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