Annotation of loncom/LONCAPA.pm, revision 1.34
1.1 albertel 1: # The LearningOnline Network
2: # Base routines
3: #
1.34 ! raeburn 4: # $Id: LONCAPA.pm,v 1.33 2011/11/07 20:05:52 www 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:
1.34 ! raeburn 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: }
1.32 foxr 151:
152: #----------------------------------------------------------------------
153: #
154: # some of these subs need a bit of documentation
155:
1.1 albertel 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:
1.33 www 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:
1.30 raeburn 196: $match_domain = $LONCAPA::domain_re = qr{[[:alnum:]\-.]+};
197: $match_not_domain = $LONCAPA::not_domain_re = qr{[^[:alnum:]\-.]+};
1.14 albertel 198: sub clean_domain {
199: my ($domain) = @_;
200: $domain =~ s/$match_not_domain//g;
201: return $domain;
202: }
203:
1.24 albertel 204: $match_username = $LONCAPA::username_re = qr{\w[\w\-.@]+};
205: $match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.@]+};
1.14 albertel 206: sub clean_username {
207: my ($username) = @_;
1.21 albertel 208: $username =~ s/^\W+//;
1.14 albertel 209: $username =~ s/$match_not_username//g;
210: return $username;
211: }
212:
1.16 albertel 213:
214: $match_courseid = $LONCAPA::courseid_re = qr{\d[\w\-.]+};
1.29 raeburn 215: $match_community =$LONCAPA::community_re = qr{0[\w\-.]+};
1.16 albertel 216: $match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+};
1.22 albertel 217: sub clean_courseid {
218: my ($courseid) = @_;
219: $courseid =~ s/^\D+//;
220: $courseid =~ s/$match_not_courseid//g;
221: return $courseid;
222: }
1.16 albertel 223:
1.22 albertel 224: $match_name = $LONCAPA::name_re = qr{$match_username|$match_courseid};
1.16 albertel 225: sub clean_name {
226: my ($name) = @_;
227: $name =~ s/$match_not_username//g;
228: return $name;
229: }
230:
1.23 albertel 231: $match_lonid = $LONCAPA::lonid_re = qr{[\w\-.]+};
232:
1.16 albertel 233: sub split_courseid {
234: my ($courseid) = @_;
235: my ($domain,$coursenum) =
236: ($courseid=~m{^/($match_domain)/($match_courseid)});
237: return ($domain,$coursenum);
238: }
239:
1.24 albertel 240: $match_handle = $LONCAPA::handle_re = qr{[\w\-.@]+};
241: $match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.@]+};
1.14 albertel 242: sub clean_handle {
243: my ($handle) = @_;
244: $handle =~ s/$match_not_handle//g;
245: return $handle;
246: }
247:
1.31 raeburn 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:
1.2 www 289: # -------------------------------------------- Return path to profile directory
290:
291: sub propath {
292: my ($udom,$uname)=@_;
1.14 albertel 293: $udom = &clean_domain($udom);
1.16 albertel 294: $uname= &clean_name($uname);
1.2 www 295: my $subdir=$uname.'__';
296: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
297: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
298: return $proname;
1.29 raeburn 299: }
1.2 www 300:
301: sub tie_domain_hash {
302: my ($domain,$namespace,$how,$loghead,$logtail) = @_;
303:
304: # Filter out any whitespace in the domain name:
305:
1.14 albertel 306: $domain = &clean_domain($domain);
1.2 www 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: }
1.25 jms 319:
320:
1.2 www 321: sub tie_user_hash {
322: my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
323:
1.15 albertel 324: $namespace=~s{/}{_}g; # / -> _
325: $namespace = &clean_username($namespace);
326: my $proname = &propath($domain, $user);
1.2 www 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:
1.6 www 335:
336: sub locking_hash_tie {
337: my ($filename,$how)=@_;
338: my ($file_prefix,$namespace)=&db_filename_parts($filename);
1.7 albertel 339: if ($namespace eq '') { return undef; }
1.6 www 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$/);
1.7 albertel 350: if ($namespace eq '') { return undef; }
1.6 www 351: return ($file_path.'/'.$namespace,$namespace);
352: }
353:
1.2 www 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) {
1.5 albertel 365: my $now = time();
366: print $hfh ("$loghead:$now:$what\n");
1.2 www 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;
1.10 albertel 384: my @pushed_syms;
1.11 albertel 385:
386: sub clean_sym {
387: undef($sym);
388: }
1.10 albertel 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: }
1.2 www 403:
404: sub _locking_hash_tie {
405: my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
1.9 albertel 406: if (defined($sym)) {
1.11 albertel 407: die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
1.9 albertel 408: }
409:
1.2 www 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;
1.11 albertel 421: &clean_sym();
1.2 www 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
1.9 albertel 428: if (!&flock_sym(LOCK_SH)) {
1.11 albertel 429: &clean_sym();
1.9 albertel 430: return undef;
431: }
1.2 www 432: # If this is compressed, we will actually need an exclusive lock
433: if (-e "$file_prefix.db.gz") {
1.9 albertel 434: if (!&flock_sym(LOCK_EX)) {
1.11 albertel 435: &clean_sym();
1.9 albertel 436: return undef;
437: }
1.2 www 438: }
439: } elsif ($how eq &GDBM_WRCREAT()) {
440: # We are writing
441: open($sym,">>$file_prefix.db.lock");
442: # Writing needs exclusive lock
1.9 albertel 443: if (!&flock_sym(LOCK_EX)) {
1.11 albertel 444: &clean_sym();
1.9 albertel 445: return undef;
446: }
1.2 www 447: } else {
1.5 albertel 448: die("Unknown method $how for $file_prefix");
1.2 www 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
1.13 albertel 461: my $result =
462: &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
463: if (!$result) {
464: &clean_sym();
465: }
466: return $result;
1.2 www 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);
1.11 albertel 495: &clean_sym();
1.2 www 496: return $result;
497: }
498: }
499:
1.32 foxr 500:
1.2 www 501: BEGIN {
1.4 albertel 502: %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
1.2 www 503: }
504:
1.1 albertel 505: 1;
506:
507: __END__
508:
1.28 raeburn 509: =pod
1.1 albertel 510:
1.27 jms 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()
1.28 raeburn 534:
535: Append escaped form elements (name=value etc.) to a url.
1.27 jms 536:
537: Inputs: url (with or without exit GET from parameters), hash ref of
538: form name => value pairs
539:
1.28 raeburn 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 &
1.27 jms 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:
1.32 foxr 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:
1.27 jms 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:
1.32 foxr 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:
1.27 jms 637: =head1 INTERNAL SUBROUTINES
638:
1.32 foxr 639: =over
640:
1.27 jms 641: =item _do_hash_tie()
642:
643: =item _do_hash_untie()
644:
645: =back
646:
647: =cut
648:
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