version 1.301, 2005/10/17 20:09:01
|
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 87 my $ConnectionType;
|
Line 89 my $ConnectionType;
|
|
|
my %hostid; # ID's for hosts in cluster by ip. |
my %hostid; # ID's for hosts in cluster by ip. |
my %hostdom; # LonCAPA domain for hosts in cluster. |
my %hostdom; # LonCAPA domain for hosts in cluster. |
|
my %hostname; # DNSname -> ID's mapping. |
my %hostip; # IPs for hosts in cluster. |
my %hostip; # IPs for hosts in cluster. |
my %hostdns; # ID's of hosts looked up by DNS name. |
my %hostdns; # ID's of hosts looked up by DNS name. |
|
|
Line 970 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 { |
|
return &_locking_hash_untie(@_); |
|
} |
# |
# |
# Ties a user's resource file to a hash. |
# Ties a user's resource file to a hash. |
# If necessary, an appropriate history |
# If necessary, an appropriate history |
Line 1012 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 1034 sub tie_user_hash {
|
Line 1036 sub tie_user_hash {
|
} else { |
} else { |
return undef; |
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); |
|
|
|
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 |
Line 1067 sub read_profile {
|
Line 1134 sub read_profile {
|
$qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. |
$qresult.="$hashref->{$queries[$i]}&"; # Presumably failure gives empty string. |
} |
} |
$qresult=~s/\&$//; # Remove trailing & from last lookup. |
$qresult=~s/\&$//; # Remove trailing & from last lookup. |
if (untie %$hashref) { |
if (&untie_user_hash($hashref)) { |
return $qresult; |
return $qresult; |
} else { |
} else { |
return "error: ".($!+0)." untie (GDBM) Failed"; |
return "error: ".($!+0)." untie (GDBM) Failed"; |
Line 1943 sub update_resource_handler {
|
Line 2010 sub update_resource_handler {
|
my $since=$now-$atime; |
my $since=$now-$atime; |
if ($since>$perlvar{'lonExpire'}) { |
if ($since>$perlvar{'lonExpire'}) { |
my $reply=&reply("unsub:$fname","$clientname"); |
my $reply=&reply("unsub:$fname","$clientname"); |
|
&devalidate_meta_cache($fname); |
unlink("$fname"); |
unlink("$fname"); |
} else { |
} else { |
my $transname="$fname.in.transfer"; |
my $transname="$fname.in.transfer"; |
Line 1973 sub update_resource_handler {
|
Line 2041 sub update_resource_handler {
|
alarm(0); |
alarm(0); |
} |
} |
rename($transname,$fname); |
rename($transname,$fname); |
use Cache::Memcached; |
&devalidate_meta_cache($fname); |
my $memcache= |
|
new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); |
|
my $url=$fname; |
|
$url=~s-^/home/httpd/html--; |
|
my $id=&escape('meta:'.$url); |
|
$memcache->delete($id); |
|
} |
} |
} |
} |
&Reply( $client, "ok\n", $userinput); |
&Reply( $client, "ok\n", $userinput); |
Line 1993 sub update_resource_handler {
|
Line 2055 sub update_resource_handler {
|
} |
} |
®ister_handler("update", \&update_resource_handler, 0 ,1, 0); |
®ister_handler("update", \&update_resource_handler, 0 ,1, 0); |
|
|
|
sub devalidate_meta_cache { |
|
my ($url) = @_; |
|
use Cache::Memcached; |
|
my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']}); |
|
$url = &declutter($url); |
|
$url =~ s-\.meta$--; |
|
my $id = &escape('meta:'.$url); |
|
$memcache->delete($id); |
|
} |
|
|
|
sub declutter { |
|
my $thisfn=shift; |
|
$thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//; |
|
$thisfn=~s/^\///; |
|
$thisfn=~s|^adm/wrapper/||; |
|
$thisfn=~s|^adm/coursedocs/showdoc/||; |
|
$thisfn=~s/^res\///; |
|
$thisfn=~s/\?.+$//; |
|
return $thisfn; |
|
} |
# |
# |
# Fetch a user file from a remote server to the user's home directory |
# Fetch a user file from a remote server to the user's home directory |
# userfiles subdir. |
# userfiles subdir. |
Line 2361 sub put_user_profile_entry {
|
Line 2443 sub put_user_profile_entry {
|
my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
if (untie(%$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 2369 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 2405 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 2424 sub newput_user_profile_entry {
|
Line 2506 sub newput_user_profile_entry {
|
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
|
|
if (untie(%$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 2477 sub increment_user_value_handler {
|
Line 2559 sub increment_user_value_handler {
|
} |
} |
} |
} |
} |
} |
if (untie(%$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 2544 sub roles_put_handler {
|
Line 2626 sub roles_put_handler {
|
$auth_type); |
$auth_type); |
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
if (untie($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 2595 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(%$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 2736 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(%$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 2778 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(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 2833 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(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
while (my ($symb,$param_hash) = each(%data)) { |
while (my ($symb,$param_hash) = each(%data)) { |
while(my ($param,$value) = each (%$param_hash)){ |
while(my ($param,$value) = each (%$param_hash)){ |
next if ($param =~ /^v\./); # Ignore versions... |
next if ($param =~ /^v\./); # Ignore versions... |
Line 2894 sub dump_with_regexp {
|
Line 2982 sub dump_with_regexp {
|
|
|
my $userinput = "$cmd:$tail"; |
my $userinput = "$cmd:$tail"; |
|
|
my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail); |
my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail); |
if (defined($regexp)) { |
if (defined($regexp)) { |
$regexp=&unescape($regexp); |
$regexp=&unescape($regexp); |
} else { |
} else { |
$regexp='.'; |
$regexp='.'; |
} |
} |
|
my ($start,$end); |
|
if (defined($range)) { |
|
if ($range =~/^(\d+)\-(\d+)$/) { |
|
($start,$end) = ($1,$2); |
|
} elsif ($range =~/^(\d+)$/) { |
|
($start,$end) = (0,$1); |
|
} else { |
|
undef($range); |
|
} |
|
} |
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
my $hashref = &tie_user_hash($udom, $uname, $namespace, |
&GDBM_READER()); |
&GDBM_READER()); |
if ($hashref) { |
if ($hashref) { |
my $qresult=''; |
my $qresult=''; |
|
my $count=0; |
while (my ($key,$value) = each(%$hashref)) { |
while (my ($key,$value) = each(%$hashref)) { |
if ($regexp eq '.') { |
if ($regexp eq '.') { |
|
$count++; |
|
if (defined($range) && $count >= $end) { last; } |
|
if (defined($range) && $count < $start) { next; } |
$qresult.=$key.'='.$value.'&'; |
$qresult.=$key.'='.$value.'&'; |
} else { |
} else { |
my $unescapeKey = &unescape($key); |
my $unescapeKey = &unescape($key); |
if (eval('$unescapeKey=~/$regexp/')) { |
if (eval('$unescapeKey=~/$regexp/')) { |
|
$count++; |
|
if (defined($range) && $count >= $end) { last; } |
|
if (defined($range) && $count < $start) { next; } |
$qresult.="$key=$value&"; |
$qresult.="$key=$value&"; |
} |
} |
} |
} |
} |
} |
if (untie(%$hashref)) { |
if (&untie_user_hash($hashref)) { |
chop($qresult); |
chop($qresult); |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 2969 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($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 3028 sub restore_handler {
|
Line 3132 sub restore_handler {
|
$namespace=~s/\//\_/g; |
$namespace=~s/\//\_/g; |
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
chomp($rid); |
chomp($rid); |
my $proname=&propath($udom,$uname); |
|
my $qresult=''; |
my $qresult=''; |
my %hash; |
my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER()); |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db", |
if ($hashref) { |
&GDBM_READER(),0640)) { |
my $version=$hashref->{"version:$rid"}; |
my $version=$hash{"version:$rid"}; |
|
$qresult.="version=$version&"; |
$qresult.="version=$version&"; |
my $scope; |
my $scope; |
for ($scope=1;$scope<=$version;$scope++) { |
for ($scope=1;$scope<=$version;$scope++) { |
my $vkeys=$hash{"$scope:keys:$rid"}; |
my $vkeys=$hashref->{"$scope:keys:$rid"}; |
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=".$hash{"$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(%hash)) { |
if (&untie_user_hash($hashref)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
&Reply( $client, "$qresult\n", $userinput); |
&Reply( $client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 3278 sub put_course_id_handler {
|
Line 3388 sub put_course_id_handler {
|
} |
} |
$hashref->{$key}=$courseinfo.':'.$now; |
$hashref->{$key}=$courseinfo.':'.$now; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
&Reply( $client, "ok\n", $userinput); |
&Reply( $client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0) |
&Failure($client, "error: ".($!+0) |
Line 3394 sub dump_course_id_handler {
|
Line 3504 sub dump_course_id_handler {
|
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; |
$qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&'; |
} |
} |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
chop($qresult); |
chop($qresult); |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 3443 sub put_id_handler {
|
Line 3553 sub put_id_handler {
|
my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_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 3492 sub get_id_handler {
|
Line 3602 sub get_id_handler {
|
for (my $i=0;$i<=$#queries;$i++) { |
for (my $i=0;$i<=$#queries;$i++) { |
$qresult.="$hashref->{$queries[$i]}&"; |
$qresult.="$hashref->{$queries[$i]}&"; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 3536 sub put_dcmail_handler {
|
Line 3646 sub put_dcmail_handler {
|
my ($key,$value)=split(/=/,$what); |
my ($key,$value)=split(/=/,$what); |
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_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 3594 sub dump_dcmail_handler {
|
Line 3704 sub dump_dcmail_handler {
|
if ($hashref) { |
if ($hashref) { |
while (my ($key,$value) = each(%$hashref)) { |
while (my ($key,$value) = each(%$hashref)) { |
my $match = 1; |
my $match = 1; |
my ($timestamp,$subj,$uname,$udom) = split(/:/,&unescape($key),5); |
my ($timestamp,$subj,$uname,$udom) = |
$timestamp = &unescape($timestamp); |
split(/:/,&unescape(&unescape($key)),5); # yes, twice really |
$subj = &unescape($subj); |
$subj = &unescape($subj); |
$uname = &unescape($uname); |
|
$udom = &unescape($udom); |
|
unless ($startfilter eq '.' || !defined($startfilter)) { |
unless ($startfilter eq '.' || !defined($startfilter)) { |
if ($timestamp < $startfilter) { |
if ($timestamp < $startfilter) { |
$match = 0; |
$match = 0; |
Line 3618 sub dump_dcmail_handler {
|
Line 3726 sub dump_dcmail_handler {
|
$qresult.=$key.'='.$value.'&'; |
$qresult.=$key.'='.$value.'&'; |
} |
} |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
chop($qresult); |
chop($qresult); |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 3665 sub put_domainroles_handler {
|
Line 3773 sub put_domainroles_handler {
|
my ($key,$value)=split(/=/,$pair); |
my ($key,$value)=split(/=/,$pair); |
$hashref->{$key}=$value; |
$hashref->{$key}=$value; |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_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 3746 sub dump_domainroles_handler {
|
Line 3854 sub dump_domainroles_handler {
|
$qresult.=$key.'='.$value.'&'; |
$qresult.=$key.'='.$value.'&'; |
} |
} |
} |
} |
if (untie(%$hashref)) { |
if (&untie_domain_hash($hashref)) { |
chop($qresult); |
chop($qresult); |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 4241 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 4253 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; |
} |
} |
Line 4685 sub ReadHostTable {
|
Line 4860 sub ReadHostTable {
|
} |
} |
$hostid{$ip}=$id; # LonCAPA name of host by IP. |
$hostid{$ip}=$id; # LonCAPA name of host by IP. |
$hostdom{$id}=$domain; # LonCAPA domain name of host. |
$hostdom{$id}=$domain; # LonCAPA domain name of host. |
|
$hostname{$id}=$name; # LonCAPA name -> DNS name |
$hostip{$id}=$ip; # IP address of host. |
$hostip{$id}=$ip; # IP address of host. |
$hostdns{$name} = $id; # LonCAPA name of host by DNS. |
$hostdns{$name} = $id; # LonCAPA name of host by DNS. |
|
|
Line 4935 sub reconlonc {
|
Line 5111 sub reconlonc {
|
|
|
sub subreply { |
sub subreply { |
my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
my $peerfile="$perlvar{'lonSockDir'}/$server"; |
my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server}; |
my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", |
my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile", |
Type => SOCK_STREAM, |
Type => SOCK_STREAM, |
Timeout => 10) |
Timeout => 10) |
or return "con_lost"; |
or return "con_lost"; |
print $sclient "$cmd\n"; |
print $sclient "sethost:$server:$cmd\n"; |
my $answer=<$sclient>; |
my $answer=<$sclient>; |
chomp($answer); |
chomp($answer); |
if (!$answer) { $answer="con_lost"; } |
if (!$answer) { $answer="con_lost"; } |
Line 4956 sub reply {
|
Line 5132 sub reply {
|
$answer=subreply("ping",$server); |
$answer=subreply("ping",$server); |
if ($answer ne $server) { |
if ($answer ne $server) { |
&logthis("sub reply: answer != server answer is $answer, server is $server"); |
&logthis("sub reply: answer != server answer is $answer, server is $server"); |
&reconlonc("$perlvar{'lonSockDir'}/$server"); |
&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server}); |
} |
} |
$answer=subreply($cmd,$server); |
$answer=subreply($cmd,$server); |
} |
} |
Line 5262 sub make_new_child {
|
Line 5438 sub make_new_child {
|
# no need to try to do recon's to myself |
# no need to try to do recon's to myself |
next; |
next; |
} |
} |
&reconlonc("$perlvar{'lonSockDir'}/$id"); |
&reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id}); |
} |
} |
&logthis("<font color='green'>Established connection: $clientname</font>"); |
&logthis("<font color='green'>Established connection: $clientname</font>"); |
&status('Will listen to '.$clientname); |
&status('Will listen to '.$clientname); |
Line 5593 sub addline {
|
Line 5769 sub addline {
|
|
|
sub get_chat { |
sub get_chat { |
my ($cdom,$cname,$udom,$uname)=@_; |
my ($cdom,$cname,$udom,$uname)=@_; |
my %hash; |
|
my $proname=&propath($cdom,$cname); |
|
my @entries=(); |
my @entries=(); |
if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", |
my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom', |
&GDBM_READER(),0640)) { |
&GDBM_READER()); |
@entries=map { $_.':'.$hash{$_} } sort keys %hash; |
if ($hashref) { |
untie %hash; |
@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref)); |
|
&untie_user_hash($hashref); |
} |
} |
my @participants=(); |
my @participants=(); |
my $cutoff=time-60; |
my $cutoff=time-60; |
if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db", |
$hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom', |
&GDBM_WRCREAT(),0640)) { |
&GDBM_WRCREAT()); |
$hash{$uname.':'.$udom}=time; |
if ($hashref) { |
foreach (sort keys %hash) { |
$hashref->{$uname.':'.$udom}=time; |
if ($hash{$_}>$cutoff) { |
foreach my $user (sort(keys(%$hashref))) { |
$participants[$#participants+1]='active_participant:'.$_; |
if ($hashref->{$user}>$cutoff) { |
|
push(@participants, 'active_participant:'.$user); |
} |
} |
} |
} |
untie %hash; |
&untie_user_hash($hashref); |
} |
} |
return (@participants,@entries); |
return (@participants,@entries); |
} |
} |
|
|
sub chat_add { |
sub chat_add { |
my ($cdom,$cname,$newchat)=@_; |
my ($cdom,$cname,$newchat)=@_; |
my %hash; |
|
my $proname=&propath($cdom,$cname); |
|
my @entries=(); |
my @entries=(); |
my $time=time; |
my $time=time; |
if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", |
my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom', |
&GDBM_WRCREAT(),0640)) { |
&GDBM_WRCREAT()); |
@entries=map { $_.':'.$hash{$_} } sort keys %hash; |
if ($hashref) { |
|
@entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref)); |
my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); |
my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); |
my ($thentime,$idnum)=split(/\_/,$lastid); |
my ($thentime,$idnum)=split(/\_/,$lastid); |
my $newid=$time.'_000000'; |
my $newid=$time.'_000000'; |
Line 5634 sub chat_add {
|
Line 5810 sub chat_add {
|
$idnum=substr('000000'.$idnum,-6,6); |
$idnum=substr('000000'.$idnum,-6,6); |
$newid=$time.'_'.$idnum; |
$newid=$time.'_'.$idnum; |
} |
} |
$hash{$newid}=$newchat; |
$hashref->{$newid}=$newchat; |
my $expired=$time-3600; |
my $expired=$time-3600; |
foreach (keys %hash) { |
foreach my $comment (keys(%$hashref)) { |
my ($thistime)=($_=~/(\d+)\_/); |
my ($thistime) = ($comment=~/(\d+)\_/); |
if ($thistime<$expired) { |
if ($thistime<$expired) { |
delete $hash{$_}; |
delete $hashref->{$comment}; |
} |
} |
} |
} |
untie %hash; |
{ |
} |
my $proname=&propath($cdom,$cname); |
{ |
if (open(CHATLOG,">>$proname/chatroom.log")) { |
my $hfh; |
print CHATLOG ("$time:".&unescape($newchat)."\n"); |
if ($hfh=IO::File->new(">>$proname/chatroom.log")) { |
} |
print $hfh "$time:".&unescape($newchat)."\n"; |
close(CHATLOG); |
} |
} |
|
&untie_user_hash($hashref); |
} |
} |
} |
} |
|
|