Return to LONCAPA.pm CVS log

Up to [LON-CAPA] / loncom

- course ids and usernames are slightly different (courseids must start \d\w\d usernames can not start with a digit) add re for both course ids and any kind of internal name

    1: # The LearningOnline Network
    2: # Base routines
    3: #
    4: # $Id: LONCAPA.pm,v 1.16 2006/12/01 21:52:28 albertel Exp $
    5: #
    6: # Copyright Michigan State University Board of Trustees
    7: #
    8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
    9: #
   10: # LON-CAPA is free software; you can redistribute it and/or modify
   11: # it under the terms of the GNU General Public License as published by
   12: # the Free Software Foundation; either version 2 of the License, or
   13: # (at your option) any later version.
   14: #
   15: # LON-CAPA is distributed in the hope that it will be useful,
   16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
   17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   18: # GNU General Public License for more details.
   19: #
   20: # You should have received a copy of the GNU General Public License
   21: # along with LON-CAPA; if not, write to the Free Software
   22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   23: #
   24: # /home/httpd/html/adm/gpl.txt
   25: #
   26: # http://www.lon-capa.org/
   27: #
   28: ###
   29: 
   30: package LONCAPA;
   31: 
   32: use strict;
   33: use lib '/home/httpd/lib/perl/';
   34: use LONCAPA::Configuration;
   35: use Fcntl qw(:flock);
   36: use GDBM_File;
   37: use POSIX;
   38: 
   39: my $loncapa_max_wait_time = 13;
   40: 
   41: 
   42: use vars qw($match_domain   $match_not_domain
   43: 	    $match_username $match_not_username
   44: 	    $match_courseid $match_not_courseid
   45: 	    $match_name
   46: 	    $match_handle   $match_not_handle);
   47: 
   48: require Exporter;
   49: our @ISA = qw (Exporter);
   50: our @EXPORT = qw(&add_get_param    &escape            &unescape       
   51: 		 &tie_domain_hash  &untie_domain_hash &tie_user_hash
   52: 		 &untie_user_hash  &propath);
   53: our @EXPORT_OK = qw($match_domain   $match_not_domain
   54: 		    $match_username $match_not_username
   55: 		    $match_courseid $match_not_courseid
   56: 		    $match_name
   57: 		    $match_handle   $match_not_handle);
   58: our %EXPORT_TAGS = ( 'match' =>[qw($match_domain   $match_not_domain
   59: 				   $match_username $match_not_username
   60: 				   $match_courseid $match_not_courseid
   61: 				   $match_name
   62: 				   $match_handle   $match_not_handle)],);
   63: my %perlvar;
   64: 
   65: 
   66: 
   67: # Inputs are a url, and a hash ref of
   68: # form name => value pairs
   69: # takes care of properly adding the form name elements and values to the 
   70: # the url doing proper escaping of the values and joining with ? or & as 
   71: # needed
   72: 
   73: sub add_get_param {
   74:     my ($url,$form_data) = @_;
   75:     my $needs_question_mark = ($url !~ /\?/);
   76: 
   77:     while (my ($name,$value) = each(%$form_data)) {
   78: 	if ($needs_question_mark) {
   79: 	    $url.='?';
   80: 	    $needs_question_mark = 0;
   81: 	} else { 
   82: 	    $url.='&';
   83: 	}
   84: 	$url.=$name.'='.&escape($form_data->{$name});
   85:     }
   86:     return $url;
   87: }
   88: 
   89: # -------------------------------------------------------- Escape Special Chars
   90: 
   91: sub escape {
   92:     my $str=shift;
   93:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
   94:     return $str;
   95: }
   96: 
   97: # ----------------------------------------------------- Un-Escape Special Chars
   98: 
   99: sub unescape {
  100:     my $str=shift;
  101:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  102:     return $str;
  103: }
  104: 
  105: $match_domain     = $LONCAPA::domain_re     = qr{[\w\-.]+};
  106: $match_not_domain = $LONCAPA::not_domain_re = qr{[^\w\-.]+};
  107: sub clean_domain {
  108:     my ($domain) = @_;
  109:     $domain =~ s/$match_not_domain//g;
  110:     return $domain;
  111: }
  112: 
  113: $match_username     = $LONCAPA::username_re     = qr{[^a-zA-Z\_][\w\-.]+};
  114: $match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.]+};
  115: sub clean_username {
  116:     my ($username) = @_;
  117:     $username =~ s/^\d+//;
  118:     $username =~ s/$match_not_username//g;
  119:     return $username;
  120: }
  121: 
  122: 
  123: $match_courseid     = $LONCAPA::courseid_re     = qr{\d[\w\-.]+};
  124: $match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+};
  125: sub is_courseid {
  126:     my ($courseid) = @_;
  127:     return ($courseid =~ m/^$match_courseid$/);
  128: }
  129: 
  130: $match_name  = qr{$match_username|$match_courseid};
  131: sub clean_name {
  132:     my ($name) = @_;
  133:     $name =~ s/$match_not_username//g;
  134:     return $name;
  135: }
  136: 
  137: sub split_courseid {
  138:     my ($courseid) = @_;
  139:     my  ($domain,$coursenum) = 
  140: 	($courseid=~m{^/($match_domain)/($match_courseid)});
  141:     return ($domain,$coursenum);
  142: }
  143: 
  144: $match_handle     = $LONCAPA::handle_re     = qr{[\w\-.]+};
  145: $match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.]+};
  146: sub clean_handle {
  147:     my ($handle) = @_;
  148:     $handle =~ s/$match_not_handle//g;
  149:     return $handle;
  150: }
  151: 
  152: # -------------------------------------------- Return path to profile directory
  153: 
  154: sub propath {
  155:     my ($udom,$uname)=@_;
  156:     $udom = &clean_domain($udom);
  157:     $uname= &clean_name($uname);
  158:     my $subdir=$uname.'__';
  159:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
  160:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
  161:     return $proname;
  162: } 
  163: 
  164: 
  165: #---------------------------------------------------------------
  166: #
  167: # Manipulation of hash based databases (factoring out common code
  168: # for later use as we refactor.
  169: #
  170: #  Ties a domain level resource file to a hash.
  171: #  If requested a history entry is created in the associated hist file.
  172: #
  173: #  Parameters:
  174: #     domain    - Name of the domain in which the resource file lives.
  175: #     namespace - Name of the hash within that domain.
  176: #     how       - How to tie the hash (e.g. GDBM_WRCREAT()).
  177: #     loghead   - Optional parameter, if present a log entry is created
  178: #                 in the associated history file and this is the first part
  179: #                  of that entry.
  180: #     logtail   - Goes along with loghead,  The actual logentry is of the
  181: #                 form $loghead:<timestamp>:logtail.
  182: # Returns:
  183: #    Reference to a hash bound to the db file or alternatively undef
  184: #    if the tie failed.
  185: #
  186: sub tie_domain_hash {
  187:     my ($domain,$namespace,$how,$loghead,$logtail) = @_;
  188:     
  189:     # Filter out any whitespace in the domain name:
  190:     
  191:     $domain = &clean_domain($domain);
  192:     
  193:     # We have enough to go on to tie the hash:
  194:     
  195:     my $user_top_dir   = $perlvar{'lonUsersDir'};
  196:     my $domain_dir     = $user_top_dir."/$domain";
  197:     my $resource_file  = $domain_dir."/$namespace";
  198:     return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
  199: }
  200: 
  201: sub untie_domain_hash {
  202:     return &_locking_hash_untie(@_);
  203: }
  204: #
  205: #   Ties a user's resource file to a hash.  
  206: #   If necessary, an appropriate history
  207: #   log file entry is made as well.
  208: #   This sub factors out common code from the subs that manipulate
  209: #   the various gdbm files that keep keyword value pairs.
  210: # Parameters:
  211: #   domain       - Name of the domain the user is in.
  212: #   user         - Name of the 'current user'.
  213: #   namespace    - Namespace representing the file to tie.
  214: #   how          - What the tie is done to (e.g. GDBM_WRCREAT().
  215: #   loghead      - Optional first part of log entry if there may be a
  216: #                  history file.
  217: #   what         - Optional tail of log entry if there may be a history
  218: #                  file.
  219: # Returns:
  220: #   hash to which the database is tied.  It's up to the caller to untie.
  221: #   undef if the has could not be tied.
  222: #
  223: sub tie_user_hash {
  224:     my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
  225: 
  226:     $namespace=~s{/}{_}g;	# / -> _
  227:     $namespace     = &clean_username($namespace);
  228:     my $proname    = &propath($domain, $user);
  229:     my $file_prefix="$proname/$namespace";
  230:     return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
  231: }
  232: 
  233: sub untie_user_hash {
  234:     return &_locking_hash_untie(@_);
  235: }
  236: 
  237: # routines if you just have a filename
  238: # return tied hashref or undef
  239: 
  240: sub locking_hash_tie {
  241:     my ($filename,$how)=@_;
  242:     my ($file_prefix,$namespace)=&db_filename_parts($filename);
  243:     if ($namespace eq '') { return undef; }
  244:     return &_locking_hash_tie($file_prefix,$namespace,$how);
  245: }
  246: 
  247: sub locking_hash_untie {
  248:     return &_locking_hash_untie(@_);
  249: }
  250: 
  251: sub db_filename_parts {
  252:     my ($filename)=@_;
  253:     my ($file_path,$namespace)=($filename=~/^(.*)\/([^\/]+)\.db$/);
  254:     if ($namespace eq '') { return undef; }
  255:     return ($file_path.'/'.$namespace,$namespace);
  256: }
  257: 
  258: # internal routines that handle the actual tieing and untieing process
  259: 
  260: sub _do_hash_tie {
  261:     my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
  262:     my %hash;
  263:     if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
  264: 	# If this is a namespace for which a history is kept,
  265: 	# make the history log entry:    
  266: 	if (($namespace !~/^nohist\_/) && (defined($loghead))) {
  267: 	    my $hfh = IO::File->new(">>$file_prefix.hist"); 
  268: 	    if($hfh) {
  269: 		my $now = time();
  270: 		print $hfh ("$loghead:$now:$what\n");
  271: 	    }
  272: 	    $hfh->close;
  273: 	}
  274: 	return \%hash;
  275:     } else {
  276: 	return undef;
  277:     }
  278: }
  279: 
  280: sub _do_hash_untie {
  281:     my ($hashref) = @_;
  282:     my $result = untie(%$hashref);
  283:     return $result;
  284: }
  285: 
  286: {
  287:     my $sym;
  288:     my @pushed_syms;
  289: 
  290:     sub clean_sym {
  291: 	undef($sym);
  292:     }
  293:     sub push_locking_hash_tie {
  294: 	if (!defined($sym)) {
  295: 	    die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock.");
  296: 	}
  297: 	push(@pushed_syms,$sym);
  298: 	undef($sym);
  299:     }
  300: 
  301:     sub pop_locking_hash_tie {
  302: 	if (defined($sym)) {
  303: 	    die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred.");
  304: 	}
  305: 	$sym = pop(@pushed_syms);
  306:     }
  307: 
  308:     sub _locking_hash_tie {
  309: 	my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
  310: 	if (defined($sym)) {
  311: 	    die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
  312: 	}
  313: 
  314:         my $lock_type=LOCK_SH;
  315: # Are we reading or writing?
  316:         if ($how eq &GDBM_READER()) {
  317: # We are reading
  318:            if (!open($sym,"$file_prefix.db.lock")) {
  319: # We don't have a lock file. This could mean
  320: # - that there is no such db-file
  321: # - that it does not have a lock file yet
  322:                if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
  323: # No such file. Forget it.                
  324:                    $! = 2;
  325: 		   &clean_sym();
  326:                    return undef;
  327:                }
  328: # Apparently just no lock file yet. Make one
  329:                open($sym,">>$file_prefix.db.lock");
  330:            }
  331: # Do a shared lock
  332:            if (!&flock_sym(LOCK_SH)) { 
  333: 	       &clean_sym();
  334: 	       return undef; 
  335: 	   } 
  336: # If this is compressed, we will actually need an exclusive lock
  337: 	   if (-e "$file_prefix.db.gz") {
  338: 	       if (!&flock_sym(LOCK_EX)) {
  339: 		   &clean_sym();
  340: 		   return undef;
  341: 	       }
  342: 	   }
  343:         } elsif ($how eq &GDBM_WRCREAT()) {
  344: # We are writing
  345:            open($sym,">>$file_prefix.db.lock");
  346: # Writing needs exclusive lock
  347:            if (!&flock_sym(LOCK_EX)) {
  348: 	       &clean_sym();
  349: 	       return undef;
  350: 	   }
  351:         } else {
  352:            die("Unknown method $how for $file_prefix");
  353:         }
  354: # The file is ours!
  355: # If it is archived, un-archive it now
  356:        if (-e "$file_prefix.db.gz") {
  357:            system("gunzip $file_prefix.db.gz");
  358: 	   if (-e "$file_prefix.hist.gz") {
  359: 	       system("gunzip $file_prefix.hist.gz");
  360: 	   }
  361:        }
  362: # Change access mode to non-blocking
  363:        $how=$how|&GDBM_NOLOCK();
  364: # Go ahead and tie the hash
  365:       	my $result = 
  366: 	    &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
  367: 	if (!$result) {
  368: 	    &clean_sym();
  369: 	}
  370: 	return $result;
  371:     }
  372: 
  373:     sub flock_sym {
  374:         my ($lock_type)=@_;
  375: 	my $failed=0;
  376: 	eval {
  377: 	    local $SIG{__DIE__}='DEFAULT';
  378: 	    local $SIG{ALRM}=sub {
  379: 		$failed=1;
  380: 		die("failed lock");
  381: 	    };
  382: 	    alarm($loncapa_max_wait_time);
  383: 	    flock($sym,$lock_type);
  384: 	    alarm(0);
  385: 	};
  386: 	if ($failed) {
  387: 	    $! = 100; # throwing error # 100
  388: 	    return undef;
  389: 	} else {
  390: 	    return 1;
  391: 	}
  392:     }
  393: 
  394:     sub _locking_hash_untie {
  395: 	my ($hashref) = @_;
  396: 	my $result = untie(%$hashref);
  397: 	flock($sym,LOCK_UN);
  398: 	close($sym);
  399: 	&clean_sym();
  400: 	return $result;
  401:     }
  402: }
  403: 
  404: BEGIN {
  405:     %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
  406: }
  407: 
  408: 1;
  409: 
  410: __END__
  411: 
  412: =pod
  413: 
  414: =head1 NAME
  415: 
  416: LONCAPA - Basic routines
  417: 
  418: =head1 SYNOPSIS
  419: 
  420: Generally useful routines
  421: 
  422: =head1 EXPORTED SUBROUTINES
  423: 
  424: =over 4
  425: 
  426: =item *
  427: 
  428: escape() : unpack non-word characters into CGI-compatible hex codes
  429: 
  430: =item *
  431: 
  432: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
  433: 
  434: =item *
  435: 
  436: add_get_param() :
  437:  Inputs:  url (with or without exit GET from parameters), hash ref of
  438:               form name => value pairs
  439: 
  440:  Return: url with properly added the form name elements and values to the 
  441:          the url doing proper escaping of the values and joining with ? or &
  442:          as needed
  443: 
  444: =back