File:
[LON-CAPA] /
loncom /
LONCAPA.pm
Revision
1.24:
download - view:
text,
annotated -
select for diffs
Mon Jul 2 21:15:29 2007 UTC (17 years, 3 months ago) by
albertel
Branches:
MAIN
CVS tags:
version_2_8_X,
version_2_8_2,
version_2_8_1,
version_2_8_0,
version_2_7_X,
version_2_7_99_1,
version_2_7_99_0,
version_2_7_1,
version_2_7_0,
version_2_6_X,
version_2_6_99_1,
version_2_6_99_0,
version_2_6_3,
version_2_6_2,
version_2_6_1,
version_2_6_0,
version_2_5_X,
version_2_5_99_1,
version_2_5_99_0,
version_2_5_2,
version_2_5_1,
version_2_5_0,
version_2_4_X,
version_2_4_99_0,
version_2_4_2,
HEAD,
GCI_1
- BUG#5305 allow @ in usernames
# The LearningOnline Network
# Base routines
#
# $Id: LONCAPA.pm,v 1.24 2007/07/02 21:15:29 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
###
package LONCAPA;
use strict;
use lib '/home/httpd/lib/perl/';
use LONCAPA::Configuration;
use Fcntl qw(:flock);
use GDBM_File;
use POSIX;
my $loncapa_max_wait_time = 13;
use vars qw($match_domain $match_not_domain
$match_username $match_not_username
$match_courseid $match_not_courseid
$match_name
$match_lonid
$match_handle $match_not_handle);
require Exporter;
our @ISA = qw (Exporter);
our @EXPORT = qw(&add_get_param &escape &unescape
&tie_domain_hash &untie_domain_hash &tie_user_hash
&untie_user_hash &propath);
our @EXPORT_OK = qw($match_domain $match_not_domain
$match_username $match_not_username
$match_courseid $match_not_courseid
$match_name
$match_lonid
$match_handle $match_not_handle);
our %EXPORT_TAGS = ( 'match' =>[qw($match_domain $match_not_domain
$match_username $match_not_username
$match_courseid $match_not_courseid
$match_name
$match_lonid
$match_handle $match_not_handle)],);
my %perlvar;
# Inputs are a url, and a hash ref of
# form name => value pairs
# takes care of properly adding the form name elements and values to the
# the url doing proper escaping of the values and joining with ? or & as
# needed
sub add_get_param {
my ($url,$form_data) = @_;
my $needs_question_mark = ($url !~ /\?/);
while (my ($name,$value) = each(%$form_data)) {
if ($needs_question_mark) {
$url.='?';
$needs_question_mark = 0;
} else {
$url.='&';
}
$url.=$name.'='.&escape($form_data->{$name});
}
return $url;
}
# -------------------------------------------------------- Escape Special Chars
sub escape {
my $str=shift;
$str =~ s/(\W)/"%".unpack('H2',$1)/eg;
return $str;
}
# ----------------------------------------------------- Un-Escape Special Chars
sub unescape {
my $str=shift;
$str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
return $str;
}
$match_domain = $LONCAPA::domain_re = qr{[\w\-.]+};
$match_not_domain = $LONCAPA::not_domain_re = qr{[^\w\-.]+};
sub clean_domain {
my ($domain) = @_;
$domain =~ s/$match_not_domain//g;
return $domain;
}
$match_username = $LONCAPA::username_re = qr{\w[\w\-.@]+};
$match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.@]+};
sub clean_username {
my ($username) = @_;
$username =~ s/^\W+//;
$username =~ s/$match_not_username//g;
return $username;
}
$match_courseid = $LONCAPA::courseid_re = qr{\d[\w\-.]+};
$match_not_courseid = $LONCAPA::not_courseid_re = qr{[^\w\-.]+};
sub clean_courseid {
my ($courseid) = @_;
$courseid =~ s/^\D+//;
$courseid =~ s/$match_not_courseid//g;
return $courseid;
}
$match_name = $LONCAPA::name_re = qr{$match_username|$match_courseid};
sub clean_name {
my ($name) = @_;
$name =~ s/$match_not_username//g;
return $name;
}
$match_lonid = $LONCAPA::lonid_re = qr{[\w\-.]+};
sub split_courseid {
my ($courseid) = @_;
my ($domain,$coursenum) =
($courseid=~m{^/($match_domain)/($match_courseid)});
return ($domain,$coursenum);
}
$match_handle = $LONCAPA::handle_re = qr{[\w\-.@]+};
$match_not_handle = $LONCAPA::not_handle_re = qr{[^\w\-.@]+};
sub clean_handle {
my ($handle) = @_;
$handle =~ s/$match_not_handle//g;
return $handle;
}
# -------------------------------------------- Return path to profile directory
sub propath {
my ($udom,$uname)=@_;
$udom = &clean_domain($udom);
$uname= &clean_name($uname);
my $subdir=$uname.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
return $proname;
}
#---------------------------------------------------------------
#
# Manipulation of hash based databases (factoring out common code
# for later use as we refactor.
#
# Ties a domain level resource file to a hash.
# If requested a history entry is created in the associated hist file.
#
# Parameters:
# domain - Name of the domain in which the resource file lives.
# namespace - Name of the hash within that domain.
# how - How to tie the hash (e.g. GDBM_WRCREAT()).
# loghead - Optional parameter, if present a log entry is created
# in the associated history file and this is the first part
# of that entry.
# logtail - Goes along with loghead, The actual logentry is of the
# form $loghead:<timestamp>:logtail.
# Returns:
# Reference to a hash bound to the db file or alternatively undef
# if the tie failed.
#
sub tie_domain_hash {
my ($domain,$namespace,$how,$loghead,$logtail) = @_;
# Filter out any whitespace in the domain name:
$domain = &clean_domain($domain);
# We have enough to go on to tie the hash:
my $user_top_dir = $perlvar{'lonUsersDir'};
my $domain_dir = $user_top_dir."/$domain";
my $resource_file = $domain_dir."/$namespace";
return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);
}
sub untie_domain_hash {
return &_locking_hash_untie(@_);
}
#
# Ties a user's resource file to a hash.
# If necessary, an appropriate history
# log file entry is made as well.
# This sub factors out common code from the subs that manipulate
# the various gdbm files that keep keyword value pairs.
# Parameters:
# domain - Name of the domain the user is in.
# user - Name of the 'current user'.
# namespace - Namespace representing the file to tie.
# how - What the tie is done to (e.g. GDBM_WRCREAT().
# loghead - Optional first part of log entry if there may be a
# history file.
# what - Optional tail of log entry if there may be a history
# file.
# Returns:
# hash to which the database is tied. It's up to the caller to untie.
# undef if the has could not be tied.
#
sub tie_user_hash {
my ($domain,$user,$namespace,$how,$loghead,$what) = @_;
$namespace=~s{/}{_}g; # / -> _
$namespace = &clean_username($namespace);
my $proname = &propath($domain, $user);
my $file_prefix="$proname/$namespace";
return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
}
sub untie_user_hash {
return &_locking_hash_untie(@_);
}
# routines if you just have a filename
# return tied hashref or undef
sub locking_hash_tie {
my ($filename,$how)=@_;
my ($file_prefix,$namespace)=&db_filename_parts($filename);
if ($namespace eq '') { return undef; }
return &_locking_hash_tie($file_prefix,$namespace,$how);
}
sub locking_hash_untie {
return &_locking_hash_untie(@_);
}
sub db_filename_parts {
my ($filename)=@_;
my ($file_path,$namespace)=($filename=~/^(.*)\/([^\/]+)\.db$/);
if ($namespace eq '') { return undef; }
return ($file_path.'/'.$namespace,$namespace);
}
# internal routines that handle the actual tieing and untieing process
sub _do_hash_tie {
my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
my %hash;
if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {
# If this is a namespace for which a history is kept,
# make the history log entry:
if (($namespace !~/^nohist\_/) && (defined($loghead))) {
my $hfh = IO::File->new(">>$file_prefix.hist");
if($hfh) {
my $now = time();
print $hfh ("$loghead:$now:$what\n");
}
$hfh->close;
}
return \%hash;
} else {
return undef;
}
}
sub _do_hash_untie {
my ($hashref) = @_;
my $result = untie(%$hashref);
return $result;
}
{
my $sym;
my @pushed_syms;
sub clean_sym {
undef($sym);
}
sub push_locking_hash_tie {
if (!defined($sym)) {
die("Invalid used of push_locking_hash_tie, should only be called after a lock has occurred and before and unlock.");
}
push(@pushed_syms,$sym);
undef($sym);
}
sub pop_locking_hash_tie {
if (defined($sym)) {
die("Invalid nested used of pop_locking_hash_tie, should only be called after a unlock has occurred.");
}
$sym = pop(@pushed_syms);
}
sub _locking_hash_tie {
my ($file_prefix,$namespace,$how,$loghead,$what) = @_;
if (defined($sym)) {
die('Nested locking attempted without proper use of push_locking_hash_tie, this is unsupported');
}
my $lock_type=LOCK_SH;
# Are we reading or writing?
if ($how eq &GDBM_READER()) {
# We are reading
if (!open($sym,"$file_prefix.db.lock")) {
# We don't have a lock file. This could mean
# - that there is no such db-file
# - that it does not have a lock file yet
if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) {
# No such file. Forget it.
$! = 2;
&clean_sym();
return undef;
}
# Apparently just no lock file yet. Make one
open($sym,">>$file_prefix.db.lock");
}
# Do a shared lock
if (!&flock_sym(LOCK_SH)) {
&clean_sym();
return undef;
}
# If this is compressed, we will actually need an exclusive lock
if (-e "$file_prefix.db.gz") {
if (!&flock_sym(LOCK_EX)) {
&clean_sym();
return undef;
}
}
} elsif ($how eq &GDBM_WRCREAT()) {
# We are writing
open($sym,">>$file_prefix.db.lock");
# Writing needs exclusive lock
if (!&flock_sym(LOCK_EX)) {
&clean_sym();
return undef;
}
} else {
die("Unknown method $how for $file_prefix");
}
# The file is ours!
# If it is archived, un-archive it now
if (-e "$file_prefix.db.gz") {
system("gunzip $file_prefix.db.gz");
if (-e "$file_prefix.hist.gz") {
system("gunzip $file_prefix.hist.gz");
}
}
# Change access mode to non-blocking
$how=$how|&GDBM_NOLOCK();
# Go ahead and tie the hash
my $result =
&_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);
if (!$result) {
&clean_sym();
}
return $result;
}
sub flock_sym {
my ($lock_type)=@_;
my $failed=0;
eval {
local $SIG{__DIE__}='DEFAULT';
local $SIG{ALRM}=sub {
$failed=1;
die("failed lock");
};
alarm($loncapa_max_wait_time);
flock($sym,$lock_type);
alarm(0);
};
if ($failed) {
$! = 100; # throwing error # 100
return undef;
} else {
return 1;
}
}
sub _locking_hash_untie {
my ($hashref) = @_;
my $result = untie(%$hashref);
flock($sym,LOCK_UN);
close($sym);
&clean_sym();
return $result;
}
}
BEGIN {
%perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')};
}
1;
__END__
=pod
=head1 NAME
LONCAPA - Basic routines
=head1 SYNOPSIS
Generally useful routines
=head1 EXPORTED SUBROUTINES
=over 4
=item *
escape() : unpack non-word characters into CGI-compatible hex codes
=item *
unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
=item *
add_get_param() :
Inputs: url (with or without exit GET from parameters), hash ref of
form name => value pairs
Return: url with properly added the form name elements and values to the
the url doing proper escaping of the values and joining with ? or &
as needed
=back
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>