--- loncom/lond 2006/05/18 19:57:59 1.330 +++ loncom/lond 2006/05/30 15:39:56 1.331 @@ -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 $DEBUG = 0; # Non zero to ena 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 @@ sub EditFile { 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::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 @@ sub sub_sql_reply { 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 {