Annotation of loncom/LONCAPA.pm, revision 1.30

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

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