1: # The LearningOnline Network
2: # Base routines
3: #
4: # $Id: LONCAPA.pm,v 1.32 2011/07/04 09:25:53 foxr Exp $
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:
30:
31:
32: package LONCAPA;
33:
34: use strict;
35: use lib '/home/httpd/lib/perl/';
36: use LONCAPA::Configuration;
37: use Fcntl qw(:flock);
38: use GDBM_File;
39: use POSIX;
40: #use Apache::lonnet;
41:
42: my $loncapa_max_wait_time = 13;
43:
44:
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:
61: use vars qw($match_domain $match_not_domain
62: $match_username $match_not_username
63: $match_courseid $match_not_courseid
64: $match_community
65: $match_name
66: $match_lonid
67: $match_handle $match_not_handle);
68:
69: require Exporter;
70: our @ISA = qw (Exporter);
71: our @EXPORT = qw(&add_get_param &escape &unescape
72: &tie_domain_hash &untie_domain_hash &tie_user_hash
73: &untie_user_hash &propath &tie_course);
74: our @EXPORT_OK = qw($match_domain $match_not_domain
75: $match_username $match_not_username
76: $match_courseid $match_not_courseid
77: $match_community
78: $match_name
79: $match_lonid
80: $match_handle $match_not_handle &tie_course);
81: our %EXPORT_TAGS = ( 'match' =>[qw($match_domain $match_not_domain
82: $match_username $match_not_username
83: $match_courseid $match_not_courseid
84: $match_community
85: $match_name
86: $match_lonid
87: $match_handle $match_not_handle)],);
88: my %perlvar;
89:
90:
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:
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:
178: $match_domain = $LONCAPA::domain_re = qr{[[:alnum:]\-.]+};
179: $match_not_domain = $LONCAPA::not_domain_re = qr{[^[:alnum:]\-.]+};
180: sub clean_domain {
181: my ($domain) = @_;
182: $domain =~ s/$match_not_domain//g;
183: return $domain;
184: }
185:
186: $match_username = $LONCAPA::username_re = qr{\w[\w\-.@]+};
187: $match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.@]+};
188: sub clean_username {
189: my ($username) = @_;
190: $username =~ s/^\W+//;
191: $username =~ s/$match_not_username//g;
192: return $username;
193: }
194:
195:
196: $match_courseid = $LONCAPA::courseid_re = qr{\d[\w\-.]+};
197: $match_community =$LONCAPA::community_re = qr{0[\w\-.]+};
198: $match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+};
199: sub clean_courseid {
200: my ($courseid) = @_;
201: $courseid =~ s/^\D+//;
202: $courseid =~ s/$match_not_courseid//g;
203: return $courseid;
204: }
205:
206: $match_name = $LONCAPA::name_re = qr{$match_username|$match_courseid};
207: sub clean_name {
208: my ($name) = @_;
209: $name =~ s/$match_not_username//g;
210: return $name;
211: }
212:
213: $match_lonid = $LONCAPA::lonid_re = qr{[\w\-.]+};
214:
215: sub split_courseid {
216: my ($courseid) = @_;
217: my ($domain,$coursenum) =
218: ($courseid=~m{^/($match_domain)/($match_courseid)});
219: return ($domain,$coursenum);
220: }
221:
222: $match_handle = $LONCAPA::handle_re = qr{[\w\-.@]+};
223: $match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.@]+};
224: sub clean_handle {
225: my ($handle) = @_;
226: $handle =~ s/$match_not_handle//g;
227: return $handle;
228: }
229:
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:
271: # -------------------------------------------- Return path to profile directory
272:
273: sub propath {
274: my ($udom,$uname)=@_;
275: $udom = &clean_domain($udom);
276: $uname= &clean_name($uname);
277: my $subdir=$uname.'__';
278: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
279: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
280: return $proname;
281: }
282:
283: sub tie_domain_hash {
284: my ($domain,$namespace,$how,$loghead,$logtail) = @_;
285:
286: # Filter out any whitespace in the domain name:
287:
288: $domain = &clean_domain($domain);
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: }
301:
302:
303: sub tie_user_hash {
304: my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
305:
306: $namespace=~s{/}{_}g; # / -> _
307: $namespace = &clean_username($namespace);
308: my $proname = &propath($domain, $user);
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:
317:
318: sub locking_hash_tie {
319: my ($filename,$how)=@_;
320: my ($file_prefix,$namespace)=&db_filename_parts($filename);
321: if ($namespace eq '') { return undef; }
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$/);
332: if ($namespace eq '') { return undef; }
333: return ($file_path.'/'.$namespace,$namespace);
334: }
335:
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) {
347: my $now = time();
348: print $hfh ("$loghead:$now:$what\n");
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;
366: my @pushed_syms;
367:
368: sub clean_sym {
369: undef($sym);
370: }
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: }
385:
386: sub _locking_hash_tie {
387: my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
388: if (defined($sym)) {
389: die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
390: }
391:
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;
403: &clean_sym();
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
410: if (!&flock_sym(LOCK_SH)) {
411: &clean_sym();
412: return undef;
413: }
414: # If this is compressed, we will actually need an exclusive lock
415: if (-e "$file_prefix.db.gz") {
416: if (!&flock_sym(LOCK_EX)) {
417: &clean_sym();
418: return undef;
419: }
420: }
421: } elsif ($how eq &GDBM_WRCREAT()) {
422: # We are writing
423: open($sym,">>$file_prefix.db.lock");
424: # Writing needs exclusive lock
425: if (!&flock_sym(LOCK_EX)) {
426: &clean_sym();
427: return undef;
428: }
429: } else {
430: die("Unknown method $how for $file_prefix");
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
443: my $result =
444: &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
445: if (!$result) {
446: &clean_sym();
447: }
448: return $result;
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);
477: &clean_sym();
478: return $result;
479: }
480: }
481:
482:
483: BEGIN {
484: %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
485: }
486:
487: 1;
488:
489: __END__
490:
491: =pod
492:
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()
516:
517: Append escaped form elements (name=value etc.) to a url.
518:
519: Inputs: url (with or without exit GET from parameters), hash ref of
520: form name => value pairs
521:
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 &
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:
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:
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:
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:
619: =head1 INTERNAL SUBROUTINES
620:
621: =over
622:
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