File:  [LON-CAPA] / loncom / LONCAPA.pm
Revision 1.34: download - view: text, annotated - select for diffs
Fri Feb 8 14:49:51 2013 UTC (11 years, 1 month ago) by raeburn
Branches: MAIN
CVS tags: version_2_11_2_uiuc, version_2_11_2_msu, version_2_11_2_educog, version_2_11_2, version_2_11_1, version_2_11_0_RC3, version_2_11_0_RC2, version_2_11_0_RC1, version_2_11_0, HEAD
- Move routine used to get Linux distro from &get_distro() in loncron
  to &distro() in LONCAPA.pm to facilitate reuse.

    1: # The LearningOnline Network
    2: # Base routines
    3: #
    4: # $Id: LONCAPA.pm,v 1.34 2013/02/08 14:49:51 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: #use Apache::lonnet;
   41: 
   42: my $loncapa_max_wait_time = 13;
   43: 
   44: 
   45: #--------------------------------------------------------------------------
   46: #
   47: #   The  constant definnitions below probably should really be in 
   48: #   a configuration file somewhere (loncapa.conf?) and loaded so that they can be 
   49: #   modified without requring source code changes:
   50: #
   51: #   COURSE_CACHE_TIME - Number of minutes after which an unaccessed
   52: #                       course.db or course_param.db file is considered
   53: #                       to be a stale cache of this info.
   54: #
   55: #   LONCAPA_TEMPDIR   - Place loncapa puts temporary files
   56: #
   57: 
   58: my  $COURSE_CACHE_TIME =  60;	# minutes course cache file is considered valid. 
   59: my  $LONCAPA_TEMPDIR   =  '/tmp/'; # relative to configuration{'lonTabDir'}.
   60: 
   61: use vars qw($match_domain   $match_not_domain
   62: 	    $match_username $match_not_username
   63: 	    $match_courseid $match_not_courseid
   64:             $match_community
   65: 	    $match_name
   66:             $match_lonid
   67: 	    $match_handle   $match_not_handle);
   68: 
   69: require Exporter;
   70: our @ISA = qw (Exporter);
   71: our @EXPORT = qw(&add_get_param    &escape            &unescape       
   72: 		 &tie_domain_hash  &untie_domain_hash &tie_user_hash
   73: 		 &untie_user_hash  &propath &tie_course);
   74: our @EXPORT_OK = qw($match_domain   $match_not_domain
   75: 		    $match_username $match_not_username
   76: 		    $match_courseid $match_not_courseid
   77:                     $match_community
   78: 		    $match_name
   79: 		    $match_lonid
   80: 		    $match_handle   $match_not_handle &tie_course);
   81: our %EXPORT_TAGS = ( 'match' =>[qw($match_domain   $match_not_domain
   82: 				   $match_username $match_not_username
   83: 				   $match_courseid $match_not_courseid
   84:                                    $match_community
   85: 				   $match_name
   86: 				   $match_lonid
   87: 				   $match_handle   $match_not_handle)],);
   88: my %perlvar;
   89: 
   90: 
   91: #
   92: # If necessary fetch and tie a user's image of the course hash 
   93: # to the specified hash
   94: # Parameters:
   95: #   domain   - User's domain
   96: #   user     - Name of user.
   97: #   course   - Course number.
   98: #   cdom     - Domain that is home to the course
   99: #   hash     - reference to the has to tie.
  100: #
  101: # Side effects:
  102: #   a gdbm file and it's associated lock file will be created in the 
  103: #   tmp directory tree.
  104: #
  105: # Returns:
  106: #   0 - failure.
  107: #   1 - success.
  108: #
  109: #  Note:
  110: #     It's possible the required user's db file is already present in the tempdir.
  111: #     in that case a decision must be made about whether or not to just tie to it
  112: #     or to fetch it again. Remember this sub could be called in the context of a user
  113: #     other than the one whose data are being fetched.  We don't know if that user already
  114: #     has a live session on this server.  What we'll do is only re-fetch if the hash atime.
  115: #     is older than COURSE_CACHE_TIME...that is if it's been accessed relatively recently
  116: #     where COURSE_CACHE_TIME defines the caching time.
  117: #
  118: #     The database files this function creates are of the form:
  119: #     $user@$domain_$course@$cdom.{db,lock}
  120: #     This differs from the prior filenames.  Therefore if a module does its own
  121: #     caching (That's a coding no-no) and does not use this centralized sub,
  122: #     multiple cache files for the same course/user will be created. 
  123: #  
  124: sub tie_course {
  125:     my ($domain, $user, $course, $cdom, $hash) = @_;
  126: 
  127:     #
  128:     #  See if we need to re-fetch the course data
  129:     #
  130: 
  131:     
  132: }
  133: 
  134: # Return a string that is the path in which loncapa puts temp files:
  135: 
  136: sub tempdir {
  137:     my $result =  $perlvar{'lonDaemons'}.$LONCAPA_TEMPDIR; # to allow debugging.
  138:     return $result;
  139: }
  140: 
  141: # Return the Linux distro where this LON-CAPA instance is running
  142: 
  143: sub distro {
  144:     my $distro;
  145:     if (open(PIPE,"/home/httpd/perl/distprobe |")) {
  146:         $distro = <PIPE>;
  147:         close(PIPE);
  148:     }
  149:     return $distro;
  150: }
  151: 
  152: #----------------------------------------------------------------------
  153: #
  154: #  some of these subs need a bit of documentation
  155: 
  156: sub add_get_param {
  157:     my ($url,$form_data) = @_;
  158:     my $needs_question_mark = ($url !~ /\?/);
  159: 
  160:     while (my ($name,$value) = each(%$form_data)) {
  161: 	if ($needs_question_mark) {
  162: 	    $url.='?';
  163: 	    $needs_question_mark = 0;
  164: 	} else { 
  165: 	    $url.='&';
  166: 	}
  167: 	$url.=$name.'='.&escape($form_data->{$name});
  168:     }
  169:     return $url;
  170: }
  171: 
  172: # -------------------------------------------------------- Escape Special Chars
  173: 
  174: sub escape {
  175:     my $str=shift;
  176:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
  177:     return $str;
  178: }
  179: 
  180: # ----------------------------------------------------- Un-Escape Special Chars
  181: 
  182: sub unescape {
  183:     my $str=shift;
  184:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
  185:     return $str;
  186: }
  187: 
  188: $LONCAPA::assess_re = qr{\.(problem|exam|quiz|assess|survey|form|library|task)$};
  189: $LONCAPA::assess_page_re = qr{\.(problem|exam|quiz|assess|survey|form|library|task|page)$};
  190: $LONCAPA::assess_page_seq_re = qr{\.(problem|exam|quiz|assess|survey|form|library|task|sequence|page)$};
  191: $LONCAPA::parse_re = qr{\.(problem|exam|quiz|assess|survey|form|library|page|xml|html|htm|xhtml|xhtm)$};
  192: $LONCAPA::parse_page_re = qr{\.(problem|exam|quiz|assess|survey|form|library|page|xml|html|htm|xhtml|xhtm|page)$};
  193: $LONCAPA::parse_page_sty_re = qr{\.(problem|exam|quiz|assess|survey|form|library|page|xml|html|htm|xhtml|xhtm|page|sty)$};
  194: 
  195: 
  196: $match_domain     = $LONCAPA::domain_re     = qr{[[:alnum:]\-.]+};
  197: $match_not_domain = $LONCAPA::not_domain_re = qr{[^[:alnum:]\-.]+};
  198: sub clean_domain {
  199:     my ($domain) = @_;
  200:     $domain =~ s/$match_not_domain//g;
  201:     return $domain;
  202: }
  203: 
  204: $match_username     = $LONCAPA::username_re     = qr{\w[\w\-.@]+};
  205: $match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.@]+};
  206: sub clean_username {
  207:     my ($username) = @_;
  208:     $username =~ s/^\W+//;
  209:     $username =~ s/$match_not_username//g;
  210:     return $username;
  211: }
  212: 
  213: 
  214: $match_courseid     = $LONCAPA::courseid_re     = qr{\d[\w\-.]+};
  215: $match_community    =$LONCAPA::community_re     = qr{0[\w\-.]+};
  216: $match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+};
  217: sub clean_courseid {
  218:     my ($courseid) = @_;
  219:     $courseid =~ s/^\D+//;
  220:     $courseid =~ s/$match_not_courseid//g;
  221:     return $courseid;
  222: }
  223: 
  224: $match_name         = $LONCAPA::name_re = qr{$match_username|$match_courseid};
  225: sub clean_name {
  226:     my ($name) = @_;
  227:     $name =~ s/$match_not_username//g;
  228:     return $name;
  229: }
  230: 
  231: $match_lonid     = $LONCAPA::lonid_re     = qr{[\w\-.]+};
  232: 
  233: sub split_courseid {
  234:     my ($courseid) = @_;
  235:     my  ($domain,$coursenum) = 
  236: 	($courseid=~m{^/($match_domain)/($match_courseid)});
  237:     return ($domain,$coursenum);
  238: }
  239: 
  240: $match_handle     = $LONCAPA::handle_re     = qr{[\w\-.@]+};
  241: $match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.@]+};
  242: sub clean_handle {
  243:     my ($handle) = @_;
  244:     $handle =~ s/$match_not_handle//g;
  245:     return $handle;
  246: }
  247: 
  248: #
  249: # -- Ensure another process for same filesystem action is not running.
  250: #    lond uses for: apachereload; loncron uses for: lciptables
  251: #
  252: 
  253: sub try_to_lock {
  254:     my ($lockfile)=@_;
  255:     my $currentpid;
  256:     my $lastpid;
  257:     # Do not manipulate lock file as root
  258:     if ($>==0) {
  259:         return 0;
  260:     }
  261:     # Try to generate lock file.
  262:     # Wait 3 seconds.  If same process id is in
  263:     # lock file, then assume lock file is stale, and
  264:     # go ahead.  If process id's fluctuate, try
  265:     # for a maximum of 10 times.
  266:     for (0..10) {
  267:         if (-e $lockfile) { 
  268:             open(LOCK,"<$lockfile");
  269:             $currentpid=<LOCK>;
  270:             close LOCK;
  271:             if ($currentpid==$lastpid) {
  272:                 last;
  273:             }
  274:             sleep 3;
  275:             $lastpid=$currentpid;
  276:         } else {
  277:             last;
  278:         }
  279:         if ($_==10) {
  280:             return 0;
  281:         }
  282:     }
  283:     open(LOCK,">$lockfile");
  284:     print LOCK $$;
  285:     close LOCK;
  286:     return 1;
  287: }
  288: 
  289: # -------------------------------------------- Return path to profile directory
  290: 
  291: sub propath {
  292:     my ($udom,$uname)=@_;
  293:     $udom = &clean_domain($udom);
  294:     $uname= &clean_name($uname);
  295:     my $subdir=$uname.'__';
  296:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
  297:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
  298:     return $proname;
  299: }
  300: 
  301: sub tie_domain_hash {
  302:     my ($domain,$namespace,$how,$loghead,$logtail) = @_;
  303:     
  304:     # Filter out any whitespace in the domain name:
  305:     
  306:     $domain = &clean_domain($domain);
  307:     
  308:     # We have enough to go on to tie the hash:
  309:     
  310:     my $user_top_dir   = $perlvar{'lonUsersDir'};
  311:     my $domain_dir     = $user_top_dir."/$domain";
  312:     my $resource_file  = $domain_dir."/$namespace";
  313:     return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
  314: }
  315: 
  316: sub untie_domain_hash {
  317:     return &_locking_hash_untie(@_);
  318: }
  319: 
  320: 
  321: sub tie_user_hash {
  322:     my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
  323: 
  324:     $namespace=~s{/}{_}g;	# / -> _
  325:     $namespace     = &clean_username($namespace);
  326:     my $proname    = &propath($domain, $user);
  327:     my $file_prefix="$proname/$namespace";
  328:     return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
  329: }
  330: 
  331: sub untie_user_hash {
  332:     return &_locking_hash_untie(@_);
  333: }
  334: 
  335: 
  336: sub locking_hash_tie {
  337:     my ($filename,$how)=@_;
  338:     my ($file_prefix,$namespace)=&db_filename_parts($filename);
  339:     if ($namespace eq '') { return undef; }
  340:     return &_locking_hash_tie($file_prefix,$namespace,$how);
  341: }
  342: 
  343: sub locking_hash_untie {
  344:     return &_locking_hash_untie(@_);
  345: }
  346: 
  347: sub db_filename_parts {
  348:     my ($filename)=@_;
  349:     my ($file_path,$namespace)=($filename=~/^(.*)\/([^\/]+)\.db$/);
  350:     if ($namespace eq '') { return undef; }
  351:     return ($file_path.'/'.$namespace,$namespace);
  352: }
  353: 
  354: # internal routines that handle the actual tieing and untieing process
  355: 
  356: sub _do_hash_tie {
  357:     my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
  358:     my %hash;
  359:     if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
  360: 	# If this is a namespace for which a history is kept,
  361: 	# make the history log entry:    
  362: 	if (($namespace !~/^nohist\_/) && (defined($loghead))) {
  363: 	    my $hfh = IO::File->new(">>$file_prefix.hist"); 
  364: 	    if($hfh) {
  365: 		my $now = time();
  366: 		print $hfh ("$loghead:$now:$what\n");
  367: 	    }
  368: 	    $hfh->close;
  369: 	}
  370: 	return \%hash;
  371:     } else {
  372: 	return undef;
  373:     }
  374: }
  375: 
  376: sub _do_hash_untie {
  377:     my ($hashref) = @_;
  378:     my $result = untie(%$hashref);
  379:     return $result;
  380: }
  381: 
  382: {
  383:     my $sym;
  384:     my @pushed_syms;
  385: 
  386:     sub clean_sym {
  387: 	undef($sym);
  388:     }
  389:     sub push_locking_hash_tie {
  390: 	if (!defined($sym)) {
  391: 	    die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock.");
  392: 	}
  393: 	push(@pushed_syms,$sym);
  394: 	undef($sym);
  395:     }
  396: 
  397:     sub pop_locking_hash_tie {
  398: 	if (defined($sym)) {
  399: 	    die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred.");
  400: 	}
  401: 	$sym = pop(@pushed_syms);
  402:     }
  403: 
  404:     sub _locking_hash_tie {
  405: 	my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
  406: 	if (defined($sym)) {
  407: 	    die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
  408: 	}
  409: 
  410:         my $lock_type=LOCK_SH;
  411: # Are we reading or writing?
  412:         if ($how eq &GDBM_READER()) {
  413: # We are reading
  414:            if (!open($sym,"$file_prefix.db.lock")) {
  415: # We don't have a lock file. This could mean
  416: # - that there is no such db-file
  417: # - that it does not have a lock file yet
  418:                if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
  419: # No such file. Forget it.                
  420:                    $! = 2;
  421: 		   &clean_sym();
  422:                    return undef;
  423:                }
  424: # Apparently just no lock file yet. Make one
  425:                open($sym,">>$file_prefix.db.lock");
  426:            }
  427: # Do a shared lock
  428:            if (!&flock_sym(LOCK_SH)) { 
  429: 	       &clean_sym();
  430: 	       return undef; 
  431: 	   } 
  432: # If this is compressed, we will actually need an exclusive lock
  433: 	   if (-e "$file_prefix.db.gz") {
  434: 	       if (!&flock_sym(LOCK_EX)) {
  435: 		   &clean_sym();
  436: 		   return undef;
  437: 	       }
  438: 	   }
  439:         } elsif ($how eq &GDBM_WRCREAT()) {
  440: # We are writing
  441:            open($sym,">>$file_prefix.db.lock");
  442: # Writing needs exclusive lock
  443:            if (!&flock_sym(LOCK_EX)) {
  444: 	       &clean_sym();
  445: 	       return undef;
  446: 	   }
  447:         } else {
  448:            die("Unknown method $how for $file_prefix");
  449:         }
  450: # The file is ours!
  451: # If it is archived, un-archive it now
  452:        if (-e "$file_prefix.db.gz") {
  453:            system("gunzip $file_prefix.db.gz");
  454: 	   if (-e "$file_prefix.hist.gz") {
  455: 	       system("gunzip $file_prefix.hist.gz");
  456: 	   }
  457:        }
  458: # Change access mode to non-blocking
  459:        $how=$how|&GDBM_NOLOCK();
  460: # Go ahead and tie the hash
  461:       	my $result = 
  462: 	    &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
  463: 	if (!$result) {
  464: 	    &clean_sym();
  465: 	}
  466: 	return $result;
  467:     }
  468: 
  469:     sub flock_sym {
  470:         my ($lock_type)=@_;
  471: 	my $failed=0;
  472: 	eval {
  473: 	    local $SIG{__DIE__}='DEFAULT';
  474: 	    local $SIG{ALRM}=sub {
  475: 		$failed=1;
  476: 		die("failed lock");
  477: 	    };
  478: 	    alarm($loncapa_max_wait_time);
  479: 	    flock($sym,$lock_type);
  480: 	    alarm(0);
  481: 	};
  482: 	if ($failed) {
  483: 	    $! = 100; # throwing error # 100
  484: 	    return undef;
  485: 	} else {
  486: 	    return 1;
  487: 	}
  488:     }
  489: 
  490:     sub _locking_hash_untie {
  491: 	my ($hashref) = @_;
  492: 	my $result = untie(%$hashref);
  493: 	flock($sym,LOCK_UN);
  494: 	close($sym);
  495: 	&clean_sym();
  496: 	return $result;
  497:     }
  498: }
  499: 
  500: 
  501: BEGIN {
  502:     %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
  503: }
  504: 
  505: 1;
  506: 
  507: __END__
  508: 
  509: =pod
  510: 
  511: =head1 NAME
  512: 
  513: Apache::LONCAPA
  514: 
  515: LONCAPA - Basic routines
  516: 
  517: =head1 SYNOPSIS
  518: 
  519: Generally useful routines
  520: 
  521: =head1 EXPORTED SUBROUTINES
  522: 
  523: =over
  524: 
  525: =item escape()
  526: 
  527: unpack non-word characters into CGI-compatible hex codes
  528: 
  529: =item unescape()
  530: 
  531:  pack CGI-compatible hex codes into actual non-word ASCII character
  532: 
  533: =item  add_get_param()
  534: 
  535: Append escaped form elements (name=value etc.) to a url.
  536:  
  537:  Inputs:  url (with or without exit GET from parameters), hash ref of
  538:               form name => value pairs
  539: 
  540:  Return: url with form name elements and values appended to the 
  541:          the url, doing proper escaping of the values and joining with ? or &
  542:          as needed
  543: 
  544: =item clean_handle()
  545: 
  546: =item propath()
  547: 
  548: =item untie_domain_hash()
  549: 
  550: =item tie_domain_hash()
  551: 
  552: Manipulation of hash based databases (factoring out common code
  553: for later use as we refactor.
  554: 
  555:  Ties a domain level resource file to a hash.
  556:  If requested a history entry is created in the associated hist file.
  557: 
  558:  Parameters:
  559:     domain    - Name of the domain in which the resource file lives.
  560:     namespace - Name of the hash within that domain.
  561:     how       - How to tie the hash (e.g. GDBM_WRCREAT()).
  562:     loghead   - Optional parameter, if present a log entry is created
  563:                 in the associated history file and this is the first part
  564:                  of that entry.
  565:     logtail   - Goes along with loghead,  The actual logentry is of the
  566:                 form $loghead:<timestamp>:logtail.
  567: Returns:
  568:    Reference to a hash bound to the db file or alternatively undef
  569:    if the tie failed.
  570: 
  571: =item tie_user_hash()
  572: 
  573:   Ties a user's resource file to a hash.  
  574:   If necessary, an appropriate history
  575:   log file entry is made as well.
  576:   This sub factors out common code from the subs that manipulate
  577:   the various gdbm files that keep keyword value pairs.
  578: Parameters:
  579:   domain       - Name of the domain the user is in.
  580:   user         - Name of the 'current user'.
  581:   namespace    - Namespace representing the file to tie.
  582:   how          - What the tie is done to (e.g. GDBM_WRCREAT().
  583:   loghead      - Optional first part of log entry if there may be a
  584:                  history file.
  585:   what         - Optional tail of log entry if there may be a history
  586:                  file.
  587: Returns:
  588:   hash to which the database is tied.  It's up to the caller to untie.
  589:   undef if the has could not be tied.
  590: 
  591: =item tie_course
  592: 
  593: Caches the course database into the temp directory in the context of a specific
  594: user and ties it to a hash.
  595: Parameters:
  596:    domain    - Domain the user is in.
  597:    user      - Username of the user.
  598:    course    - Course specification
  599:    cdom      - The course domain.
  600:    hash      - Reference to the hash to tie.
  601: 
  602: Returns:
  603:     1        - Success
  604:     0        - Failure.
  605: 
  606: =item tie_course_params
  607: 
  608: Caches the course parameter database into the temp directory in the context
  609: of a specific user and ties it to a hash.
  610: Parameters:
  611:    domain   - Domain the user is in.
  612:    user     - Username of the user.
  613:    course   - course specification.
  614:    cdom     - The course domain.
  615:    hash     - reference to the hash to tie.
  616: 
  617: Returns:
  618:    1        - Success.
  619:    0        - Failure./
  620: 
  621: 
  622: =item locking_hash_tie()
  623: 
  624: routines if you just have a filename return tied hashref or undef
  625: 
  626: =item locking_hash_untie()
  627: 
  628: =item db_filename_parts()
  629: 
  630: =back
  631: 
  632: =item tempdir()
  633: 
  634: Returns the file system path to the place loncapa temporary files should be placed/found.
  635: 
  636: 
  637: =head1 INTERNAL SUBROUTINES
  638: 
  639: =over 
  640: 
  641: =item _do_hash_tie()
  642: 
  643: =item _do_hash_untie()
  644: 
  645: =back
  646: 
  647: =cut
  648: 

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