|
version 1.288, 2005/06/27 14:16:30
|
version 1.320, 2006/02/10 09:47:36
|
|
Line 48 use localauth;
|
Line 48 use localauth;
|
| use localenroll; |
use localenroll; |
| use localstudentphoto; |
use localstudentphoto; |
| use File::Copy; |
use File::Copy; |
| |
use File::Find; |
| use LONCAPA::ConfigFileEdit; |
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 86 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 969 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 1011 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 1033 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 1066 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 1363 sub du_handler {
|
Line 1431 sub du_handler {
|
| # etc. |
# etc. |
| # |
# |
| if (-d $ududir) { |
if (-d $ududir) { |
| # And as Shakespeare would say to make |
my $total_size=0; |
| # assurance double sure, |
my $code=sub { |
| # use execute_command to ensure that the command is not executed in |
if ($_=~/\.\d+\./) { return;} |
| # a shell that can screw us up. |
if ($_=~/\.meta$/) { return;} |
| |
$total_size+=(stat($_))[7]; |
| my $duout = execute_command("du -ks $ududir"); |
}; |
| $duout=~s/[^\d]//g; #preserve only the numbers |
chdir($ududir); |
| &Reply($client,"$duout\n","$cmd:$ududir"); |
find($code,$ududir); |
| |
$total_size=int($total_size/1024); |
| |
&Reply($client,"$total_size\n","$cmd:$ududir"); |
| } else { |
} else { |
| |
|
| &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); |
&Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); |
| |
|
| } |
} |
| return 1; |
return 1; |
| } |
} |
|
Line 1413 sub ls_handler {
|
Line 1481 sub ls_handler {
|
| if(-d $ulsdir) { |
if(-d $ulsdir) { |
| if (opendir(LSDIR,$ulsdir)) { |
if (opendir(LSDIR,$ulsdir)) { |
| while ($ulsfn=readdir(LSDIR)) { |
while ($ulsfn=readdir(LSDIR)) { |
| undef $obs, $rights; |
undef($obs); |
| |
undef($rights); |
| my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
| #We do some obsolete checking here |
#We do some obsolete checking here |
| if(-e $ulsdir.'/'.$ulsfn.".meta") { |
if(-e $ulsdir.'/'.$ulsfn.".meta") { |
| open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
| my @obsolete=<FILE>; |
my @obsolete=<FILE>; |
| foreach my $obsolete (@obsolete) { |
foreach my $obsolete (@obsolete) { |
| if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } |
if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } |
| if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; } |
if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; } |
| } |
} |
| } |
} |
|
Line 1480 sub ls2_handler {
|
Line 1549 sub ls2_handler {
|
| if(-d $ulsdir) { |
if(-d $ulsdir) { |
| if (opendir(LSDIR,$ulsdir)) { |
if (opendir(LSDIR,$ulsdir)) { |
| while ($ulsfn=readdir(LSDIR)) { |
while ($ulsfn=readdir(LSDIR)) { |
| undef $obs, $rights; |
undef($obs); |
| |
undef($rights); |
| my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
my @ulsstats=stat($ulsdir.'/'.$ulsfn); |
| #We do some obsolete checking here |
#We do some obsolete checking here |
| if(-e $ulsdir.'/'.$ulsfn.".meta") { |
if(-e $ulsdir.'/'.$ulsfn.".meta") { |
| open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
open(FILE, $ulsdir.'/'.$ulsfn.".meta"); |
| my @obsolete=<FILE>; |
my @obsolete=<FILE>; |
| foreach my $obsolete (@obsolete) { |
foreach my $obsolete (@obsolete) { |
| if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; } |
if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } |
| if($obsolete =~ m|(<copyright>)(default)|) { |
if($obsolete =~ m|(<copyright>)(default)|) { |
| $rights = 1; |
$rights = 1; |
| } |
} |
|
Line 1940 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 1970 sub update_resource_handler {
|
Line 2041 sub update_resource_handler {
|
| alarm(0); |
alarm(0); |
| } |
} |
| rename($transname,$fname); |
rename($transname,$fname); |
| |
&devalidate_meta_cache($fname); |
| } |
} |
| } |
} |
| &Reply( $client, "ok\n", $userinput); |
&Reply( $client, "ok\n", $userinput); |
|
Line 1983 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 2351 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 2359 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 2395 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 2414 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 2467 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 2534 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 2585 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 2726 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 2768 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 2829 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 2884 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 2966 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 3018 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 3268 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 3384 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 3433 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 3482 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 3499 sub get_id_handler {
|
Line 3606 sub get_id_handler {
|
| ®ister_handler("idget", \&get_id_handler, 0, 1, 0); |
®ister_handler("idget", \&get_id_handler, 0, 1, 0); |
| |
|
| # |
# |
| |
# Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database |
| |
# |
| |
# Parameters |
| |
# $cmd - Command keyword that caused us to be dispatched. |
| |
# $tail - Tail of the command. Consists of a colon separated: |
| |
# domain - the domain whose dcmail we are recording |
| |
# email Consists of key=value pair |
| |
# where key is unique msgid |
| |
# and value is message (in XML) |
| |
# $client - Socket open on the client. |
| |
# |
| |
# Returns: |
| |
# 1 - indicating processing should continue. |
| |
# Side effects |
| |
# reply is written to $client. |
| |
# |
| |
sub put_dcmail_handler { |
| |
my ($cmd,$tail,$client) = @_; |
| |
my $userinput = "$cmd:$tail"; |
| |
|
| |
my ($udom,$what)=split(/:/,$tail); |
| |
chomp($what); |
| |
my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); |
| |
if ($hashref) { |
| |
my ($key,$value)=split(/=/,$what); |
| |
$hashref->{$key}=$value; |
| |
} |
| |
if (&untie_domain_hash($hashref)) { |
| |
&Reply($client, "ok\n", $userinput); |
| |
} else { |
| |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
| |
"while attempting dcmailput\n", $userinput); |
| |
} |
| |
return 1; |
| |
} |
| |
®ister_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0); |
| |
|
| |
# |
| |
# Retrieves broadcast e-mail from nohist_dcmail database |
| |
# Returns to client an & separated list of key=value pairs, |
| |
# where key is msgid and value is message information. |
| |
# |
| |
# Parameters |
| |
# $cmd - Command keyword that caused us to be dispatched. |
| |
# $tail - Tail of the command. Consists of a colon separated: |
| |
# domain - the domain whose dcmail table we dump |
| |
# startfilter - beginning of time window |
| |
# endfilter - end of time window |
| |
# sendersfilter - & separated list of username:domain |
| |
# for senders to search for. |
| |
# $client - Socket open on the client. |
| |
# |
| |
# Returns: |
| |
# 1 - indicating processing should continue. |
| |
# Side effects |
| |
# reply (& separated list of msgid=messageinfo pairs) is |
| |
# written to $client. |
| |
# |
| |
sub dump_dcmail_handler { |
| |
my ($cmd, $tail, $client) = @_; |
| |
|
| |
my $userinput = "$cmd:$tail"; |
| |
my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail); |
| |
chomp($sendersfilter); |
| |
my @senders = (); |
| |
if (defined($startfilter)) { |
| |
$startfilter=&unescape($startfilter); |
| |
} else { |
| |
$startfilter='.'; |
| |
} |
| |
if (defined($endfilter)) { |
| |
$endfilter=&unescape($endfilter); |
| |
} else { |
| |
$endfilter='.'; |
| |
} |
| |
if (defined($sendersfilter)) { |
| |
$sendersfilter=&unescape($sendersfilter); |
| |
@senders = map { &unescape($_) } split(/\&/,$sendersfilter); |
| |
} |
| |
|
| |
my $qresult=''; |
| |
my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); |
| |
if ($hashref) { |
| |
while (my ($key,$value) = each(%$hashref)) { |
| |
my $match = 1; |
| |
my ($timestamp,$subj,$uname,$udom) = |
| |
split(/:/,&unescape(&unescape($key)),5); # yes, twice really |
| |
$subj = &unescape($subj); |
| |
unless ($startfilter eq '.' || !defined($startfilter)) { |
| |
if ($timestamp < $startfilter) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
unless ($endfilter eq '.' || !defined($endfilter)) { |
| |
if ($timestamp > $endfilter) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
unless (@senders < 1) { |
| |
unless (grep/^$uname:$udom$/,@senders) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
if ($match == 1) { |
| |
$qresult.=$key.'='.$value.'&'; |
| |
} |
| |
} |
| |
if (&untie_domain_hash($hashref)) { |
| |
chop($qresult); |
| |
&Reply($client, "$qresult\n", $userinput); |
| |
} else { |
| |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
| |
"while attempting dcmaildump\n", $userinput); |
| |
} |
| |
} else { |
| |
&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". |
| |
"while attempting dcmaildump\n", $userinput); |
| |
} |
| |
return 1; |
| |
} |
| |
|
| |
®ister_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0); |
| |
|
| |
# |
| |
# Puts domain roles in nohist_domainroles database |
| |
# |
| |
# Parameters |
| |
# $cmd - Command keyword that caused us to be dispatched. |
| |
# $tail - Tail of the command. Consists of a colon separated: |
| |
# domain - the domain whose roles we are recording |
| |
# role - Consists of key=value pair |
| |
# where key is unique role |
| |
# and value is start/end date information |
| |
# $client - Socket open on the client. |
| |
# |
| |
# Returns: |
| |
# 1 - indicating processing should continue. |
| |
# Side effects |
| |
# reply is written to $client. |
| |
# |
| |
|
| |
sub put_domainroles_handler { |
| |
my ($cmd,$tail,$client) = @_; |
| |
|
| |
my $userinput = "$cmd:$tail"; |
| |
my ($udom,$what)=split(/:/,$tail); |
| |
chomp($what); |
| |
my @pairs=split(/\&/,$what); |
| |
my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); |
| |
if ($hashref) { |
| |
foreach my $pair (@pairs) { |
| |
my ($key,$value)=split(/=/,$pair); |
| |
$hashref->{$key}=$value; |
| |
} |
| |
if (&untie_domain_hash($hashref)) { |
| |
&Reply($client, "ok\n", $userinput); |
| |
} else { |
| |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
| |
"while attempting domroleput\n", $userinput); |
| |
} |
| |
} else { |
| |
&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". |
| |
"while attempting domroleput\n", $userinput); |
| |
} |
| |
|
| |
return 1; |
| |
} |
| |
|
| |
®ister_handler("domroleput", \&put_domainroles_handler, 0, 1, 0); |
| |
|
| |
# |
| |
# Retrieves domain roles from nohist_domainroles database |
| |
# Returns to client an & separated list of key=value pairs, |
| |
# where key is role and value is start and end date information. |
| |
# |
| |
# Parameters |
| |
# $cmd - Command keyword that caused us to be dispatched. |
| |
# $tail - Tail of the command. Consists of a colon separated: |
| |
# domain - the domain whose domain roles table we dump |
| |
# $client - Socket open on the client. |
| |
# |
| |
# Returns: |
| |
# 1 - indicating processing should continue. |
| |
# Side effects |
| |
# reply (& separated list of role=start/end info pairs) is |
| |
# written to $client. |
| |
# |
| |
sub dump_domainroles_handler { |
| |
my ($cmd, $tail, $client) = @_; |
| |
|
| |
my $userinput = "$cmd:$tail"; |
| |
my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail); |
| |
chomp($rolesfilter); |
| |
my @roles = (); |
| |
if (defined($startfilter)) { |
| |
$startfilter=&unescape($startfilter); |
| |
} else { |
| |
$startfilter='.'; |
| |
} |
| |
if (defined($endfilter)) { |
| |
$endfilter=&unescape($endfilter); |
| |
} else { |
| |
$endfilter='.'; |
| |
} |
| |
if (defined($rolesfilter)) { |
| |
$rolesfilter=&unescape($rolesfilter); |
| |
@roles = split(/\&/,$rolesfilter); |
| |
} |
| |
|
| |
my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT()); |
| |
if ($hashref) { |
| |
my $qresult = ''; |
| |
while (my ($key,$value) = each(%$hashref)) { |
| |
my $match = 1; |
| |
my ($start,$end) = split(/:/,&unescape($value)); |
| |
my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key)); |
| |
unless ($startfilter eq '.' || !defined($startfilter)) { |
| |
if ($start >= $startfilter) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
unless ($endfilter eq '.' || !defined($endfilter)) { |
| |
if ($end <= $endfilter) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
unless (@roles < 1) { |
| |
unless (grep/^$trole$/,@roles) { |
| |
$match = 0; |
| |
} |
| |
} |
| |
if ($match == 1) { |
| |
$qresult.=$key.'='.$value.'&'; |
| |
} |
| |
} |
| |
if (&untie_domain_hash($hashref)) { |
| |
chop($qresult); |
| |
&Reply($client, "$qresult\n", $userinput); |
| |
} else { |
| |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
| |
"while attempting domrolesdump\n", $userinput); |
| |
} |
| |
} else { |
| |
&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ". |
| |
"while attempting domrolesdump\n", $userinput); |
| |
} |
| |
return 1; |
| |
} |
| |
|
| |
®ister_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0); |
| |
|
| |
|
| # Process the tmpput command I'm not sure what this does.. Seems to |
# Process the tmpput command I'm not sure what this does.. Seems to |
| # create a file in the lonDaemons/tmp directory of the form $id.tmp |
# create a file in the lonDaemons/tmp directory of the form $id.tmp |
| # where Id is the client's ip concatenated with a sequence number. |
# where Id is the client's ip concatenated with a sequence number. |
|
Line 3977 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; |
| |
eval { |
| |
local($SIG{__DIE__})='DEFAULT'; |
| |
$outcome = &localenroll::photo_permission($cdom,\$perm_reqd, |
| |
\$conditions); |
| |
}; |
| |
if (!$@) { |
| |
&Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n", |
| |
$userinput); |
| |
} else { |
| |
&Failure($client,"unknown_cmd\n",$userinput); |
| |
} |
| |
return 1; |
| |
} |
| |
®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); |
| |
return 1; |
| |
} |
| |
®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); |
| |
eval { |
| |
local($SIG{__DIE__})='DEFAULT'; |
| |
($update,$comment) = &localenroll::manager_photo_update($cdom); |
| |
}; |
| |
if (!$@) { |
| |
&Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput); |
| |
} else { |
| |
&Failure($client,"unknown_cmd\n",$userinput); |
| |
} |
| |
return 1; |
| |
} |
| |
®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 3989 sub get_institutional_code_format_handle
|
Line 4425 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') { |
| |
eval { |
| |
local($SIG{__DIE__})='DEFAULT'; |
| |
$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 4402 sub ReadHostTable {
|
Line 4850 sub ReadHostTable {
|
| open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; |
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; |
| my $myloncapaname = $perlvar{'lonHostID'}; |
my $myloncapaname = $perlvar{'lonHostID'}; |
| Debug("My loncapa name is : $myloncapaname"); |
Debug("My loncapa name is : $myloncapaname"); |
| |
my %name_to_ip; |
| while (my $configline=<CONFIG>) { |
while (my $configline=<CONFIG>) { |
| if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) { |
if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) { |
| my ($id,$domain,$role,$name)=split(/:/,$configline); |
my ($id,$domain,$role,$name)=split(/:/,$configline); |
| $name=~s/\s//g; |
$name=~s/\s//g; |
| my $ip = gethostbyname($name); |
my $ip; |
| if (length($ip) ne 4) { |
if (!exists($name_to_ip{$name})) { |
| &logthis("Skipping host $id name $name no IP $ip found\n"); |
$ip = gethostbyname($name); |
| next; |
if (!$ip || length($ip) ne 4) { |
| |
&logthis("Skipping host $id name $name no IP found\n"); |
| |
next; |
| |
} |
| |
$ip=inet_ntoa($ip); |
| |
$name_to_ip{$name} = $ip; |
| |
} else { |
| |
$ip = $name_to_ip{$name}; |
| } |
} |
| $ip=inet_ntoa($ip); |
|
| $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 4664 sub reconlonc {
|
Line 5120 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 4685 sub reply {
|
Line 5141 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 4712 sub sub_sql_reply {
|
Line 5168 sub sub_sql_reply {
|
| Type => SOCK_STREAM, |
Type => SOCK_STREAM, |
| Timeout => 10) |
Timeout => 10) |
| or return "con_lost"; |
or return "con_lost"; |
| print $sclient "$cmd\n"; |
print $sclient "$cmd:$currentdomainid\n"; |
| my $answer=<$sclient>; |
my $answer=<$sclient>; |
| chomp($answer); |
chomp($answer); |
| if (!$answer) { $answer="con_lost"; } |
if (!$answer) { $answer="con_lost"; } |
|
Line 4855 sub make_new_child {
|
Line 5311 sub make_new_child {
|
| # my $tmpsnum=0; # Now global |
# my $tmpsnum=0; # Now global |
| #---------------------------------------------------- kerberos 5 initialization |
#---------------------------------------------------- kerberos 5 initialization |
| &Authen::Krb5::init_context(); |
&Authen::Krb5::init_context(); |
| if ($dist ne 'fedora4') { |
unless (($dist eq 'fedora4') || ($dist eq 'suse9.3')) { |
| &Authen::Krb5::init_ets(); |
&Authen::Krb5::init_ets(); |
| } |
} |
| |
|
|
Line 4991 sub make_new_child {
|
Line 5447 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 5067 sub is_author {
|
Line 5523 sub is_author {
|
| # user - Name of the user for which the role is being put. |
# user - Name of the user for which the role is being put. |
| # authtype - The authentication type associated with the user. |
# authtype - The authentication type associated with the user. |
| # |
# |
| sub manage_permissions |
sub manage_permissions { |
| { |
|
| |
|
| |
|
| my ($request, $domain, $user, $authtype) = @_; |
my ($request, $domain, $user, $authtype) = @_; |
| |
|
| &Debug("manage_permissions: $request $domain $user $authtype"); |
&Debug("manage_permissions: $request $domain $user $authtype"); |
| |
|
| # See if the request is of the form /$domain/_au |
# See if the request is of the form /$domain/_au |
| if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... |
if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput... |
| my $execdir = $perlvar{'lonDaemons'}; |
my $execdir = $perlvar{'lonDaemons'}; |
| my $userhome= "/home/$user" ; |
my $userhome= "/home/$user" ; |
| &logthis("system $execdir/lchtmldir $userhome $user $authtype"); |
&logthis("system $execdir/lchtmldir $userhome $user $authtype"); |
|
Line 5325 sub addline {
|
Line 5778 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 5366 sub chat_add {
|
Line 5819 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); |
| } |
} |
| } |
} |
| |
|
|
Line 5469 sub thisversion {
|
Line 5923 sub thisversion {
|
| sub subscribe { |
sub subscribe { |
| my ($userinput,$clientip)=@_; |
my ($userinput,$clientip)=@_; |
| my $result; |
my $result; |
| my ($cmd,$fname)=split(/:/,$userinput); |
my ($cmd,$fname)=split(/:/,$userinput,2); |
| my $ownership=&ishome($fname); |
my $ownership=&ishome($fname); |
| if ($ownership eq 'owner') { |
if ($ownership eq 'owner') { |
| # explitly asking for the current version? |
# explitly asking for the current version? |
![[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