version 1.115, 2003/03/18 22:51:03
|
version 1.121, 2003/03/27 23:00:28
|
Line 73 my $DEBUG = 0; # Non zero to ena
|
Line 73 my $DEBUG = 0; # Non zero to ena
|
my $status=''; |
my $status=''; |
my $lastlog=''; |
my $lastlog=''; |
|
|
|
my $VERSION='$Revision$'; #' stupid emacs |
|
my $remoteVERSION; |
my $currenthostid; |
my $currenthostid; |
my $currentdomainid; |
my $currentdomainid; |
# |
# |
Line 199 while ($configline=<CONFIG>) {
|
Line 201 while ($configline=<CONFIG>) {
|
$hostid{$ip}=$id; |
$hostid{$ip}=$id; |
$hostdom{$id}=$domain; |
$hostdom{$id}=$domain; |
$hostip{$id}=$ip; |
$hostip{$id}=$ip; |
if ($id eq $perlvar{'lonHostId'}) { $thisserver=$name; } |
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } |
$PREFORK++; |
$PREFORK++; |
} |
} |
close(CONFIG); |
close(CONFIG); |
Line 515 while (1) {
|
Line 517 while (1) {
|
make_new_child($client); |
make_new_child($client); |
} |
} |
|
|
sub init_host_and_domain { |
|
my ($remotereq) = @_; |
|
my (undef,$hostid)=split(/:/,$remotereq); |
|
if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } |
|
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { |
|
$currenthostid=$hostid; |
|
$currentdomainid=$hostdom{$hostid}; |
|
&logthis("Setting hostid to $hostid, and domain to $currentdomainid"); |
|
} else { |
|
&logthis("Requested host id $hostid not an alias of ". |
|
$perlvar{'lonHostID'}." refusing connection"); |
|
return 0; |
|
} |
|
return 1; |
|
} |
|
|
|
sub make_new_child { |
sub make_new_child { |
my $client; |
my $client; |
my $pid; |
my $pid; |
Line 592 sub make_new_child {
|
Line 578 sub make_new_child {
|
my $remotereq=<$client>; |
my $remotereq=<$client>; |
$remotereq=~s/[^\w:]//g; |
$remotereq=~s/[^\w:]//g; |
if ($remotereq =~ /^init/) { |
if ($remotereq =~ /^init/) { |
if (!&init_host_and_domain($remotereq)) { |
&sethost("sethost:$perlvar{'lonHostID'}"); |
&status("Got bad init message, exiting"); |
|
print $client "refused\n"; |
|
$client->close(); |
|
&logthis("<font color=blue>WARNING: " |
|
."Bad init message $remotereq, closing connection</font>"); |
|
exit; |
|
} |
|
my $challenge="$$".time; |
my $challenge="$$".time; |
print $client "$challenge\n"; |
print $client "$challenge\n"; |
&status( |
&status( |
Line 1091 sub make_new_child {
|
Line 1070 sub make_new_child {
|
) { print $hfh "P:$now:$what\n"; } |
) { print $hfh "P:$now:$what\n"; } |
} |
} |
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
foreach $pair (@pairs) { |
foreach $pair (@pairs) { |
($key,$value)=split(/=/,$pair); |
($key,$value)=split(/=/,$pair); |
$hash{$key}=$value; |
$hash{$key}=$value; |
Line 1133 sub make_new_child {
|
Line 1112 sub make_new_child {
|
} |
} |
} |
} |
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
foreach $pair (@pairs) { |
foreach $pair (@pairs) { |
($key,$value)=split(/=/,$pair); |
($key,$value)=split(/=/,$pair); |
&ManagePermissions($key, $udom, $uname, |
&ManagePermissions($key, $udom, $uname, |
Line 1157 sub make_new_child {
|
Line 1136 sub make_new_child {
|
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
} |
} |
|
# -------------------------------------------------------------------- rolesdel |
|
} elsif ($userinput =~ /^rolesdel/) { |
|
&Debug("rolesdel"); |
|
if ($wasenc==1) { |
|
my ($cmd,$exedom,$exeuser,$udom,$uname,$what) |
|
=split(/:/,$userinput); |
|
&Debug("cmd = ".$cmd." exedom= ".$exedom. |
|
"user = ".$exeuser." udom=".$udom. |
|
"what = ".$what); |
|
my $namespace='roles'; |
|
chomp($what); |
|
my $proname=propath($udom,$uname); |
|
my $now=time; |
|
{ |
|
my $hfh; |
|
if ( |
|
$hfh=IO::File->new(">>$proname/$namespace.hist") |
|
) { |
|
print $hfh "D:$now:$exedom:$exeuser:$what\n"; |
|
} |
|
} |
|
my @rolekeys=split(/\&/,$what); |
|
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
|
foreach $key (@rolekeys) { |
|
delete $hash{$key}; |
|
|
|
} |
|
if (untie(%hash)) { |
|
print $client "ok\n"; |
|
} else { |
|
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting rolesdel\n"; |
|
} |
|
} else { |
|
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting rolesdel\n"; |
|
} |
|
} else { |
|
print $client "refused\n"; |
|
} |
# ------------------------------------------------------------------------- get |
# ------------------------------------------------------------------------- get |
} elsif ($userinput =~ /^get/) { |
} elsif ($userinput =~ /^get/) { |
my ($cmd,$udom,$uname,$namespace,$what) |
my ($cmd,$udom,$uname,$namespace,$what) |
Line 1167 sub make_new_child {
|
Line 1188 sub make_new_child {
|
my @queries=split(/\&/,$what); |
my @queries=split(/\&/,$what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $qresult=''; |
my $qresult=''; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
for ($i=0;$i<=$#queries;$i++) { |
for ($i=0;$i<=$#queries;$i++) { |
$qresult.="$hash{$queries[$i]}&"; |
$qresult.="$hash{$queries[$i]}&"; |
} |
} |
Line 1199 sub make_new_child {
|
Line 1220 sub make_new_child {
|
my @queries=split(/\&/,$what); |
my @queries=split(/\&/,$what); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $qresult=''; |
my $qresult=''; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
for ($i=0;$i<=$#queries;$i++) { |
for ($i=0;$i<=$#queries;$i++) { |
$qresult.="$hash{$queries[$i]}&"; |
$qresult.="$hash{$queries[$i]}&"; |
} |
} |
Line 1245 sub make_new_child {
|
Line 1266 sub make_new_child {
|
) { print $hfh "D:$now:$what\n"; } |
) { print $hfh "D:$now:$what\n"; } |
} |
} |
my @keys=split(/\&/,$what); |
my @keys=split(/\&/,$what); |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
foreach $key (@keys) { |
foreach $key (@keys) { |
delete($hash{$key}); |
delete($hash{$key}); |
} |
} |
Line 1269 sub make_new_child {
|
Line 1290 sub make_new_child {
|
$namespace=~s/\W//g; |
$namespace=~s/\W//g; |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $qresult=''; |
my $qresult=''; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
foreach $key (keys %hash) { |
foreach $key (keys %hash) { |
$qresult.="$key&"; |
$qresult.="$key&"; |
} |
} |
Line 1387 sub make_new_child {
|
Line 1408 sub make_new_child {
|
} |
} |
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
|
|
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { |
my @previouskeys=split(/&/,$hash{"keys:$rid"}); |
my @previouskeys=split(/&/,$hash{"keys:$rid"}); |
my $key; |
my $key; |
$hash{"version:$rid"}++; |
$hash{"version:$rid"}++; |
Line 1425 sub make_new_child {
|
Line 1446 sub make_new_child {
|
chomp($rid); |
chomp($rid); |
my $proname=propath($udom,$uname); |
my $proname=propath($udom,$uname); |
my $qresult=''; |
my $qresult=''; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
my $version=$hash{"version:$rid"}; |
my $version=$hash{"version:$rid"}; |
$qresult.="version=$version&"; |
$qresult.="version=$version&"; |
my $scope; |
my $scope; |
Line 1492 sub make_new_child {
|
Line 1513 sub make_new_child {
|
." IO::File->new Failed ". |
." IO::File->new Failed ". |
"while attempting queryreply\n"; |
"while attempting queryreply\n"; |
} |
} |
|
# ----------------------------------------------------------------- courseidput |
|
} elsif ($userinput =~ /^courseidput/) { |
|
my ($cmd,$udom,$what)=split(/:/,$userinput); |
|
chomp($what); |
|
$udom=~s/\W//g; |
|
my $proname= |
|
"$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; |
|
my $now=time; |
|
my @pairs=split(/\&/,$what); |
|
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { |
|
foreach $pair (@pairs) { |
|
($key,$value)=split(/=/,$pair); |
|
$hash{$key}=$value.':'.$now; |
|
} |
|
if (untie(%hash)) { |
|
print $client "ok\n"; |
|
} else { |
|
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting courseidput\n"; |
|
} |
|
} else { |
|
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting courseidput\n"; |
|
} |
|
# ---------------------------------------------------------------- courseiddump |
|
} elsif ($userinput =~ /^courseiddump/) { |
|
my ($cmd,$udom,$since,$description) |
|
=split(/:/,$userinput); |
|
if (defined($description)) { |
|
$description=&unescape($description); |
|
} else { |
|
$description='.'; |
|
} |
|
unless (defined($since)) { $since=0; } |
|
my $qresult=''; |
|
my $proname= |
|
"$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; |
|
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { |
|
while (($key,$value) = each(%hash)) { |
|
my ($descr,$lasttime)=split(/\:/,$value); |
|
if ($lasttime<$since) { next; } |
|
if ($regexp eq '.') { |
|
$qresult.=$key.'='.$descr.'&'; |
|
} else { |
|
my $unescapeVal = &unescape($descr); |
|
if (eval('$unescapeVal=~/$description/i')) { |
|
$qresult.="$key=$descr&"; |
|
} |
|
} |
|
} |
|
if (untie(%hash)) { |
|
chop($qresult); |
|
print $client "$qresult\n"; |
|
} else { |
|
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting courseiddump\n"; |
|
} |
|
} else { |
|
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting courseiddump\n"; |
|
} |
# ----------------------------------------------------------------------- idput |
# ----------------------------------------------------------------------- idput |
} elsif ($userinput =~ /^idput/) { |
} elsif ($userinput =~ /^idput/) { |
my ($cmd,$udom,$what)=split(/:/,$userinput); |
my ($cmd,$udom,$what)=split(/:/,$userinput); |
Line 1506 sub make_new_child {
|
Line 1592 sub make_new_child {
|
) { print $hfh "P:$now:$what\n"; } |
) { print $hfh "P:$now:$what\n"; } |
} |
} |
my @pairs=split(/\&/,$what); |
my @pairs=split(/\&/,$what); |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { |
foreach $pair (@pairs) { |
foreach $pair (@pairs) { |
($key,$value)=split(/=/,$pair); |
($key,$value)=split(/=/,$pair); |
$hash{$key}=$value; |
$hash{$key}=$value; |
Line 1531 sub make_new_child {
|
Line 1617 sub make_new_child {
|
my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; |
my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; |
my @queries=split(/\&/,$what); |
my @queries=split(/\&/,$what); |
my $qresult=''; |
my $qresult=''; |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) { |
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { |
for ($i=0;$i<=$#queries;$i++) { |
for ($i=0;$i<=$#queries;$i++) { |
$qresult.="$hash{$queries[$i]}&"; |
$qresult.="$hash{$queries[$i]}&"; |
} |
} |
Line 1632 sub make_new_child {
|
Line 1718 sub make_new_child {
|
$client->close(); |
$client->close(); |
last; |
last; |
# ------------------------------------------------------------- unknown command |
# ------------------------------------------------------------- unknown command |
|
} elsif ($userinput =~ /^sethost:/) { |
|
print $client &sethost($userinput)."\n"; |
|
} elsif ($userinput =~/^version:/) { |
|
print $client &version($userinput)."\n"; |
} else { |
} else { |
# unknown command |
# unknown command |
print $client "unknown_cmd\n"; |
print $client "unknown_cmd\n"; |
Line 1947 sub make_passwd_file {
|
Line 2037 sub make_passwd_file {
|
return $result; |
return $result; |
} |
} |
|
|
|
sub sethost { |
|
my ($remotereq) = @_; |
|
my (undef,$hostid)=split(/:/,$remotereq); |
|
if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } |
|
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { |
|
$currenthostid=$hostid; |
|
$currentdomainid=$hostdom{$hostid}; |
|
&logthis("Setting hostid to $hostid, and domain to $currentdomainid"); |
|
} else { |
|
&logthis("Requested host id $hostid not an alias of ". |
|
$perlvar{'lonHostID'}." refusing connection"); |
|
return 'unable_to_set'; |
|
} |
|
return 'ok'; |
|
} |
|
|
|
sub version { |
|
my ($userinput)=@_; |
|
$remoteVERSION=(split(/:/,$userinput))[1]; |
|
return "version:$VERSION"; |
|
} |
|
|
# ----------------------------------- POD (plain old documentation, CPAN style) |
# ----------------------------------- POD (plain old documentation, CPAN style) |
|
|
=head1 NAME |
=head1 NAME |