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