--- loncom/LONCAPA.pm 2006/05/08 22:05:54 1.1 +++ loncom/LONCAPA.pm 2006/05/30 12:45:12 1.2 @@ -1,7 +1,7 @@ # The LearningOnline Network # Base routines # -# $Id: LONCAPA.pm,v 1.1 2006/05/08 22:05:54 albertel Exp $ +# $Id: LONCAPA.pm,v 1.2 2006/05/30 12:45:12 www Exp $ # # Copyright Michigan State University Board of Trustees # @@ -30,11 +30,20 @@ package LONCAPA; use strict; +use lib '/home/httpd/lib/perl/'; +use LONCAPA::Configuration; +use Fcntl qw(:flock); +use GDBM_File; +use POSIX; + +my $loncapa_max_wait_time = 13; + require Exporter; our @ISA = qw (Exporter); -our @EXPORT = qw(&add_get_param &escape &unescape); +our @EXPORT = qw(&add_get_param &escape &unescape &tie_domain_hash &untie_domain_hash &tie_user_hash &untie_user_hash &propath); +my %perlvar; -# Inputs are a url, adn a hash ref of +# Inputs are a url, and a hash ref of # form name => value pairs # takes care of properly adding the form name elements and values to the # the url doing proper escaping of the values and joining with ? or & as @@ -72,6 +81,209 @@ sub unescape { return $str; } +# -------------------------------------------- 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; +} + + +#--------------------------------------------------------------- +# +# 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($loncapa_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; + } +} + +BEGIN { + my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); + %perlvar=%{$perlvarref}; + undef $perlvarref; +} + 1; __END__ @@ -109,4 +321,3 @@ add_get_param() : as needed =back -