--- loncom/LONCAPA.pm 2006/11/22 19:58:29 1.14 +++ loncom/LONCAPA.pm 2011/05/14 16:12:53 1.31 @@ -1,7 +1,7 @@ # The LearningOnline Network # Base routines # -# $Id: LONCAPA.pm,v 1.14 2006/11/22 19:58:29 albertel Exp $ +# $Id: LONCAPA.pm,v 1.31 2011/05/14 16:12:53 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -27,6 +27,8 @@ # ### + + package LONCAPA; use strict; @@ -41,6 +43,10 @@ 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_community + $match_name + $match_lonid $match_handle $match_not_handle); require Exporter; @@ -50,20 +56,21 @@ our @EXPORT = qw(&add_get_param &esca &untie_user_hash &propath); our @EXPORT_OK = qw($match_domain $match_not_domain $match_username $match_not_username + $match_courseid $match_not_courseid + $match_community + $match_name + $match_lonid $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_community + $match_name + $match_lonid $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 !~ /\?/); @@ -96,71 +103,111 @@ sub unescape { return $str; } -$match_domain = $LONCAPA::domain_re = qr{[\w\-.]+}; -$match_not_domain = $LONCAPA::not_domain_re = qr{[^\w\-.]+}; +$match_domain = $LONCAPA::domain_re = qr{[[:alnum:]\-.]+}; +$match_not_domain = $LONCAPA::not_domain_re = qr{[^[:alnum:]\-.]+}; sub clean_domain { my ($domain) = @_; $domain =~ s/$match_not_domain//g; return $domain; } -sub split_courseid { - my ($courseid) = @_; - my ($domain,$coursenum) = - ($courseid=~m{^/($match_domain)/($match_username)}); - return ($domain,$coursenum); -} - -$match_username = $LONCAPA::username_re = qr{[\w\-.]+}; -$match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.]+}; +$match_username = $LONCAPA::username_re = qr{\w[\w\-.@]+}; +$match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.@]+}; sub clean_username { my ($username) = @_; + $username =~ s/^\W+//; $username =~ s/$match_not_username//g; return $username; } -$match_handle = $LONCAPA::handle_re = qr{[\w\-.]+}; -$match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.]+}; + +$match_courseid = $LONCAPA::courseid_re = qr{\d[\w\-.]+}; +$match_community =$LONCAPA::community_re = qr{0[\w\-.]+}; +$match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+}; +sub clean_courseid { + my ($courseid) = @_; + $courseid =~ s/^\D+//; + $courseid =~ s/$match_not_courseid//g; + return $courseid; +} + +$match_name = $LONCAPA::name_re = qr{$match_username|$match_courseid}; +sub clean_name { + my ($name) = @_; + $name =~ s/$match_not_username//g; + return $name; +} + +$match_lonid = $LONCAPA::lonid_re = qr{[\w\-.]+}; + +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; } +# +# -- Ensure another process for same filesystem action is not running. +# lond uses for: apachereload; loncron uses for: lciptables +# + +sub try_to_lock { + my ($lockfile)=@_; + my $currentpid; + my $lastpid; + # Do not manipulate lock file as root + if ($>==0) { + return 0; + } + # Try to generate lock file. + # Wait 3 seconds. If same process id is in + # lock file, then assume lock file is stale, and + # go ahead. If process id's fluctuate, try + # for a maximum of 10 times. + for (0..10) { + if (-e $lockfile) { + open(LOCK,"<$lockfile"); + $currentpid=; + close LOCK; + if ($currentpid==$lastpid) { + last; + } + sleep 3; + $lastpid=$currentpid; + } else { + last; + } + if ($_==10) { + return 0; + } + } + open(LOCK,">$lockfile"); + print LOCK $$; + close LOCK; + return 1; +} + # -------------------------------------------- Return path to profile directory sub propath { my ($udom,$uname)=@_; $udom = &clean_domain($udom); - $uname= &clean_username($uname); + $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) = @_; @@ -179,32 +226,14 @@ sub tie_domain_hash { 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); - + $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); } @@ -213,8 +242,6 @@ 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)=@_; @@ -392,6 +419,8 @@ __END__ =head1 NAME +Apache::LONCAPA + LONCAPA - Basic routines =head1 SYNOPSIS @@ -400,24 +429,89 @@ Generally useful routines =head1 EXPORTED SUBROUTINES -=over 4 +=over -=item * +=item escape() -escape() : unpack non-word characters into CGI-compatible hex codes +unpack non-word characters into CGI-compatible hex codes -=item * +=item unescape() -unescape() : pack CGI-compatible hex codes into actual non-word ASCII character + pack CGI-compatible hex codes into actual non-word ASCII character -=item * +=item add_get_param() -add_get_param() : +Append escaped form elements (name=value etc.) to a url. + 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 & + Return: url with form name elements and values appended to the + the url, doing proper escaping of the values and joining with ? or & as needed +=item clean_handle() + +=item propath() + +=item untie_domain_hash() + +=item tie_domain_hash() + +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. + +=item tie_user_hash() + + 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. + +=item locking_hash_tie() + +routines if you just have a filename return tied hashref or undef + +=item locking_hash_untie() + +=item db_filename_parts() + +=head1 INTERNAL SUBROUTINES + +=item _do_hash_tie() + +=item _do_hash_untie() + =back + +=cut + 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.