Annotation of loncom/LONCAPA.pm, revision 1.15
1.1 albertel 1: # The LearningOnline Network
2: # Base routines
3: #
1.15 ! albertel 4: # $Id: LONCAPA.pm,v 1.14 2006/11/22 19:58: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:
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:
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: # routines if you just have a filename
216: # return tied hashref or undef
217:
218: sub locking_hash_tie {
219: my ($filename,$how)=@_;
220: my ($file_prefix,$namespace)=&db_filename_parts($filename);
1.7 albertel 221: if ($namespace eq '') { return undef; }
1.6 www 222: return &_locking_hash_tie($file_prefix,$namespace,$how);
223: }
224:
225: sub locking_hash_untie {
226: return &_locking_hash_untie(@_);
227: }
228:
229: sub db_filename_parts {
230: my ($filename)=@_;
231: my ($file_path,$namespace)=($filename=~/^(.*)\/([^\/]+)\.db$/);
1.7 albertel 232: if ($namespace eq '') { return undef; }
1.6 www 233: return ($file_path.'/'.$namespace,$namespace);
234: }
235:
1.2 www 236: # internal routines that handle the actual tieing and untieing process
237:
238: sub _do_hash_tie {
239: my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
240: my %hash;
241: if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
242: # If this is a namespace for which a history is kept,
243: # make the history log entry:
244: if (($namespace !~/^nohist\_/) && (defined($loghead))) {
245: my $hfh = IO::File->new(">>$file_prefix.hist");
246: if($hfh) {
1.5 albertel 247: my $now = time();
248: print $hfh ("$loghead:$now:$what\n");
1.2 www 249: }
250: $hfh->close;
251: }
252: return \%hash;
253: } else {
254: return undef;
255: }
256: }
257:
258: sub _do_hash_untie {
259: my ($hashref) = @_;
260: my $result = untie(%$hashref);
261: return $result;
262: }
263:
264: {
265: my $sym;
1.10 albertel 266: my @pushed_syms;
1.11 albertel 267:
268: sub clean_sym {
269: undef($sym);
270: }
1.10 albertel 271: sub push_locking_hash_tie {
272: if (!defined($sym)) {
273: die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock.");
274: }
275: push(@pushed_syms,$sym);
276: undef($sym);
277: }
278:
279: sub pop_locking_hash_tie {
280: if (defined($sym)) {
281: die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred.");
282: }
283: $sym = pop(@pushed_syms);
284: }
1.2 www 285:
286: sub _locking_hash_tie {
287: my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
1.9 albertel 288: if (defined($sym)) {
1.11 albertel 289: die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
1.9 albertel 290: }
291:
1.2 www 292: my $lock_type=LOCK_SH;
293: # Are we reading or writing?
294: if ($how eq &GDBM_READER()) {
295: # We are reading
296: if (!open($sym,"$file_prefix.db.lock")) {
297: # We don't have a lock file. This could mean
298: # - that there is no such db-file
299: # - that it does not have a lock file yet
300: if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
301: # No such file. Forget it.
302: $! = 2;
1.11 albertel 303: &clean_sym();
1.2 www 304: return undef;
305: }
306: # Apparently just no lock file yet. Make one
307: open($sym,">>$file_prefix.db.lock");
308: }
309: # Do a shared lock
1.9 albertel 310: if (!&flock_sym(LOCK_SH)) {
1.11 albertel 311: &clean_sym();
1.9 albertel 312: return undef;
313: }
1.2 www 314: # If this is compressed, we will actually need an exclusive lock
315: if (-e "$file_prefix.db.gz") {
1.9 albertel 316: if (!&flock_sym(LOCK_EX)) {
1.11 albertel 317: &clean_sym();
1.9 albertel 318: return undef;
319: }
1.2 www 320: }
321: } elsif ($how eq &GDBM_WRCREAT()) {
322: # We are writing
323: open($sym,">>$file_prefix.db.lock");
324: # Writing needs exclusive lock
1.9 albertel 325: if (!&flock_sym(LOCK_EX)) {
1.11 albertel 326: &clean_sym();
1.9 albertel 327: return undef;
328: }
1.2 www 329: } else {
1.5 albertel 330: die("Unknown method $how for $file_prefix");
1.2 www 331: }
332: # The file is ours!
333: # If it is archived, un-archive it now
334: if (-e "$file_prefix.db.gz") {
335: system("gunzip $file_prefix.db.gz");
336: if (-e "$file_prefix.hist.gz") {
337: system("gunzip $file_prefix.hist.gz");
338: }
339: }
340: # Change access mode to non-blocking
341: $how=$how|&GDBM_NOLOCK();
342: # Go ahead and tie the hash
1.13 albertel 343: my $result =
344: &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
345: if (!$result) {
346: &clean_sym();
347: }
348: return $result;
1.2 www 349: }
350:
351: sub flock_sym {
352: my ($lock_type)=@_;
353: my $failed=0;
354: eval {
355: local $SIG{__DIE__}='DEFAULT';
356: local $SIG{ALRM}=sub {
357: $failed=1;
358: die("failed lock");
359: };
360: alarm($loncapa_max_wait_time);
361: flock($sym,$lock_type);
362: alarm(0);
363: };
364: if ($failed) {
365: $! = 100; # throwing error # 100
366: return undef;
367: } else {
368: return 1;
369: }
370: }
371:
372: sub _locking_hash_untie {
373: my ($hashref) = @_;
374: my $result = untie(%$hashref);
375: flock($sym,LOCK_UN);
376: close($sym);
1.11 albertel 377: &clean_sym();
1.2 www 378: return $result;
379: }
380: }
381:
382: BEGIN {
1.4 albertel 383: %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
1.2 www 384: }
385:
1.1 albertel 386: 1;
387:
388: __END__
389:
390: =pod
391:
392: =head1 NAME
393:
394: LONCAPA - Basic routines
395:
396: =head1 SYNOPSIS
397:
398: Generally useful routines
399:
400: =head1 EXPORTED SUBROUTINES
401:
402: =over 4
403:
404: =item *
405:
406: escape() : unpack non-word characters into CGI-compatible hex codes
407:
408: =item *
409:
410: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
411:
412: =item *
413:
414: add_get_param() :
415: Inputs: url (with or without exit GET from parameters), hash ref of
416: form name => value pairs
417:
418: Return: url with properly added the form name elements and values to the
419: the url doing proper escaping of the values and joining with ? or &
420: as needed
421:
422: =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