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