Annotation of loncom/LONCAPA.pm, revision 1.33
1.1 albertel 1: # The LearningOnline Network
2: # Base routines
3: #
1.33 ! www 4: # $Id: LONCAPA.pm,v 1.32 2011/07/04 09:25:53 foxr 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.33 ! www 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:
1.30 raeburn 186: $match_domain = $LONCAPA::domain_re = qr{[[:alnum:]\-.]+};
187: $match_not_domain = $LONCAPA::not_domain_re = qr{[^[:alnum:]\-.]+};
1.14 albertel 188: sub clean_domain {
189: my ($domain) = @_;
190: $domain =~ s/$match_not_domain//g;
191: return $domain;
192: }
193:
1.24 albertel 194: $match_username = $LONCAPA::username_re = qr{\w[\w\-.@]+};
195: $match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.@]+};
1.14 albertel 196: sub clean_username {
197: my ($username) = @_;
1.21 albertel 198: $username =~ s/^\W+//;
1.14 albertel 199: $username =~ s/$match_not_username//g;
200: return $username;
201: }
202:
1.16 albertel 203:
204: $match_courseid = $LONCAPA::courseid_re = qr{\d[\w\-.]+};
1.29 raeburn 205: $match_community =$LONCAPA::community_re = qr{0[\w\-.]+};
1.16 albertel 206: $match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+};
1.22 albertel 207: sub clean_courseid {
208: my ($courseid) = @_;
209: $courseid =~ s/^\D+//;
210: $courseid =~ s/$match_not_courseid//g;
211: return $courseid;
212: }
1.16 albertel 213:
1.22 albertel 214: $match_name = $LONCAPA::name_re = qr{$match_username|$match_courseid};
1.16 albertel 215: sub clean_name {
216: my ($name) = @_;
217: $name =~ s/$match_not_username//g;
218: return $name;
219: }
220:
1.23 albertel 221: $match_lonid = $LONCAPA::lonid_re = qr{[\w\-.]+};
222:
1.16 albertel 223: sub split_courseid {
224: my ($courseid) = @_;
225: my ($domain,$coursenum) =
226: ($courseid=~m{^/($match_domain)/($match_courseid)});
227: return ($domain,$coursenum);
228: }
229:
1.24 albertel 230: $match_handle = $LONCAPA::handle_re = qr{[\w\-.@]+};
231: $match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.@]+};
1.14 albertel 232: sub clean_handle {
233: my ($handle) = @_;
234: $handle =~ s/$match_not_handle//g;
235: return $handle;
236: }
237:
1.31 raeburn 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:
1.2 www 279: # -------------------------------------------- Return path to profile directory
280:
281: sub propath {
282: my ($udom,$uname)=@_;
1.14 albertel 283: $udom = &clean_domain($udom);
1.16 albertel 284: $uname= &clean_name($uname);
1.2 www 285: my $subdir=$uname.'__';
286: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
287: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
288: return $proname;
1.29 raeburn 289: }
1.2 www 290:
291: sub tie_domain_hash {
292: my ($domain,$namespace,$how,$loghead,$logtail) = @_;
293:
294: # Filter out any whitespace in the domain name:
295:
1.14 albertel 296: $domain = &clean_domain($domain);
1.2 www 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: }
1.25 jms 309:
310:
1.2 www 311: sub tie_user_hash {
312: my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
313:
1.15 albertel 314: $namespace=~s{/}{_}g; # / -> _
315: $namespace = &clean_username($namespace);
316: my $proname = &propath($domain, $user);
1.2 www 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:
1.6 www 325:
326: sub locking_hash_tie {
327: my ($filename,$how)=@_;
328: my ($file_prefix,$namespace)=&db_filename_parts($filename);
1.7 albertel 329: if ($namespace eq '') { return undef; }
1.6 www 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$/);
1.7 albertel 340: if ($namespace eq '') { return undef; }
1.6 www 341: return ($file_path.'/'.$namespace,$namespace);
342: }
343:
1.2 www 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) {
1.5 albertel 355: my $now = time();
356: print $hfh ("$loghead:$now:$what\n");
1.2 www 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;
1.10 albertel 374: my @pushed_syms;
1.11 albertel 375:
376: sub clean_sym {
377: undef($sym);
378: }
1.10 albertel 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: }
1.2 www 393:
394: sub _locking_hash_tie {
395: my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
1.9 albertel 396: if (defined($sym)) {
1.11 albertel 397: die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
1.9 albertel 398: }
399:
1.2 www 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;
1.11 albertel 411: &clean_sym();
1.2 www 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
1.9 albertel 418: if (!&flock_sym(LOCK_SH)) {
1.11 albertel 419: &clean_sym();
1.9 albertel 420: return undef;
421: }
1.2 www 422: # If this is compressed, we will actually need an exclusive lock
423: if (-e "$file_prefix.db.gz") {
1.9 albertel 424: if (!&flock_sym(LOCK_EX)) {
1.11 albertel 425: &clean_sym();
1.9 albertel 426: return undef;
427: }
1.2 www 428: }
429: } elsif ($how eq &GDBM_WRCREAT()) {
430: # We are writing
431: open($sym,">>$file_prefix.db.lock");
432: # Writing needs exclusive lock
1.9 albertel 433: if (!&flock_sym(LOCK_EX)) {
1.11 albertel 434: &clean_sym();
1.9 albertel 435: return undef;
436: }
1.2 www 437: } else {
1.5 albertel 438: die("Unknown method $how for $file_prefix");
1.2 www 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
1.13 albertel 451: my $result =
452: &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
453: if (!$result) {
454: &clean_sym();
455: }
456: return $result;
1.2 www 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);
1.11 albertel 485: &clean_sym();
1.2 www 486: return $result;
487: }
488: }
489:
1.32 foxr 490:
1.2 www 491: BEGIN {
1.4 albertel 492: %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
1.2 www 493: }
494:
1.1 albertel 495: 1;
496:
497: __END__
498:
1.28 raeburn 499: =pod
1.1 albertel 500:
1.27 jms 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()
1.28 raeburn 524:
525: Append escaped form elements (name=value etc.) to a url.
1.27 jms 526:
527: Inputs: url (with or without exit GET from parameters), hash ref of
528: form name => value pairs
529:
1.28 raeburn 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 &
1.27 jms 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:
1.32 foxr 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:
1.27 jms 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:
1.32 foxr 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:
1.27 jms 627: =head1 INTERNAL SUBROUTINES
628:
1.32 foxr 629: =over
630:
1.27 jms 631: =item _do_hash_tie()
632:
633: =item _do_hash_untie()
634:
635: =back
636:
637: =cut
638:
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