[LON-CAPA-cvs] cvs: loncom / LONCAPA.pm lond
www
lon-capa-cvs@mail.lon-capa.org
Tue, 30 May 2006 15:39:57 -0000
www Tue May 30 11:39:57 2006 EDT
Modified files:
/loncom LONCAPA.pm lond
Log:
Separate out the locking tie/untie-hash functions, so they can be used by
service programs.
Index: loncom/LONCAPA.pm
diff -u loncom/LONCAPA.pm:1.2 loncom/LONCAPA.pm:1.3
--- loncom/LONCAPA.pm:1.2 Tue May 30 08:45:12 2006
+++ loncom/LONCAPA.pm Tue May 30 11:39:56 2006
@@ -1,7 +1,7 @@
# The LearningOnline Network
# Base routines
#
-# $Id: LONCAPA.pm,v 1.2 2006/05/30 12:45:12 www Exp $
+# $Id: LONCAPA.pm,v 1.3 2006/05/30 15:39:56 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -177,7 +177,6 @@
# make the history log entry:
if (($namespace !~/^nohist\_/) && (defined($loghead))) {
my $args = scalar @_;
- Debug(" Opening history: $file_prefix $args");
my $hfh = IO::File->new(">>$file_prefix.hist");
if($hfh) {
my $now = time;
Index: loncom/lond
diff -u loncom/lond:1.330 loncom/lond:1.331
--- loncom/lond:1.330 Thu May 18 15:57:59 2006
+++ loncom/lond Tue May 30 11:39:56 2006
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.330 2006/05/18 19:57:59 albertel Exp $
+# $Id: lond,v 1.331 2006/05/30 15:39:56 www Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -58,9 +58,8 @@
my $status='';
my $lastlog='';
-my $lond_max_wait_time = 13;
-my $VERSION='$Revision: 1.330 $'; #' stupid emacs
+my $VERSION='$Revision: 1.331 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -940,190 +939,6 @@
return "ok\n";
}
-#---------------------------------------------------------------
-#
-# Manipulation of hash based databases (factoring out common code
-# for later use as we refactor.
-#
-# Ties a domain level resource file to a hash.
-# If requested a history entry is created in the associated hist file.
-#
-# Parameters:
-# domain - Name of the domain in which the resource file lives.
-# namespace - Name of the hash within that domain.
-# how - How to tie the hash (e.g. GDBM_WRCREAT()).
-# loghead - Optional parameter, if present a log entry is created
-# in the associated history file and this is the first part
-# of that entry.
-# logtail - Goes along with loghead, The actual logentry is of the
-# form $loghead:<timestamp>:logtail.
-# Returns:
-# Reference to a hash bound to the db file or alternatively undef
-# if the tie failed.
-#
-sub tie_domain_hash {
- my ($domain,$namespace,$how,$loghead,$logtail) = @_;
-
- # Filter out any whitespace in the domain name:
-
- $domain =~ s/\W//g;
-
- # We have enough to go on to tie the hash:
-
- my $user_top_dir = $perlvar{'lonUsersDir'};
- my $domain_dir = $user_top_dir."/$domain";
- my $resource_file = $domain_dir."/$namespace";
- return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
-}
-
-sub untie_domain_hash {
- return &_locking_hash_untie(@_);
-}
-#
-# Ties a user's resource file to a hash.
-# If necessary, an appropriate history
-# log file entry is made as well.
-# This sub factors out common code from the subs that manipulate
-# the various gdbm files that keep keyword value pairs.
-# Parameters:
-# domain - Name of the domain the user is in.
-# user - Name of the 'current user'.
-# namespace - Namespace representing the file to tie.
-# how - What the tie is done to (e.g. GDBM_WRCREAT().
-# loghead - Optional first part of log entry if there may be a
-# history file.
-# what - Optional tail of log entry if there may be a history
-# file.
-# Returns:
-# hash to which the database is tied. It's up to the caller to untie.
-# undef if the has could not be tied.
-#
-sub tie_user_hash {
- my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
-
- $namespace=~s/\//\_/g; # / -> _
- $namespace=~s/\W//g; # whitespace eliminated.
- my $proname = propath($domain, $user);
-
- my $file_prefix="$proname/$namespace";
- return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
-}
-
-sub untie_user_hash {
- return &_locking_hash_untie(@_);
-}
-
-# internal routines that handle the actual tieing and untieing process
-
-sub _do_hash_tie {
- my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
- my %hash;
- if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
- # If this is a namespace for which a history is kept,
- # make the history log entry:
- if (($namespace !~/^nohist\_/) && (defined($loghead))) {
- my $args = scalar @_;
- Debug(" Opening history: $file_prefix $args");
- my $hfh = IO::File->new(">>$file_prefix.hist");
- if($hfh) {
- my $now = time;
- print $hfh "$loghead:$now:$what\n";
- }
- $hfh->close;
- }
- return \%hash;
- } else {
- return undef;
- }
-}
-
-sub _do_hash_untie {
- my ($hashref) = @_;
- my $result = untie(%$hashref);
- return $result;
-}
-
-{
- my $sym;
-
- sub _locking_hash_tie {
- my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
- my $lock_type=LOCK_SH;
-# Are we reading or writing?
- if ($how eq &GDBM_READER()) {
-# We are reading
- if (!open($sym,"$file_prefix.db.lock")) {
-# We don't have a lock file. This could mean
-# - that there is no such db-file
-# - that it does not have a lock file yet
- if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
-# No such file. Forget it.
- $! = 2;
- return undef;
- }
-# Apparently just no lock file yet. Make one
- open($sym,">>$file_prefix.db.lock");
- }
-# Do a shared lock
- if (!&flock_sym(LOCK_SH)) { return undef; }
-# If this is compressed, we will actually need an exclusive lock
- if (-e "$file_prefix.db.gz") {
- if (!&flock_sym(LOCK_EX)) { return undef; }
- }
- } elsif ($how eq &GDBM_WRCREAT()) {
-# We are writing
- open($sym,">>$file_prefix.db.lock");
-# Writing needs exclusive lock
- if (!&flock_sym(LOCK_EX)) { return undef; }
- } else {
- &logthis("Unknown method $how for $file_prefix");
- die();
- }
-# The file is ours!
-# If it is archived, un-archive it now
- if (-e "$file_prefix.db.gz") {
- system("gunzip $file_prefix.db.gz");
- if (-e "$file_prefix.hist.gz") {
- system("gunzip $file_prefix.hist.gz");
- }
- }
-# Change access mode to non-blocking
- $how=$how|&GDBM_NOLOCK();
-# Go ahead and tie the hash
- return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
- }
-
- sub flock_sym {
- my ($lock_type)=@_;
- my $failed=0;
- eval {
- local $SIG{__DIE__}='DEFAULT';
- local $SIG{ALRM}=sub {
- $failed=1;
- die("failed lock");
- };
- alarm($lond_max_wait_time);
- flock($sym,$lock_type);
- alarm(0);
- };
- if ($failed) {
- $! = 100; # throwing error # 100
- return undef;
- } else {
- return 1;
- }
- }
-
- sub _locking_hash_untie {
- my ($hashref) = @_;
- my $result = untie(%$hashref);
- flock($sym,LOCK_UN);
- close($sym);
- undef($sym);
- return $result;
- }
-}
-
# read_profile
#
# Returns a set of specific entries from a user's profile file.
@@ -5280,18 +5095,6 @@
return $answer;
}
-# -------------------------------------------- Return path to profile directory
-
-sub propath {
- my ($udom,$uname)=@_;
- $udom=~s/\W//g;
- $uname=~s/\W//g;
- my $subdir=$uname.'__';
- $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
- my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
- return $proname;
-}
-
# --------------------------------------- Is this the home server of an author?
sub ishome {