Annotation of loncom/LONCAPA.pm, revision 1.25

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>