File:  [LON-CAPA] / loncom / LONCAPA.pm
Revision 1.33: download - view: text, annotated - select for diffs
Mon Nov 7 20:05:52 2011 UTC (11 years, 1 month ago) by www
Branches: MAIN
CVS tags: language_hyphenation_merge, language_hyphenation, HEAD, BZ4492-merge, BZ4492-feature_horizontal_radioresponse, BZ4492-feature_Support_horizontal_radioresponse, BZ4492-Support_horizontal_radioresponse
Trying to get rid of some of the copy/paste regular expressions.

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

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