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