# The LearningOnline Network # Base routines # # $Id: LONCAPA.pm,v 1.2 2006/05/30 12:45:12 www Exp $ # # Copyright Michigan State University Board of Trustees # # This file is part of the LearningOnline Network with CAPA (LON-CAPA). # # LON-CAPA is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # LON-CAPA is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with LON-CAPA; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA # # /home/httpd/html/adm/gpl.txt # # http://www.lon-capa.org/ # ### 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 &tie_domain_hash &untie_domain_hash &tie_user_hash &untie_user_hash &propath); my %perlvar; # 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 # needed sub add_get_param { my ($url,$form_data) = @_; my $needs_question_mark = ($url !~ /\?/); while (my ($name,$value) = each(%$form_data)) { if ($needs_question_mark) { $url.='?'; $needs_question_mark = 0; } else { $url.='&'; } $url.=$name.'='.&escape($form_data->{$name}); } return $url; } # -------------------------------------------------------- Escape Special Chars sub escape { my $str=shift; $str =~ s/(\W)/"%".unpack('H2',$1)/eg; return $str; } # ----------------------------------------------------- Un-Escape Special Chars sub unescape { my $str=shift; $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; 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__ =pod =head1 NAME LONCAPA - Basic routines =head1 SYNOPSIS Generally useful routines =head1 EXPORTED SUBROUTINES =over 4 =item * escape() : unpack non-word characters into CGI-compatible hex codes =item * unescape() : pack CGI-compatible hex codes into actual non-word ASCII character =item * add_get_param() : Inputs: url (with or without exit GET from parameters), hash ref of form name => value pairs Return: url with properly added the form name elements and values to the the url doing proper escaping of the values and joining with ? or & as needed =back