version 1.305.2.2, 2006/02/02 10:32:31
|
version 1.311, 2006/01/31 15:37:41
|
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 89 my $ConnectionType;
|
Line 87 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 972 sub tie_domain_hash {
|
Line 971 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"; |
my $resource_file = $domain_dir."/$namespace.db"; |
return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail); |
my %hash; |
|
if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) { |
|
if (defined($loghead)) { # Need to log the operation. |
|
my $logFh = IO::File->new(">>$domain_dir/$namespace.hist"); |
|
if($logFh) { |
|
my $timestamp = time; |
|
print $logFh "$loghead:$timestamp:$logtail\n"; |
|
} |
|
$logFh->close; |
|
} |
|
return \%hash; # Return the tied hash. |
|
} else { |
|
return undef; # Tie failed. |
|
} |
} |
} |
|
|
sub untie_domain_hash { |
sub untie_domain_hash { |
return &_locking_hash_untie(@_); |
my ($hashref) = @_; |
|
untie(%$hashref); |
} |
} |
# |
# |
# Ties a user's resource file to a hash. |
# Ties a user's resource file to a hash. |
Line 1004 sub tie_user_hash {
|
Line 1017 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); |
|
|
my $file_prefix="$proname/$namespace"; |
# Tie the database. |
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', "$file_prefix.db", $how, 0640)) { |
if(tie(%hash, 'GDBM_File', "$proname/$namespace.db", |
|
$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: $file_prefix $args"); |
Debug(" Opening history: $namespace $args"); |
my $hfh = IO::File->new(">>$file_prefix.hist"); |
my $hfh = IO::File->new(">>$proname/$namespace.hist"); |
if($hfh) { |
if($hfh) { |
my $now = time; |
my $now = time; |
print $hfh "$loghead:$now:$what\n"; |
print $hfh "$loghead:$now:$what\n"; |
Line 1035 sub _do_hash_tie {
|
Line 1039 sub _do_hash_tie {
|
} else { |
} else { |
return undef; |
return undef; |
} |
} |
|
|
} |
} |
|
|
sub _do_hash_untie { |
sub untie_user_hash { |
my ($hashref) = @_; |
my ($hashref) = @_; |
my $result = untie(%$hashref); |
my $result = untie(%$hashref); |
return $result; |
return $result; |
} |
} |
|
|
{ |
|
my $sym; |
|
|
|
sub _locking_hash_tie { |
|
my ($file_prefix,$namespace,$how,$loghead,$what) = @_; |
|
|
|
my ($lock); |
|
|
|
if ($how eq &GDBM_READER()) { |
|
$lock=LOCK_SH; |
|
$how=$how|&GDBM_NOLOCK(); |
|
#if the db doesn't exist we can't read from it |
|
if (! -e "$file_prefix.db") { |
|
$! = 2; |
|
return undef; |
|
} |
|
} elsif ($how eq &GDBM_WRCREAT()) { |
|
$lock=LOCK_EX; |
|
$how=$how|&GDBM_NOLOCK(); |
|
if (! -e "$file_prefix.db") { |
|
# doesn't exist but we need it to in order to successfully |
|
# lock it so bring it into existance |
|
open(TOUCH,">>$file_prefix.db"); |
|
close(TOUCH); |
|
} |
|
} else { |
|
&logthis("Unknown method $how for $file_prefix"); |
|
die(); |
|
} |
|
|
|
$sym=&Symbol::gensym(); |
|
open($sym,"$file_prefix.db"); |
|
my $failed=0; |
|
eval { |
|
local $SIG{__DIE__}='DEFAULT'; |
|
local $SIG{ALRM}=sub { |
|
$failed=1; |
|
die("failed lock"); |
|
}; |
|
alarm($lond_max_wait_time); |
|
flock($sym,$lock); |
|
alarm(0); |
|
}; |
|
if ($failed) { |
|
$! = 100; # throwing error # 100 |
|
return undef; |
|
} |
|
return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what); |
|
} |
|
|
|
sub _locking_hash_untie { |
|
my ($hashref) = @_; |
|
my $result = untie(%$hashref); |
|
flock($sym,LOCK_UN); |
|
close($sym); |
|
undef($sym); |
|
return $result; |
|
} |
|
} |
|
|
|
# read_profile |
# read_profile |
# |
# |
# Returns a set of specific entries from a user's profile file. |
# Returns a set of specific entries from a user's profile file. |
Line 2450 sub put_user_profile_entry {
|
Line 2394 sub put_user_profile_entry {
|
$userinput); |
$userinput); |
} |
} |
} else { |
} else { |
&Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ". |
&Failure( $client, "error: ".($!)." tie(GDBM) Failed ". |
"while attempting put\n", $userinput); |
"while attempting put\n", $userinput); |
} |
} |
} else { |
} else { |
Line 2486 sub newput_user_profile_entry {
|
Line 2430 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: ".($!+0)." tie(GDBM) Failed ". |
&Failure( $client, "error: ".($!)." tie(GDBM) Failed ". |
"while attempting put\n", $userinput); |
"while attempting put\n", $userinput); |
return 1; |
return 1; |
} |
} |
Line 2676 sub roles_delete_handler {
|
Line 2620 sub roles_delete_handler {
|
foreach my $key (@rolekeys) { |
foreach my $key (@rolekeys) { |
delete $hashref->{$key}; |
delete $hashref->{$key}; |
} |
} |
if (&untie_user_hash($hashref)) { |
if (&untie_user_hash(%$hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 2817 sub delete_profile_entry {
|
Line 2761 sub delete_profile_entry {
|
foreach my $key (@keys) { |
foreach my $key (@keys) { |
delete($hashref->{$key}); |
delete($hashref->{$key}); |
} |
} |
if (&untie_user_hash($hashref)) { |
if (&untie_user_hash(%$hashref)) { |
&Reply($client, "ok\n", $userinput); |
&Reply($client, "ok\n", $userinput); |
} else { |
} else { |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
&Failure($client, "error: ".($!+0)." untie(GDBM) Failed ". |
Line 2859 sub get_profile_keys {
|
Line 2803 sub get_profile_keys {
|
foreach my $key (keys %$hashref) { |
foreach my $key (keys %$hashref) { |
$qresult.="$key&"; |
$qresult.="$key&"; |
} |
} |
if (&untie_user_hash($hashref)) { |
if (&untie_user_hash(%$hashref)) { |
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
&Reply($client, "$qresult\n", $userinput); |
&Reply($client, "$qresult\n", $userinput); |
} else { |
} else { |
Line 2975 sub dump_with_regexp {
|
Line 2919 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&"; |
} |
} |
} |
} |
Line 4762 sub ReadHostTable {
|
Line 4723 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 5012 sub reconlonc {
|
Line 4974 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 5033 sub reply {
|
Line 4995 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 5339 sub make_new_child {
|
Line 5301 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); |