version 1.330, 2006/05/18 19:57:59
|
version 1.332, 2006/05/31 14:47:56
|
Line 58 my $DEBUG = 0; # Non zero to ena
|
Line 58 my $DEBUG = 0; # Non zero to ena
|
|
|
my $status=''; |
my $status=''; |
my $lastlog=''; |
my $lastlog=''; |
my $lond_max_wait_time = 13; |
|
|
|
my $VERSION='$Revision$'; #' stupid emacs |
my $VERSION='$Revision$'; #' stupid emacs |
my $remoteVERSION; |
my $remoteVERSION; |
Line 940 sub EditFile {
|
Line 939 sub EditFile {
|
return "ok\n"; |
return "ok\n"; |
} |
} |
|
|
#--------------------------------------------------------------- |
|
# |
|
# 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 =~ s/\W//g; |
|
|
|
# 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=~s/\W//g; # whitespace eliminated. |
|
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(@_); |
|
} |
|
|
|
# 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 $args = scalar @_; |
|
Debug(" Opening history: $file_prefix $args"); |
|
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; |
|
|
|
sub _locking_hash_tie { |
|
my ($file_prefix,$namespace,$how,$loghead,$what) = @_; |
|
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; |
|
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)) { return undef; } |
|
# If this is compressed, we will actually need an exclusive lock |
|
if (-e "$file_prefix.db.gz") { |
|
if (!&flock_sym(LOCK_EX)) { 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)) { return undef; } |
|
} else { |
|
&logthis("Unknown method $how for $file_prefix"); |
|
die(); |
|
} |
|
# 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 |
|
return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); |
|
} |
|
|
|
sub flock_sym { |
|
my ($lock_type)=@_; |
|
my $failed=0; |
|
eval { |
|
local $SIG{__DIE__}='DEFAULT'; |
|
local $SIG{ALRM}=sub { |
|
$failed=1; |
|
die("failed lock"); |
|
}; |
|
alarm($lond_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); |
|
undef($sym); |
|
return $result; |
|
} |
|
} |
|
|
|
# read_profile |
# read_profile |
# |
# |
# Returns a set of specific entries from a user's profile file. |
# Returns a set of specific entries from a user's profile file. |
Line 2311 sub token_auth_user_file_handler {
|
Line 2126 sub token_auth_user_file_handler {
|
my $reply="non_auth\n"; |
my $reply="non_auth\n"; |
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. |
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. |
$session.'.id')) { |
$session.'.id')) { |
|
flock(ENVIN,LOCK_SH); |
while (my $line=<ENVIN>) { |
while (my $line=<ENVIN>) { |
my ($envname)=split(/=/,$line,2); |
my ($envname)=split(/=/,$line,2); |
$envname=&unescape($envname); |
$envname=&unescape($envname); |
Line 5280 sub sub_sql_reply {
|
Line 5096 sub sub_sql_reply {
|
return $answer; |
return $answer; |
} |
} |
|
|
# -------------------------------------------- Return path to profile directory |
|
|
|
sub propath { |
|
my ($udom,$uname)=@_; |
|
$udom=~s/\W//g; |
|
$uname=~s/\W//g; |
|
my $subdir=$uname.'__'; |
|
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
|
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
|
return $proname; |
|
} |
|
|
|
# --------------------------------------- Is this the home server of an author? |
# --------------------------------------- Is this the home server of an author? |
|
|
sub ishome { |
sub ishome { |