--- loncom/LONCAPA.pm 2006/06/27 21:47:15 1.11 +++ loncom/LONCAPA.pm 2006/12/10 23:06:13 1.21 @@ -1,7 +1,7 @@ # The LearningOnline Network # Base routines # -# $Id: LONCAPA.pm,v 1.11 2006/06/27 21:47:15 albertel Exp $ +# $Id: LONCAPA.pm,v 1.21 2006/12/10 23:06:13 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -38,19 +38,30 @@ 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(&escape_LaTeX &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_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; -# Escape a LaTeX string of special characters that according to LaTeX line by line -# pg 9 are: # $ % & \ ^ _ { } ~ These are escaped by prepending a \ -# -sub escape_LaTeX { - my ($string) = @_; - $string =~ s/[\#\$\%\&\\^_{}]/\\$&/g; - return $string; -} # Inputs are a url, and a hash ref of @@ -91,12 +102,55 @@ sub unescape { 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{\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_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=~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"; @@ -130,7 +184,7 @@ sub tie_domain_hash { # 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: @@ -165,10 +219,9 @@ sub untie_domain_hash { 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); } @@ -305,7 +358,12 @@ sub _do_hash_untie { # 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); + my $result = + &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); + if (!$result) { + &clean_sym(); + } + return $result; } sub flock_sym {