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