Annotation of loncom/LONCAPA.pm, revision 1.31
1.1 albertel 1: # The LearningOnline Network
2: # Base routines
3: #
1.31 ! raeburn 4: # $Id: LONCAPA.pm,v 1.30 2010/06/15 05:31:43 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;
40:
41: my $loncapa_max_wait_time = 13;
42:
1.14 albertel 43:
44: use vars qw($match_domain $match_not_domain
45: $match_username $match_not_username
1.16 albertel 46: $match_courseid $match_not_courseid
1.29 raeburn 47: $match_community
1.16 albertel 48: $match_name
1.23 albertel 49: $match_lonid
1.14 albertel 50: $match_handle $match_not_handle);
51:
1.1 albertel 52: require Exporter;
53: our @ISA = qw (Exporter);
1.14 albertel 54: our @EXPORT = qw(&add_get_param &escape &unescape
55: &tie_domain_hash &untie_domain_hash &tie_user_hash
56: &untie_user_hash &propath);
57: our @EXPORT_OK = qw($match_domain $match_not_domain
58: $match_username $match_not_username
1.16 albertel 59: $match_courseid $match_not_courseid
1.29 raeburn 60: $match_community
1.16 albertel 61: $match_name
1.23 albertel 62: $match_lonid
1.14 albertel 63: $match_handle $match_not_handle);
64: our %EXPORT_TAGS = ( 'match' =>[qw($match_domain $match_not_domain
65: $match_username $match_not_username
1.16 albertel 66: $match_courseid $match_not_courseid
1.29 raeburn 67: $match_community
1.16 albertel 68: $match_name
1.23 albertel 69: $match_lonid
1.14 albertel 70: $match_handle $match_not_handle)],);
1.2 www 71: my %perlvar;
1.1 albertel 72:
1.8 foxr 73:
1.1 albertel 74: sub add_get_param {
75: my ($url,$form_data) = @_;
76: my $needs_question_mark = ($url !~ /\?/);
77:
78: while (my ($name,$value) = each(%$form_data)) {
79: if ($needs_question_mark) {
80: $url.='?';
81: $needs_question_mark = 0;
82: } else {
83: $url.='&';
84: }
85: $url.=$name.'='.&escape($form_data->{$name});
86: }
87: return $url;
88: }
89:
90: # -------------------------------------------------------- Escape Special Chars
91:
92: sub escape {
93: my $str=shift;
94: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
95: return $str;
96: }
97:
98: # ----------------------------------------------------- Un-Escape Special Chars
99:
100: sub unescape {
101: my $str=shift;
102: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
103: return $str;
104: }
105:
1.30 raeburn 106: $match_domain = $LONCAPA::domain_re = qr{[[:alnum:]\-.]+};
107: $match_not_domain = $LONCAPA::not_domain_re = qr{[^[:alnum:]\-.]+};
1.14 albertel 108: sub clean_domain {
109: my ($domain) = @_;
110: $domain =~ s/$match_not_domain//g;
111: return $domain;
112: }
113:
1.24 albertel 114: $match_username = $LONCAPA::username_re = qr{\w[\w\-.@]+};
115: $match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.@]+};
1.14 albertel 116: sub clean_username {
117: my ($username) = @_;
1.21 albertel 118: $username =~ s/^\W+//;
1.14 albertel 119: $username =~ s/$match_not_username//g;
120: return $username;
121: }
122:
1.16 albertel 123:
124: $match_courseid = $LONCAPA::courseid_re = qr{\d[\w\-.]+};
1.29 raeburn 125: $match_community =$LONCAPA::community_re = qr{0[\w\-.]+};
1.16 albertel 126: $match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+};
1.22 albertel 127: sub clean_courseid {
128: my ($courseid) = @_;
129: $courseid =~ s/^\D+//;
130: $courseid =~ s/$match_not_courseid//g;
131: return $courseid;
132: }
1.16 albertel 133:
1.22 albertel 134: $match_name = $LONCAPA::name_re = qr{$match_username|$match_courseid};
1.16 albertel 135: sub clean_name {
136: my ($name) = @_;
137: $name =~ s/$match_not_username//g;
138: return $name;
139: }
140:
1.23 albertel 141: $match_lonid = $LONCAPA::lonid_re = qr{[\w\-.]+};
142:
1.16 albertel 143: sub split_courseid {
144: my ($courseid) = @_;
145: my ($domain,$coursenum) =
146: ($courseid=~m{^/($match_domain)/($match_courseid)});
147: return ($domain,$coursenum);
148: }
149:
1.24 albertel 150: $match_handle = $LONCAPA::handle_re = qr{[\w\-.@]+};
151: $match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.@]+};
1.14 albertel 152: sub clean_handle {
153: my ($handle) = @_;
154: $handle =~ s/$match_not_handle//g;
155: return $handle;
156: }
157:
1.31 ! raeburn 158: #
! 159: # -- Ensure another process for same filesystem action is not running.
! 160: # lond uses for: apachereload; loncron uses for: lciptables
! 161: #
! 162:
! 163: sub try_to_lock {
! 164: my ($lockfile)=@_;
! 165: my $currentpid;
! 166: my $lastpid;
! 167: # Do not manipulate lock file as root
! 168: if ($>==0) {
! 169: return 0;
! 170: }
! 171: # Try to generate lock file.
! 172: # Wait 3 seconds. If same process id is in
! 173: # lock file, then assume lock file is stale, and
! 174: # go ahead. If process id's fluctuate, try
! 175: # for a maximum of 10 times.
! 176: for (0..10) {
! 177: if (-e $lockfile) {
! 178: open(LOCK,"<$lockfile");
! 179: $currentpid=<LOCK>;
! 180: close LOCK;
! 181: if ($currentpid==$lastpid) {
! 182: last;
! 183: }
! 184: sleep 3;
! 185: $lastpid=$currentpid;
! 186: } else {
! 187: last;
! 188: }
! 189: if ($_==10) {
! 190: return 0;
! 191: }
! 192: }
! 193: open(LOCK,">$lockfile");
! 194: print LOCK $$;
! 195: close LOCK;
! 196: return 1;
! 197: }
! 198:
1.2 www 199: # -------------------------------------------- Return path to profile directory
200:
201: sub propath {
202: my ($udom,$uname)=@_;
1.14 albertel 203: $udom = &clean_domain($udom);
1.16 albertel 204: $uname= &clean_name($uname);
1.2 www 205: my $subdir=$uname.'__';
206: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
207: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
208: return $proname;
1.29 raeburn 209: }
1.2 www 210:
211: sub tie_domain_hash {
212: my ($domain,$namespace,$how,$loghead,$logtail) = @_;
213:
214: # Filter out any whitespace in the domain name:
215:
1.14 albertel 216: $domain = &clean_domain($domain);
1.2 www 217:
218: # We have enough to go on to tie the hash:
219:
220: my $user_top_dir = $perlvar{'lonUsersDir'};
221: my $domain_dir = $user_top_dir."/$domain";
222: my $resource_file = $domain_dir."/$namespace";
223: return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
224: }
225:
226: sub untie_domain_hash {
227: return &_locking_hash_untie(@_);
228: }
1.25 jms 229:
230:
1.2 www 231: sub tie_user_hash {
232: my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
233:
1.15 albertel 234: $namespace=~s{/}{_}g; # / -> _
235: $namespace = &clean_username($namespace);
236: my $proname = &propath($domain, $user);
1.2 www 237: my $file_prefix="$proname/$namespace";
238: return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
239: }
240:
241: sub untie_user_hash {
242: return &_locking_hash_untie(@_);
243: }
244:
1.6 www 245:
246: sub locking_hash_tie {
247: my ($filename,$how)=@_;
248: my ($file_prefix,$namespace)=&db_filename_parts($filename);
1.7 albertel 249: if ($namespace eq '') { return undef; }
1.6 www 250: return &_locking_hash_tie($file_prefix,$namespace,$how);
251: }
252:
253: sub locking_hash_untie {
254: return &_locking_hash_untie(@_);
255: }
256:
257: sub db_filename_parts {
258: my ($filename)=@_;
259: my ($file_path,$namespace)=($filename=~/^(.*)\/([^\/]+)\.db$/);
1.7 albertel 260: if ($namespace eq '') { return undef; }
1.6 www 261: return ($file_path.'/'.$namespace,$namespace);
262: }
263:
1.2 www 264: # internal routines that handle the actual tieing and untieing process
265:
266: sub _do_hash_tie {
267: my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
268: my %hash;
269: if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
270: # If this is a namespace for which a history is kept,
271: # make the history log entry:
272: if (($namespace !~/^nohist\_/) && (defined($loghead))) {
273: my $hfh = IO::File->new(">>$file_prefix.hist");
274: if($hfh) {
1.5 albertel 275: my $now = time();
276: print $hfh ("$loghead:$now:$what\n");
1.2 www 277: }
278: $hfh->close;
279: }
280: return \%hash;
281: } else {
282: return undef;
283: }
284: }
285:
286: sub _do_hash_untie {
287: my ($hashref) = @_;
288: my $result = untie(%$hashref);
289: return $result;
290: }
291:
292: {
293: my $sym;
1.10 albertel 294: my @pushed_syms;
1.11 albertel 295:
296: sub clean_sym {
297: undef($sym);
298: }
1.10 albertel 299: sub push_locking_hash_tie {
300: if (!defined($sym)) {
301: die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock.");
302: }
303: push(@pushed_syms,$sym);
304: undef($sym);
305: }
306:
307: sub pop_locking_hash_tie {
308: if (defined($sym)) {
309: die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred.");
310: }
311: $sym = pop(@pushed_syms);
312: }
1.2 www 313:
314: sub _locking_hash_tie {
315: my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
1.9 albertel 316: if (defined($sym)) {
1.11 albertel 317: die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
1.9 albertel 318: }
319:
1.2 www 320: my $lock_type=LOCK_SH;
321: # Are we reading or writing?
322: if ($how eq &GDBM_READER()) {
323: # We are reading
324: if (!open($sym,"$file_prefix.db.lock")) {
325: # We don't have a lock file. This could mean
326: # - that there is no such db-file
327: # - that it does not have a lock file yet
328: if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
329: # No such file. Forget it.
330: $! = 2;
1.11 albertel 331: &clean_sym();
1.2 www 332: return undef;
333: }
334: # Apparently just no lock file yet. Make one
335: open($sym,">>$file_prefix.db.lock");
336: }
337: # Do a shared lock
1.9 albertel 338: if (!&flock_sym(LOCK_SH)) {
1.11 albertel 339: &clean_sym();
1.9 albertel 340: return undef;
341: }
1.2 www 342: # If this is compressed, we will actually need an exclusive lock
343: if (-e "$file_prefix.db.gz") {
1.9 albertel 344: if (!&flock_sym(LOCK_EX)) {
1.11 albertel 345: &clean_sym();
1.9 albertel 346: return undef;
347: }
1.2 www 348: }
349: } elsif ($how eq &GDBM_WRCREAT()) {
350: # We are writing
351: open($sym,">>$file_prefix.db.lock");
352: # Writing needs exclusive lock
1.9 albertel 353: if (!&flock_sym(LOCK_EX)) {
1.11 albertel 354: &clean_sym();
1.9 albertel 355: return undef;
356: }
1.2 www 357: } else {
1.5 albertel 358: die("Unknown method $how for $file_prefix");
1.2 www 359: }
360: # The file is ours!
361: # If it is archived, un-archive it now
362: if (-e "$file_prefix.db.gz") {
363: system("gunzip $file_prefix.db.gz");
364: if (-e "$file_prefix.hist.gz") {
365: system("gunzip $file_prefix.hist.gz");
366: }
367: }
368: # Change access mode to non-blocking
369: $how=$how|&GDBM_NOLOCK();
370: # Go ahead and tie the hash
1.13 albertel 371: my $result =
372: &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
373: if (!$result) {
374: &clean_sym();
375: }
376: return $result;
1.2 www 377: }
378:
379: sub flock_sym {
380: my ($lock_type)=@_;
381: my $failed=0;
382: eval {
383: local $SIG{__DIE__}='DEFAULT';
384: local $SIG{ALRM}=sub {
385: $failed=1;
386: die("failed lock");
387: };
388: alarm($loncapa_max_wait_time);
389: flock($sym,$lock_type);
390: alarm(0);
391: };
392: if ($failed) {
393: $! = 100; # throwing error # 100
394: return undef;
395: } else {
396: return 1;
397: }
398: }
399:
400: sub _locking_hash_untie {
401: my ($hashref) = @_;
402: my $result = untie(%$hashref);
403: flock($sym,LOCK_UN);
404: close($sym);
1.11 albertel 405: &clean_sym();
1.2 www 406: return $result;
407: }
408: }
409:
410: BEGIN {
1.4 albertel 411: %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
1.2 www 412: }
413:
1.1 albertel 414: 1;
415:
416: __END__
417:
1.28 raeburn 418: =pod
1.1 albertel 419:
1.27 jms 420: =head1 NAME
421:
422: Apache::LONCAPA
423:
424: LONCAPA - Basic routines
425:
426: =head1 SYNOPSIS
427:
428: Generally useful routines
429:
430: =head1 EXPORTED SUBROUTINES
431:
432: =over
433:
434: =item escape()
435:
436: unpack non-word characters into CGI-compatible hex codes
437:
438: =item unescape()
439:
440: pack CGI-compatible hex codes into actual non-word ASCII character
441:
442: =item add_get_param()
1.28 raeburn 443:
444: Append escaped form elements (name=value etc.) to a url.
1.27 jms 445:
446: Inputs: url (with or without exit GET from parameters), hash ref of
447: form name => value pairs
448:
1.28 raeburn 449: Return: url with form name elements and values appended to the
450: the url, doing proper escaping of the values and joining with ? or &
1.27 jms 451: as needed
452:
453: =item clean_handle()
454:
455: =item propath()
456:
457: =item untie_domain_hash()
458:
459: =item tie_domain_hash()
460:
461: Manipulation of hash based databases (factoring out common code
462: for later use as we refactor.
463:
464: Ties a domain level resource file to a hash.
465: If requested a history entry is created in the associated hist file.
466:
467: Parameters:
468: domain - Name of the domain in which the resource file lives.
469: namespace - Name of the hash within that domain.
470: how - How to tie the hash (e.g. GDBM_WRCREAT()).
471: loghead - Optional parameter, if present a log entry is created
472: in the associated history file and this is the first part
473: of that entry.
474: logtail - Goes along with loghead, The actual logentry is of the
475: form $loghead:<timestamp>:logtail.
476: Returns:
477: Reference to a hash bound to the db file or alternatively undef
478: if the tie failed.
479:
480: =item tie_user_hash()
481:
482: Ties a user's resource file to a hash.
483: If necessary, an appropriate history
484: log file entry is made as well.
485: This sub factors out common code from the subs that manipulate
486: the various gdbm files that keep keyword value pairs.
487: Parameters:
488: domain - Name of the domain the user is in.
489: user - Name of the 'current user'.
490: namespace - Namespace representing the file to tie.
491: how - What the tie is done to (e.g. GDBM_WRCREAT().
492: loghead - Optional first part of log entry if there may be a
493: history file.
494: what - Optional tail of log entry if there may be a history
495: file.
496: Returns:
497: hash to which the database is tied. It's up to the caller to untie.
498: undef if the has could not be tied.
499:
500: =item locking_hash_tie()
501:
502: routines if you just have a filename return tied hashref or undef
503:
504: =item locking_hash_untie()
505:
506: =item db_filename_parts()
507:
508: =head1 INTERNAL SUBROUTINES
509:
510: =item _do_hash_tie()
511:
512: =item _do_hash_untie()
513:
514: =back
515:
516: =cut
517:
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