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