|
version 1.304, 2005/12/10 00:46:23
|
version 1.317, 2006/02/07 05:08:27
|
|
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 2839 sub dump_profile_database {
|
Line 2921 sub dump_profile_database {
|
| $data{$symb}->{$param}=$value; |
$data{$symb}->{$param}=$value; |
| $data{$symb}->{'v.'.$param}=$v; |
$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 2976 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 2976 sub store_handler {
|
Line 3075 sub store_handler {
|
| $hashref->{"$version:$rid:timestamp"}=$now; |
$hashref->{"$version:$rid:timestamp"}=$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 3127 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) { |
foreach $key (@keys) { |
| $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; |
$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 3375 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 3491 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 3540 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 3589 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 3633 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 3616 sub dump_dcmail_handler {
|
Line 3713 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 3663 sub put_domainroles_handler {
|
Line 3760 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 3744 sub dump_domainroles_handler {
|
Line 3841 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 4239 sub get_institutional_code_format_handle
|
Line 4336 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 4251 sub get_institutional_code_format_handle
|
Line 4406 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 4683 sub ReadHostTable {
|
Line 4847 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 4933 sub reconlonc {
|
Line 5098 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 4954 sub reply {
|
Line 5119 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 5260 sub make_new_child {
|
Line 5425 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 5591 sub addline {
|
Line 5756 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 5632 sub chat_add {
|
Line 5797 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); |
| } |
} |
| } |
} |
| |
|
![[BACK]](/icons/back.gif){kind=icon}
Return to lond CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom