version 1.2, 2006/05/30 12:45:12
|
version 1.16, 2006/12/01 21:52:28
|
Line 38 use POSIX;
|
Line 38 use POSIX;
|
|
|
my $loncapa_max_wait_time = 13; |
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_handle $match_not_handle); |
|
|
require Exporter; |
require Exporter; |
our @ISA = qw (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 = 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_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_handle $match_not_handle)],); |
my %perlvar; |
my %perlvar; |
|
|
|
|
|
|
# Inputs are a url, and a hash ref of |
# Inputs are a url, and a hash ref of |
# form name => value pairs |
# form name => value pairs |
# takes care of properly adding the form name elements and values to the |
# takes care of properly adding the form name elements and values to the |
Line 81 sub unescape {
|
Line 102 sub unescape {
|
return $str; |
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{[^a-zA-Z\_][\w\-.]+}; |
|
$match_not_username = $LONCAPA::not_username_re = qr{[^\w\-.]+}; |
|
sub clean_username { |
|
my ($username) = @_; |
|
$username =~ s/^\d+//; |
|
$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 is_courseid { |
|
my ($courseid) = @_; |
|
return ($courseid =~ m/^$match_courseid$/); |
|
} |
|
|
|
$match_name = qr{$match_username|$match_courseid}; |
|
sub clean_name { |
|
my ($name) = @_; |
|
$name =~ s/$match_not_username//g; |
|
return $name; |
|
} |
|
|
|
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 |
# -------------------------------------------- Return path to profile directory |
|
|
sub propath { |
sub propath { |
my ($udom,$uname)=@_; |
my ($udom,$uname)=@_; |
$udom=~s/\W//g; |
$udom = &clean_domain($udom); |
$uname=~s/\W//g; |
$uname= &clean_name($uname); |
my $subdir=$uname.'__'; |
my $subdir=$uname.'__'; |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
Line 120 sub tie_domain_hash {
|
Line 188 sub tie_domain_hash {
|
|
|
# Filter out any whitespace in the domain name: |
# Filter out any whitespace in the domain name: |
|
|
$domain =~ s/\W//g; |
$domain = &clean_domain($domain); |
|
|
# We have enough to go on to tie the hash: |
# We have enough to go on to tie the hash: |
|
|
Line 155 sub untie_domain_hash {
|
Line 223 sub untie_domain_hash {
|
sub tie_user_hash { |
sub tie_user_hash { |
my ($domain,$user,$namespace,$how,$loghead,$what) = @_; |
my ($domain,$user,$namespace,$how,$loghead,$what) = @_; |
|
|
$namespace=~s/\//\_/g; # / -> _ |
$namespace=~s{/}{_}g; # / -> _ |
$namespace=~s/\W//g; # whitespace eliminated. |
$namespace = &clean_username($namespace); |
my $proname = &propath($domain, $user); |
my $proname = &propath($domain, $user); |
|
|
my $file_prefix="$proname/$namespace"; |
my $file_prefix="$proname/$namespace"; |
return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what); |
return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what); |
} |
} |
Line 167 sub untie_user_hash {
|
Line 234 sub untie_user_hash {
|
return &_locking_hash_untie(@_); |
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 |
# internal routines that handle the actual tieing and untieing process |
|
|
sub _do_hash_tie { |
sub _do_hash_tie { |
Line 176 sub _do_hash_tie {
|
Line 264 sub _do_hash_tie {
|
# If this is a namespace for which a history is kept, |
# If this is a namespace for which a history is kept, |
# make the history log entry: |
# make the history log entry: |
if (($namespace !~/^nohist\_/) && (defined($loghead))) { |
if (($namespace !~/^nohist\_/) && (defined($loghead))) { |
my $args = scalar @_; |
|
Debug(" Opening history: $file_prefix $args"); |
|
my $hfh = IO::File->new(">>$file_prefix.hist"); |
my $hfh = IO::File->new(">>$file_prefix.hist"); |
if($hfh) { |
if($hfh) { |
my $now = time; |
my $now = time(); |
print $hfh "$loghead:$now:$what\n"; |
print $hfh ("$loghead:$now:$what\n"); |
} |
} |
$hfh->close; |
$hfh->close; |
} |
} |
Line 199 sub _do_hash_untie {
|
Line 285 sub _do_hash_untie {
|
|
|
{ |
{ |
my $sym; |
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 { |
sub _locking_hash_tie { |
my ($file_prefix,$namespace,$how,$loghead,$what) = @_; |
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; |
my $lock_type=LOCK_SH; |
# Are we reading or writing? |
# Are we reading or writing? |
if ($how eq &GDBM_READER()) { |
if ($how eq &GDBM_READER()) { |
Line 213 sub _do_hash_untie {
|
Line 322 sub _do_hash_untie {
|
if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) { |
if ((! -e "$file_prefix.db") && (! -e "$file_prefix.db.gz")) { |
# No such file. Forget it. |
# No such file. Forget it. |
$! = 2; |
$! = 2; |
|
&clean_sym(); |
return undef; |
return undef; |
} |
} |
# Apparently just no lock file yet. Make one |
# Apparently just no lock file yet. Make one |
open($sym,">>$file_prefix.db.lock"); |
open($sym,">>$file_prefix.db.lock"); |
} |
} |
# Do a shared lock |
# Do a shared lock |
if (!&flock_sym(LOCK_SH)) { return undef; } |
if (!&flock_sym(LOCK_SH)) { |
|
&clean_sym(); |
|
return undef; |
|
} |
# If this is compressed, we will actually need an exclusive lock |
# If this is compressed, we will actually need an exclusive lock |
if (-e "$file_prefix.db.gz") { |
if (-e "$file_prefix.db.gz") { |
if (!&flock_sym(LOCK_EX)) { return undef; } |
if (!&flock_sym(LOCK_EX)) { |
|
&clean_sym(); |
|
return undef; |
|
} |
} |
} |
} elsif ($how eq &GDBM_WRCREAT()) { |
} elsif ($how eq &GDBM_WRCREAT()) { |
# We are writing |
# We are writing |
open($sym,">>$file_prefix.db.lock"); |
open($sym,">>$file_prefix.db.lock"); |
# Writing needs exclusive lock |
# Writing needs exclusive lock |
if (!&flock_sym(LOCK_EX)) { return undef; } |
if (!&flock_sym(LOCK_EX)) { |
|
&clean_sym(); |
|
return undef; |
|
} |
} else { |
} else { |
&logthis("Unknown method $how for $file_prefix"); |
die("Unknown method $how for $file_prefix"); |
die(); |
|
} |
} |
# The file is ours! |
# The file is ours! |
# If it is archived, un-archive it now |
# If it is archived, un-archive it now |
Line 244 sub _do_hash_untie {
|
Line 362 sub _do_hash_untie {
|
# Change access mode to non-blocking |
# Change access mode to non-blocking |
$how=$how|&GDBM_NOLOCK(); |
$how=$how|&GDBM_NOLOCK(); |
# Go ahead and tie the hash |
# Go ahead and tie the hash |
return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); |
my $result = |
|
&_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); |
|
if (!$result) { |
|
&clean_sym(); |
|
} |
|
return $result; |
} |
} |
|
|
sub flock_sym { |
sub flock_sym { |
Line 273 sub _do_hash_untie {
|
Line 396 sub _do_hash_untie {
|
my $result = untie(%$hashref); |
my $result = untie(%$hashref); |
flock($sym,LOCK_UN); |
flock($sym,LOCK_UN); |
close($sym); |
close($sym); |
undef($sym); |
&clean_sym(); |
return $result; |
return $result; |
} |
} |
} |
} |
|
|
BEGIN { |
BEGIN { |
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); |
%perlvar=%{&LONCAPA::Configuration::read_conf('loncapa.conf')}; |
%perlvar=%{$perlvarref}; |
|
undef $perlvarref; |
|
} |
} |
|
|
1; |
1; |