Annotation of loncom/LONCAPA.pm, revision 1.30
1.1 albertel 1: # The LearningOnline Network
2: # Base routines
3: #
1.30 ! raeburn 4: # $Id: LONCAPA.pm,v 1.29 2009/10/29 03:23:52 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.2 www 158: # -------------------------------------------- Return path to profile directory
159:
160: sub propath {
161: my ($udom,$uname)=@_;
1.14 albertel 162: $udom = &clean_domain($udom);
1.16 albertel 163: $uname= &clean_name($uname);
1.2 www 164: my $subdir=$uname.'__';
165: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
166: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
167: return $proname;
1.29 raeburn 168: }
1.2 www 169:
170: sub tie_domain_hash {
171: my ($domain,$namespace,$how,$loghead,$logtail) = @_;
172:
173: # Filter out any whitespace in the domain name:
174:
1.14 albertel 175: $domain = &clean_domain($domain);
1.2 www 176:
177: # We have enough to go on to tie the hash:
178:
179: my $user_top_dir = $perlvar{'lonUsersDir'};
180: my $domain_dir = $user_top_dir."/$domain";
181: my $resource_file = $domain_dir."/$namespace";
182: return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
183: }
184:
185: sub untie_domain_hash {
186: return &_locking_hash_untie(@_);
187: }
1.25 jms 188:
189:
1.2 www 190: sub tie_user_hash {
191: my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
192:
1.15 albertel 193: $namespace=~s{/}{_}g; # / -> _
194: $namespace = &clean_username($namespace);
195: my $proname = &propath($domain, $user);
1.2 www 196: my $file_prefix="$proname/$namespace";
197: return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
198: }
199:
200: sub untie_user_hash {
201: return &_locking_hash_untie(@_);
202: }
203:
1.6 www 204:
205: sub locking_hash_tie {
206: my ($filename,$how)=@_;
207: my ($file_prefix,$namespace)=&db_filename_parts($filename);
1.7 albertel 208: if ($namespace eq '') { return undef; }
1.6 www 209: return &_locking_hash_tie($file_prefix,$namespace,$how);
210: }
211:
212: sub locking_hash_untie {
213: return &_locking_hash_untie(@_);
214: }
215:
216: sub db_filename_parts {
217: my ($filename)=@_;
218: my ($file_path,$namespace)=($filename=~/^(.*)\/([^\/]+)\.db$/);
1.7 albertel 219: if ($namespace eq '') { return undef; }
1.6 www 220: return ($file_path.'/'.$namespace,$namespace);
221: }
222:
1.2 www 223: # internal routines that handle the actual tieing and untieing process
224:
225: sub _do_hash_tie {
226: my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
227: my %hash;
228: if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
229: # If this is a namespace for which a history is kept,
230: # make the history log entry:
231: if (($namespace !~/^nohist\_/) && (defined($loghead))) {
232: my $hfh = IO::File->new(">>$file_prefix.hist");
233: if($hfh) {
1.5 albertel 234: my $now = time();
235: print $hfh ("$loghead:$now:$what\n");
1.2 www 236: }
237: $hfh->close;
238: }
239: return \%hash;
240: } else {
241: return undef;
242: }
243: }
244:
245: sub _do_hash_untie {
246: my ($hashref) = @_;
247: my $result = untie(%$hashref);
248: return $result;
249: }
250:
251: {
252: my $sym;
1.10 albertel 253: my @pushed_syms;
1.11 albertel 254:
255: sub clean_sym {
256: undef($sym);
257: }
1.10 albertel 258: sub push_locking_hash_tie {
259: if (!defined($sym)) {
260: die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock.");
261: }
262: push(@pushed_syms,$sym);
263: undef($sym);
264: }
265:
266: sub pop_locking_hash_tie {
267: if (defined($sym)) {
268: die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred.");
269: }
270: $sym = pop(@pushed_syms);
271: }
1.2 www 272:
273: sub _locking_hash_tie {
274: my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
1.9 albertel 275: if (defined($sym)) {
1.11 albertel 276: die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
1.9 albertel 277: }
278:
1.2 www 279: my $lock_type=LOCK_SH;
280: # Are we reading or writing?
281: if ($how eq &GDBM_READER()) {
282: # We are reading
283: if (!open($sym,"$file_prefix.db.lock")) {
284: # We don't have a lock file. This could mean
285: # - that there is no such db-file
286: # - that it does not have a lock file yet
287: if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
288: # No such file. Forget it.
289: $! = 2;
1.11 albertel 290: &clean_sym();
1.2 www 291: return undef;
292: }
293: # Apparently just no lock file yet. Make one
294: open($sym,">>$file_prefix.db.lock");
295: }
296: # Do a shared lock
1.9 albertel 297: if (!&flock_sym(LOCK_SH)) {
1.11 albertel 298: &clean_sym();
1.9 albertel 299: return undef;
300: }
1.2 www 301: # If this is compressed, we will actually need an exclusive lock
302: if (-e "$file_prefix.db.gz") {
1.9 albertel 303: if (!&flock_sym(LOCK_EX)) {
1.11 albertel 304: &clean_sym();
1.9 albertel 305: return undef;
306: }
1.2 www 307: }
308: } elsif ($how eq &GDBM_WRCREAT()) {
309: # We are writing
310: open($sym,">>$file_prefix.db.lock");
311: # Writing needs exclusive lock
1.9 albertel 312: if (!&flock_sym(LOCK_EX)) {
1.11 albertel 313: &clean_sym();
1.9 albertel 314: return undef;
315: }
1.2 www 316: } else {
1.5 albertel 317: die("Unknown method $how for $file_prefix");
1.2 www 318: }
319: # The file is ours!
320: # If it is archived, un-archive it now
321: if (-e "$file_prefix.db.gz") {
322: system("gunzip $file_prefix.db.gz");
323: if (-e "$file_prefix.hist.gz") {
324: system("gunzip $file_prefix.hist.gz");
325: }
326: }
327: # Change access mode to non-blocking
328: $how=$how|&GDBM_NOLOCK();
329: # Go ahead and tie the hash
1.13 albertel 330: my $result =
331: &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
332: if (!$result) {
333: &clean_sym();
334: }
335: return $result;
1.2 www 336: }
337:
338: sub flock_sym {
339: my ($lock_type)=@_;
340: my $failed=0;
341: eval {
342: local $SIG{__DIE__}='DEFAULT';
343: local $SIG{ALRM}=sub {
344: $failed=1;
345: die("failed lock");
346: };
347: alarm($loncapa_max_wait_time);
348: flock($sym,$lock_type);
349: alarm(0);
350: };
351: if ($failed) {
352: $! = 100; # throwing error # 100
353: return undef;
354: } else {
355: return 1;
356: }
357: }
358:
359: sub _locking_hash_untie {
360: my ($hashref) = @_;
361: my $result = untie(%$hashref);
362: flock($sym,LOCK_UN);
363: close($sym);
1.11 albertel 364: &clean_sym();
1.2 www 365: return $result;
366: }
367: }
368:
369: BEGIN {
1.4 albertel 370: %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
1.2 www 371: }
372:
1.1 albertel 373: 1;
374:
375: __END__
376:
1.28 raeburn 377: =pod
1.1 albertel 378:
1.27 jms 379: =head1 NAME
380:
381: Apache::LONCAPA
382:
383: LONCAPA - Basic routines
384:
385: =head1 SYNOPSIS
386:
387: Generally useful routines
388:
389: =head1 EXPORTED SUBROUTINES
390:
391: =over
392:
393: =item escape()
394:
395: unpack non-word characters into CGI-compatible hex codes
396:
397: =item unescape()
398:
399: pack CGI-compatible hex codes into actual non-word ASCII character
400:
401: =item add_get_param()
1.28 raeburn 402:
403: Append escaped form elements (name=value etc.) to a url.
1.27 jms 404:
405: Inputs: url (with or without exit GET from parameters), hash ref of
406: form name => value pairs
407:
1.28 raeburn 408: Return: url with form name elements and values appended to the
409: the url, doing proper escaping of the values and joining with ? or &
1.27 jms 410: as needed
411:
412: =item clean_handle()
413:
414: =item propath()
415:
416: =item untie_domain_hash()
417:
418: =item tie_domain_hash()
419:
420: Manipulation of hash based databases (factoring out common code
421: for later use as we refactor.
422:
423: Ties a domain level resource file to a hash.
424: If requested a history entry is created in the associated hist file.
425:
426: Parameters:
427: domain - Name of the domain in which the resource file lives.
428: namespace - Name of the hash within that domain.
429: how - How to tie the hash (e.g. GDBM_WRCREAT()).
430: loghead - Optional parameter, if present a log entry is created
431: in the associated history file and this is the first part
432: of that entry.
433: logtail - Goes along with loghead, The actual logentry is of the
434: form $loghead:<timestamp>:logtail.
435: Returns:
436: Reference to a hash bound to the db file or alternatively undef
437: if the tie failed.
438:
439: =item tie_user_hash()
440:
441: Ties a user's resource file to a hash.
442: If necessary, an appropriate history
443: log file entry is made as well.
444: This sub factors out common code from the subs that manipulate
445: the various gdbm files that keep keyword value pairs.
446: Parameters:
447: domain - Name of the domain the user is in.
448: user - Name of the 'current user'.
449: namespace - Namespace representing the file to tie.
450: how - What the tie is done to (e.g. GDBM_WRCREAT().
451: loghead - Optional first part of log entry if there may be a
452: history file.
453: what - Optional tail of log entry if there may be a history
454: file.
455: Returns:
456: hash to which the database is tied. It's up to the caller to untie.
457: undef if the has could not be tied.
458:
459: =item locking_hash_tie()
460:
461: routines if you just have a filename return tied hashref or undef
462:
463: =item locking_hash_untie()
464:
465: =item db_filename_parts()
466:
467: =head1 INTERNAL SUBROUTINES
468:
469: =item _do_hash_tie()
470:
471: =item _do_hash_untie()
472:
473: =back
474:
475: =cut
476:
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