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