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