File:  [LON-CAPA] / loncom / LONCAPA.pm
Revision 1.31: download - view: text, annotated - select for diffs
Sat May 14 16:12:53 2011 UTC (12 years, 10 months ago) by raeburn
Branches: MAIN
CVS tags: version_2_10_X, version_2_10_1, version_2_10_0, loncapaMITrelate_1, HEAD
- Duplicated &try_to_lock() routine moved to one location (in LONCAPA.pm).
- Try to get locks for lock_apachereload and lock_lciptables before
  making system calls (in lond and loncron respectively).

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

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