--- loncom/LONCAPA.pm 2006/10/13 19:11:05 1.13.2.1 +++ loncom/LONCAPA.pm 2010/06/15 05:31:43 1.30 @@ -1,7 +1,7 @@ # The LearningOnline Network # Base routines # -# $Id: LONCAPA.pm,v 1.13.2.1 2006/10/13 19:11:05 albertel Exp $ +# $Id: LONCAPA.pm,v 1.30 2010/06/15 05:31:43 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -27,6 +27,8 @@ # ### + + package LONCAPA; use strict; @@ -38,19 +40,37 @@ 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_community + $match_name + $match_lonid + $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 = 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_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 !~ /\?/); @@ -83,46 +103,76 @@ sub unescape { return $str; } +$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; +} + +$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_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; +} + # -------------------------------------------- Return path to profile directory sub propath { my ($udom,$uname)=@_; - $udom=~s/\W//g; - $uname=~s/\W//g; + $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 =~ s/\W//g; + $domain = &clean_domain($domain); # We have enough to go on to tie the hash: @@ -135,32 +185,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); } @@ -169,8 +201,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)=@_; @@ -269,8 +299,7 @@ sub _do_hash_untie { return undef; } # If this is compressed, we will actually need an exclusive lock - if (-e "$file_prefix.db.gz" - || !-e "$file_prefix.db.old" ) { + if (-e "$file_prefix.db.gz") { if (!&flock_sym(LOCK_EX)) { &clean_sym(); return undef; @@ -295,30 +324,6 @@ sub _do_hash_untie { system("gunzip $file_prefix.hist.gz"); } } - if (!-e "$file_prefix.db.old") { - my $dump_db = '/home/httpd/perl/debug/dump_db_static_32'; - my $create_db = '/home/httpd/perl/debug/create_db_dynamic_64'; - my $file = "$file_prefix.db"; - &main::logthis("Converting $file"); - if (!-x $dump_db) { - &clean_symb(); - &main::logthis("$dump_db unexecutable"); - return; - } - if (!-x $create_db) { - &clean_symb(); - &main::logthis("$create_db unexecutable"); - return; - } - system("$dump_db -f $file|$create_db -f $file.new"); - if (!-e "$file.new") { - &clean_symb(); - &main::logthis("conversion faile $file.new doesn't exist"); - return; - } - rename($file,"$file.old"); - rename("$file.new","$file"); - } # Change access mode to non-blocking $how=$how|&GDBM_NOLOCK(); # Go ahead and tie the hash @@ -373,6 +378,8 @@ __END__ =head1 NAME +Apache::LONCAPA + LONCAPA - Basic routines =head1 SYNOPSIS @@ -381,24 +388,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 +