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