# The LearningOnline Network # Base routines # # $Id: LONCAPA.pm,v 1.19 2006/12/09 23:33:56 albertel 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; use vars qw($match_domain $match_not_domain $match_username $match_not_username $match_courseid $match_not_courseid $match_name $match_handle $match_not_handle); 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); our @EXPORT_OK = qw($match_domain $match_not_domain $match_username $match_not_username $match_courseid $match_not_courseid $match_name $match_handle $match_not_handle); our %EXPORT_TAGS = ( 'match' =>[qw($match_domain $match_not_domain $match_username $match_not_username $match_courseid $match_not_courseid $match_name $match_handle $match_not_handle)],); 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; } $match_domain = $LONCAPA::domain_re = qr{[\w\-.]+}; $match_not_domain = $LONCAPA::not_domain_re = qr{[^\w\-.]+}; sub clean_domain { my ($domain) = @_; $domain =~ s/$match_not_domain//g; return $domain; } $match_username = $LONCAPA::username_re = qr{[a-zA-Z\_][\w\-.]+}; $match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.]+}; sub clean_username { my ($username) = @_; $username =~ s/^\d+//; $username =~ s/$match_not_username//g; return $username; } $match_courseid = $LONCAPA::courseid_re = qr{\d[\w\-.]+}; $match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+}; $match_name = $LONCAPA::name = qr{$match_username|$match_courseid}; sub clean_name { my ($name) = @_; $name =~ s/$match_not_username//g; return $name; } sub split_courseid { my ($courseid) = @_; my ($domain,$coursenum) = ($courseid=~m{^/($match_domain)/($match_courseid)}); return ($domain,$coursenum); } $match_handle = $LONCAPA::handle_re = qr{[\w\-.]+}; $match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.]+}; sub clean_handle { my ($handle) = @_; $handle =~ s/$match_not_handle//g; return $handle; } # -------------------------------------------- Return path to profile directory sub propath { my ($udom,$uname)=@_; $udom = &clean_domain($udom); $uname= &clean_name($uname); 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 = &clean_domain($domain); # 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 = &clean_username($namespace); 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(@_); } # routines if you just have a filename # return tied hashref or undef sub locking_hash_tie { my ($filename,$how)=@_; my ($file_prefix,$namespace)=&db_filename_parts($filename); if ($namespace eq '') { return undef; } return &_locking_hash_tie($file_prefix,$namespace,$how); } sub locking_hash_untie { return &_locking_hash_untie(@_); } sub db_filename_parts { my ($filename)=@_; my ($file_path,$namespace)=($filename=~/^(.*)\/([^\/]+)\.db$/); if ($namespace eq '') { return undef; } return ($file_path.'/'.$namespace,$namespace); } # 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 $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; my @pushed_syms; sub clean_sym { undef($sym); } sub push_locking_hash_tie { if (!defined($sym)) { die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock."); } push(@pushed_syms,$sym); undef($sym); } sub pop_locking_hash_tie { if (defined($sym)) { die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred."); } $sym = pop(@pushed_syms); } sub _locking_hash_tie { my ($file_prefix,$namespace,$how,$loghead,$what) = @_; if (defined($sym)) { die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported'); } 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; &clean_sym(); 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)) { &clean_sym(); return undef; } # If this is compressed, we will actually need an exclusive lock if (-e "$file_prefix.db.gz") { if (!&flock_sym(LOCK_EX)) { &clean_sym(); 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)) { &clean_sym(); return undef; } } else { die("Unknown method $how for $file_prefix"); } # 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 my $result = &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); if (!$result) { &clean_sym(); } return $result; } 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); &clean_sym(); return $result; } } BEGIN { %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')}; } 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