version 1.311, 2006/01/31 15:37:41
|
version 1.318.2.4, 2006/02/09 23:41:22
|
Line 53 use LONCAPA::ConfigFileEdit;
|
Line 53 use LONCAPA::ConfigFileEdit;
|
use LONCAPA::lonlocal; |
use LONCAPA::lonlocal; |
use LONCAPA::lonssl; |
use LONCAPA::lonssl; |
use Fcntl qw(:flock); |
use Fcntl qw(:flock); |
|
use Symbol; |
|
|
my $DEBUG = 0; # Non zero to enable debug log entries. |
my $DEBUG = 0; # Non zero to enable debug log entries. |
|
|
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 971 sub tie_domain_hash {
|
Line 973 sub tie_domain_hash {
|
|
|
my $user_top_dir = $perlvar{'lonUsersDir'}; |
my $user_top_dir = $perlvar{'lonUsersDir'}; |
my $domain_dir = $user_top_dir."/$domain"; |
my $domain_dir = $user_top_dir."/$domain"; |
my $resource_file = $domain_dir."/$namespace.db"; |
my $resource_file = $domain_dir."/$namespace"; |
my %hash; |
return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail); |
if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) { |
|
if (defined($loghead)) { # Need to log the operation. |
|
my $logFh = IO::File->new(">>$domain_dir/$namespace.hist"); |
|
if($logFh) { |
|
my $timestamp = time; |
|
print $logFh "$loghead:$timestamp:$logtail\n"; |
|
} |
|
$logFh->close; |
|
} |
|
return \%hash; # Return the tied hash. |
|
} else { |
|
return undef; # Tie failed. |
|
} |
|
} |
} |
|
|
sub untie_domain_hash { |
sub untie_domain_hash { |
my ($hashref) = @_; |
return &_locking_hash_untie(@_); |
untie(%$hashref); |
|
} |
} |
# |
# |
# Ties a user's resource file to a hash. |
# Ties a user's resource file to a hash. |
Line 1017 sub tie_user_hash {
|
Line 1005 sub tie_user_hash {
|
$namespace=~s/\//\_/g; # / -> _ |
$namespace=~s/\//\_/g; # / -> _ |
$namespace=~s/\W//g; # whitespace eliminated. |
$namespace=~s/\W//g; # whitespace eliminated. |
my $proname = propath($domain, $user); |
my $proname = propath($domain, $user); |
|
|
# Tie the database. |
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; |
my %hash; |
if(tie(%hash, 'GDBM_File', "$proname/$namespace.db", |
if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) { |
$how, 0640)) { |
|
# 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 @_; |
my $args = scalar @_; |
Debug(" Opening history: $namespace $args"); |
Debug(" Opening history: $file_prefix $args"); |
my $hfh = IO::File->new(">>$proname/$namespace.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"; |
Line 1039 sub tie_user_hash {
|
Line 1036 sub tie_user_hash {
|
} else { |
} else { |
return undef; |
return undef; |
} |
} |
|
|
} |
} |
|
|
sub untie_user_hash { |
sub _do_hash_untie { |
my ($hashref) = @_; |
my ($hashref) = @_; |
my $result = untie(%$hashref); |
my $result = untie(%$hashref); |
return $result; |
return $result; |
} |
} |
|
|
|
{ |
|
my $sym; |
|
|
|
sub _locking_hash_tie { |
|
my ($file_prefix,$namespace,$how,$loghead,$what) = @_; |
|
|
|
my ($lock); |
|
|
|
if ($how eq &GDBM_READER()) { |
|
$lock=LOCK_SH; |
|
$how=$how|&GDBM_NOLOCK(); |
|
#if the db doesn't exist we can't read from it |
|
if (! -e "$file_prefix.db") { |
|
$! = 2; |
|
return undef; |
|
} |
|
} elsif ($how eq &GDBM_WRCREAT()) { |
|
$lock=LOCK_EX; |
|
$how=$how|&GDBM_NOLOCK(); |
|
if (! -e "$file_prefix.db") { |
|
# doesn't exist but we need it to in order to successfully |
|
# lock it so bring it into existance |
|
open(TOUCH,">>$file_prefix.db"); |
|
close(TOUCH); |
|
} |
|
} else { |
|
&logthis("Unknown method $how for $file_prefix"); |
|
die(); |
|
} |
|
|
|
$sym=&Symbol::gensym(); |
|
open($sym,"$file_prefix.db"); |
|
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); |
|
alarm(0); |
|
}; |
|
if ($failed) { |
|
$! = 100; # throwing error # 100 |
|
return undef; |
|
} |
|
return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); |
|
} |
|
|
|
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 2394 sub put_user_profile_entry {
|
Line 2451 sub put_user_profile_entry {
|
$userinput); |
$userinput); |
} |
} |
} else { |
} else { |
&Failure( $client, "error: ".($!)." tie(GDBM) Failed ". |
&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". |
"while attempting put\n", $userinput); |
"while attempting put\n", $userinput); |
} |
} |
} else { |
} else { |
Line 2430 sub newput_user_profile_entry {
|
Line 2487 sub newput_user_profile_entry {
|
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
&GDBM_WRCREAT(),"N",$what); |
&GDBM_WRCREAT(),"N",$what); |
if(!$hashref) { |
if(!$hashref) { |
&Failure( $client, "error: ".($!)." tie(GDBM) Failed ". |
&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". |
"while attempting put\n", $userinput); |
"while attempting put\n", $userinput); |
return 1; |
return 1; |
} |
} |
Line 2620 sub roles_delete_handler {
|
Line 2677 sub roles_delete_handler {
|
foreach my $key (@rolekeys) { |
foreach my $key (@rolekeys) { |
delete $hashref->{$key}; |
delete $hashref->{$key}; |
} |
} |
if (&untie_user_hash(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 2761 sub delete_profile_entry {
|
Line 2818 sub delete_profile_entry {
|
foreach my $key (@keys) { |
foreach my $key (@keys) { |
delete($hashref->{$key}); |
delete($hashref->{$key}); |
} |
} |
if (&untie_user_hash(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 2803 sub get_profile_keys {
|
Line 2860 sub get_profile_keys {
|
foreach my $key (keys %$hashref) { |
foreach my $key (keys %$hashref) { |
$qresult.="$key&"; |
$qresult.="$key&"; |
} |
} |
if (&untie_user_hash(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 2858 sub dump_profile_database {
|
Line 2915 sub dump_profile_database {
|
while (my ($key,$value) = each(%$hashref)) { |
while (my ($key,$value) = each(%$hashref)) { |
my ($v,$symb,$param) = split(/:/,$key); |
my ($v,$symb,$param) = split(/:/,$key); |
next if ($v eq 'version' || $symb eq 'keys'); |
next if ($v eq 'version' || $symb eq 'keys'); |
next if (exists($data{$symb}) && |
# making old style store entries '$ver:$symb:$key = $value' |
exists($data{$symb}->{$param}) && |
# look like new '$ver:$symb = "$key=$value"' |
$data{$symb}->{'v.'.$param} > $v); |
if (defined($param)) { $value = $param.'='.$value; } |
$data{$symb}->{$param}=$value; |
foreach my $pair (split(/\&/,$value)) { |
$data{$symb}->{'v.'.$param}=$v; |
my ($param,$value)=split(/=/,$pair); |
|
next if (exists($data{$symb}) && |
|
exists($data{$symb}->{$param}) && |
|
$data{$symb}->{'v.'.$param} > $v); |
|
$data{$symb}->{$param}=$value; |
|
$data{$symb}->{'v.'.$param}=$v; |
|
} |
} |
} |
if (&untie_user_hash($hashref)) { |
if (&untie_user_hash($hashref)) { |
while (my ($symb,$param_hash) = each(%data)) { |
while (my ($symb,$param_hash) = each(%data)) { |
Line 3011 sub store_handler {
|
Line 3074 sub store_handler {
|
my $version=$hashref->{"version:$rid"}; |
my $version=$hashref->{"version:$rid"}; |
my $allkeys=''; |
my $allkeys=''; |
foreach my $pair (@pairs) { |
foreach my $pair (@pairs) { |
my ($key,$value)=split(/=/,$pair); |
my ($key)=split(/=/,$pair); |
$allkeys.=$key.':'; |
$allkeys.=$key.':'; |
$hashref->{"$version:$rid:$key"}=$value; |
|
} |
} |
$hashref->{"$version:$rid:timestamp"}=$now; |
$hashref->{"$version:$rid"}=$what."\×tamp=$now"; |
$allkeys.='timestamp'; |
$allkeys.='timestamp'; |
$hashref->{"$version:keys:$rid"}=$allkeys; |
$hashref->{"$version:keys:$rid"}=$allkeys; |
if (&untie_user_hash($hashref)) { |
if (&untie_user_hash($hashref)) { |
Line 3081 sub restore_handler {
|
Line 3143 sub restore_handler {
|
my @keys=split(/:/,$vkeys); |
my @keys=split(/:/,$vkeys); |
my $key; |
my $key; |
$qresult.="$scope:keys=$vkeys&"; |
$qresult.="$scope:keys=$vkeys&"; |
foreach $key (@keys) { |
if (exists($hashref->{"$scope:$rid"})) { |
$qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&"; |
my $what=$hashref->{"$scope:$rid"}; |
} |
foreach my $pair (split(/\&/,$hashref->{"$scope:$rid"})) { |
|
my ($key,$value)=split(/=/,$pair); |
|
$qresult.="$scope:".$pair."&"; |
|
} |
|
} else { |
|
foreach $key (@keys) { |
|
$qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&"; |
|
} |
|
} |
} |
} |
if (&untie_user_hash($hashref)) { |
if (&untie_user_hash($hashref)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
Line 4279 sub get_institutional_code_format_handle
|
Line 4349 sub get_institutional_code_format_handle
|
®ister_handler("autoinstcodeformat", |
®ister_handler("autoinstcodeformat", |
\&get_institutional_code_format_handler,0,1,0); |
\&get_institutional_code_format_handler,0,1,0); |
|
|
|
# Get domain specific conditions for import of student photographs to a course |
|
# |
|
# Retrieves information from photo_permission subroutine in localenroll. |
|
# Returns outcome (ok) if no processing errors, and whether course owner is |
|
# required to accept conditions of use (yes/no). |
|
# |
|
# |
|
sub photo_permission_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
my $userinput = "$cmd:$tail"; |
|
my $cdom = $tail; |
|
my ($perm_reqd,$conditions); |
|
my $outcome = &localenroll::photo_permission($cdom,\$perm_reqd, |
|
\$conditions); |
|
&Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n", |
|
$userinput); |
|
} |
|
®ister_handler("autophotopermission",\&photo_permission_handler,0,1,0); |
|
|
|
# |
|
# Checks if student photo is available for a user in the domain, in the user's |
|
# directory (in /userfiles/internal/studentphoto.jpg). |
|
# Uses localstudentphoto:fetch() to ensure there is an up to date copy of |
|
# the student's photo. |
|
|
|
sub photo_check_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
my $userinput = "$cmd:$tail"; |
|
my ($udom,$uname,$pid) = split(/:/,$tail); |
|
$udom = &unescape($udom); |
|
$uname = &unescape($uname); |
|
$pid = &unescape($pid); |
|
my $path=&propath($udom,$uname).'/userfiles/internal/'; |
|
if (!-e $path) { |
|
&mkpath($path); |
|
} |
|
my $response; |
|
my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response); |
|
$result .= ':'.$response; |
|
&Reply($client, &escape($result)."\n",$userinput); |
|
} |
|
®ister_handler("autophotocheck",\&photo_check_handler,0,1,0); |
|
|
|
# |
|
# Retrieve information from localenroll about whether to provide a button |
|
# for users who have enbled import of student photos to initiate an |
|
# update of photo files for registered students. Also include |
|
# comment to display alongside button. |
|
|
|
sub photo_choice_handler { |
|
my ($cmd, $tail, $client) = @_; |
|
my $userinput = "$cmd:$tail"; |
|
my $cdom = &unescape($tail); |
|
my ($update,$comment) = &localenroll::manager_photo_update($cdom); |
|
&Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput); |
|
} |
|
®ister_handler("autophotochoice",\&photo_choice_handler,0,1,0); |
|
|
# |
# |
# Gets a student's photo to exist (in the correct image type) in the user's |
# Gets a student's photo to exist (in the correct image type) in the user's |
# directory. |
# directory. |
Line 4291 sub get_institutional_code_format_handle
|
Line 4419 sub get_institutional_code_format_handle
|
# $client - The socket open on the client. |
# $client - The socket open on the client. |
# Returns: |
# Returns: |
# 1 - continue processing. |
# 1 - continue processing. |
|
|
sub student_photo_handler { |
sub student_photo_handler { |
my ($cmd, $tail, $client) = @_; |
my ($cmd, $tail, $client) = @_; |
my ($domain,$uname,$type) = split(/:/, $tail); |
my ($domain,$uname,$ext,$type) = split(/:/, $tail); |
|
|
my $path=&propath($domain,$uname). |
my $path=&propath($domain,$uname). '/userfiles/internal/'; |
'/userfiles/internal/studentphoto.'.$type; |
my $filename = 'studentphoto.'.$ext; |
if (-e $path) { |
if ($type eq 'thumbnail') { |
|
$filename = 'studentphoto_tn.'.$ext; |
|
} |
|
if (-e $path.$filename) { |
&Reply($client,"ok\n","$cmd:$tail"); |
&Reply($client,"ok\n","$cmd:$tail"); |
return 1; |
return 1; |
} |
} |
&mkpath($path); |
&mkpath($path); |
my $file=&localstudentphoto::fetch($domain,$uname); |
my $file; |
|
if ($type eq 'thumbnail') { |
|
$file=&localstudentphoto::fetch_thumbnail($domain,$uname); |
|
} else { |
|
$file=&localstudentphoto::fetch($domain,$uname); |
|
} |
if (!$file) { |
if (!$file) { |
&Failure($client,"unavailable\n","$cmd:$tail"); |
&Failure($client,"unavailable\n","$cmd:$tail"); |
return 1; |
return 1; |
} |
} |
if (!-e $path) { &convert_photo($file,$path); } |
if (!-e $path.$filename) { &convert_photo($file,$path.$filename); } |
if (-e $path) { |
if (-e $path.$filename) { |
&Reply($client,"ok\n","$cmd:$tail"); |
&Reply($client,"ok\n","$cmd:$tail"); |
return 1; |
return 1; |
} |
} |