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