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