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