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