Annotation of loncom/LONCAPA.pm, revision 1.10

1.1       albertel    1: # The LearningOnline Network
                      2: # Base routines
                      3: #
1.10    ! albertel    4: # $Id: LONCAPA.pm,v 1.9 2006/06/27 14:49: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.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;
        !           232:     sub push_locking_hash_tie {
        !           233: 	if (!defined($sym)) {
        !           234: 	    die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock.");
        !           235: 	}
        !           236: 	push(@pushed_syms,$sym);
        !           237: 	undef($sym);
        !           238:     }
        !           239: 
        !           240:     sub pop_locking_hash_tie {
        !           241: 	if (defined($sym)) {
        !           242: 	    die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred.");
        !           243: 	}
        !           244: 	$sym = pop(@pushed_syms);
        !           245:     }
1.2       www       246: 
                    247:     sub _locking_hash_tie {
                    248: 	my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
1.9       albertel  249: 	if (defined($sym)) {
1.10    ! albertel  250: 	    die('Nested locking attempted withut proper use of push_locking_hahs_tie, this is unsupportted');
1.9       albertel  251: 	}
                    252: 
1.2       www       253:         my $lock_type=LOCK_SH;
                    254: # Are we reading or writing?
                    255:         if ($how eq &GDBM_READER()) {
                    256: # We are reading
                    257:            if (!open($sym,"$file_prefix.db.lock")) {
                    258: # We don't have a lock file. This could mean
                    259: # - that there is no such db-file
                    260: # - that it does not have a lock file yet
                    261:                if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
                    262: # No such file. Forget it.                
                    263:                    $! = 2;
                    264:                    return undef;
                    265:                }
                    266: # Apparently just no lock file yet. Make one
                    267:                open($sym,">>$file_prefix.db.lock");
                    268:            }
                    269: # Do a shared lock
1.9       albertel  270:            if (!&flock_sym(LOCK_SH)) { 
                    271: 	       return undef; 
                    272: 	   } 
1.2       www       273: # If this is compressed, we will actually need an exclusive lock
                    274: 	   if (-e "$file_prefix.db.gz") {
1.9       albertel  275: 	       if (!&flock_sym(LOCK_EX)) {
                    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)) {
                    284: 	       return undef;
                    285: 	   }
1.2       www       286:         } else {
1.5       albertel  287:            die("Unknown method $how for $file_prefix");
1.2       www       288:         }
                    289: # The file is ours!
                    290: # If it is archived, un-archive it now
                    291:        if (-e "$file_prefix.db.gz") {
                    292:            system("gunzip $file_prefix.db.gz");
                    293: 	   if (-e "$file_prefix.hist.gz") {
                    294: 	       system("gunzip $file_prefix.hist.gz");
                    295: 	   }
                    296:        }
                    297: # Change access mode to non-blocking
                    298:        $how=$how|&GDBM_NOLOCK();
                    299: # Go ahead and tie the hash
                    300:        return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
                    301:     }
                    302: 
                    303:     sub flock_sym {
                    304:         my ($lock_type)=@_;
                    305: 	my $failed=0;
                    306: 	eval {
                    307: 	    local $SIG{__DIE__}='DEFAULT';
                    308: 	    local $SIG{ALRM}=sub {
                    309: 		$failed=1;
                    310: 		die("failed lock");
                    311: 	    };
                    312: 	    alarm($loncapa_max_wait_time);
                    313: 	    flock($sym,$lock_type);
                    314: 	    alarm(0);
                    315: 	};
                    316: 	if ($failed) {
                    317: 	    $! = 100; # throwing error # 100
                    318: 	    return undef;
                    319: 	} else {
                    320: 	    return 1;
                    321: 	}
                    322:     }
                    323: 
                    324:     sub _locking_hash_untie {
                    325: 	my ($hashref) = @_;
                    326: 	my $result = untie(%$hashref);
                    327: 	flock($sym,LOCK_UN);
                    328: 	close($sym);
                    329: 	undef($sym);
                    330: 	return $result;
                    331:     }
                    332: }
                    333: 
                    334: BEGIN {
1.4       albertel  335:     %perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
1.2       www       336: }
                    337: 
1.1       albertel  338: 1;
                    339: 
                    340: __END__
                    341: 
                    342: =pod
                    343: 
                    344: =head1 NAME
                    345: 
                    346: LONCAPA - Basic routines
                    347: 
                    348: =head1 SYNOPSIS
                    349: 
                    350: Generally useful routines
                    351: 
                    352: =head1 EXPORTED SUBROUTINES
                    353: 
                    354: =over 4
                    355: 
                    356: =item *
                    357: 
                    358: escape() : unpack non-word characters into CGI-compatible hex codes
                    359: 
                    360: =item *
                    361: 
                    362: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
                    363: 
                    364: =item *
                    365: 
                    366: add_get_param() :
                    367:  Inputs:  url (with or without exit GET from parameters), hash ref of
                    368:               form name => value pairs
                    369: 
                    370:  Return: url with properly added the form name elements and values to the 
                    371:          the url doing proper escaping of the values and joining with ? or &
                    372:          as needed
                    373: 
                    374: =back

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>