version 1.13, 2000/06/29 20:43:03
|
version 1.21, 2000/09/25 20:22:58
|
Line 7
|
Line 7
|
# 12/7,12/15,01/06,01/11,01/12,01/14,2/8, |
# 12/7,12/15,01/06,01/11,01/12,01/14,2/8, |
# 03/07,05/31 Gerd Kortemeyer |
# 03/07,05/31 Gerd Kortemeyer |
# 06/26 Scott Harrison |
# 06/26 Scott Harrison |
# 06/29 Gerd Kortemeyer |
# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer |
# |
# |
# based on "Perl Cookbook" ISBN 1-56592-243-3 |
# based on "Perl Cookbook" ISBN 1-56592-243-3 |
# preforker - server who forks first |
# preforker - server who forks first |
Line 38 while ($configline=<CONFIG>) {
|
Line 38 while ($configline=<CONFIG>) {
|
} |
} |
close(CONFIG); |
close(CONFIG); |
|
|
|
# --------------------------------------------- Check if other instance running |
|
|
|
my $pidfile="$perlvar{'lonDaemons'}/logs/lond.pid"; |
|
|
|
if (-e $pidfile) { |
|
my $lfh=IO::File->new("$pidfile"); |
|
my $pide=<$lfh>; |
|
chomp($pide); |
|
if (kill 0 => $pide) { die "already running"; } |
|
} |
|
|
$PREFORK=4; # number of children to maintain, at least four spare |
$PREFORK=4; # number of children to maintain, at least four spare |
|
|
# ------------------------------------------------------------- Read hosts file |
# ------------------------------------------------------------- Read hosts file |
Line 217 sub propath {
|
Line 228 sub propath {
|
my ($udom,$uname)=@_; |
my ($udom,$uname)=@_; |
$udom=~s/\W//g; |
$udom=~s/\W//g; |
$uname=~s/\W//g; |
$uname=~s/\W//g; |
my $subdir=$uname; |
my $subdir=$uname.'__'; |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; |
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; |
return $proname; |
return $proname; |
Line 333 sub make_new_child {
|
Line 344 sub make_new_child {
|
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=blue>WARNING: $clientip did not reply challenge</font>"); |
"<font color=blue>WARNING: $clientip did not reply challenge</font>"); |
|
print $client "bye\n"; |
} |
} |
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=blue>WARNING: " |
"<font color=blue>WARNING: " |
."$clientip failed to initialize: >$remotereq< </font>"); |
."$clientip failed to initialize: >$remotereq< </font>"); |
|
print $client "bye\n"; |
} |
} |
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=blue>WARNING: Unknown client $clientip</font>"); |
"<font color=blue>WARNING: Unknown client $clientip</font>"); |
|
print $client "bye\n"; |
} |
} |
if ($clientok) { |
if ($clientok) { |
# ---------------- New known client connecting, could mean machine online again |
# ---------------- New known client connecting, could mean machine online again |
Line 513 sub make_new_child {
|
Line 527 sub make_new_child {
|
&logthis( |
&logthis( |
"LWP GET: $message for $fname ($remoteurl)"); |
"LWP GET: $message for $fname ($remoteurl)"); |
} else { |
} else { |
|
if ($remoteurl!~/\.meta$/) { |
|
my $mrequest= |
|
new HTTP::Request('GET',$remoteurl.'.meta'); |
|
my $mresponse= |
|
$ua->request($mrequest,$fname.'.meta'); |
|
if ($mresponse->is_error()) { |
|
unlink($fname.'.meta'); |
|
} |
|
} |
rename($transname,$fname); |
rename($transname,$fname); |
} |
} |
} |
} |
Line 541 sub make_new_child {
|
Line 564 sub make_new_child {
|
my $ownership=ishome($fname); |
my $ownership=ishome($fname); |
if ($ownership eq 'owner') { |
if ($ownership eq 'owner') { |
if (-e $fname) { |
if (-e $fname) { |
|
if (-d $fname) { |
|
print $client "directory\n"; |
|
} else { |
$now=time; |
$now=time; |
{ |
{ |
my $sh=IO::File->new(">$fname.$hostid{$clientip}"); |
my $sh=IO::File->new(">$fname.$hostid{$clientip}"); |
Line 549 sub make_new_child {
|
Line 575 sub make_new_child {
|
$fname=~s/\/home\/httpd\/html\/res/raw/; |
$fname=~s/\/home\/httpd\/html\/res/raw/; |
$fname="http://$thisserver/".$fname; |
$fname="http://$thisserver/".$fname; |
print $client "$fname\n"; |
print $client "$fname\n"; |
|
} |
} else { |
} else { |
print $client "not_found\n"; |
print $client "not_found\n"; |
} |
} |
Line 647 sub make_new_child {
|
Line 674 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_WRCREAT,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 670 sub make_new_child {
|
Line 697 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_WRCREAT,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 732 sub make_new_child {
|
Line 759 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_WRCREAT,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 753 sub make_new_child {
|
Line 780 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_WRCREAT,0640)) { |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
foreach $key (keys %hash) { |
foreach $key (keys %hash) { |
$qresult.="$key=$hash{$key}&"; |
$qresult.="$key=$hash{$key}&"; |
} |
} |
Line 817 sub make_new_child {
|
Line 844 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_WRCREAT,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 827 sub make_new_child {
|
Line 854 sub make_new_child {
|
my $key; |
my $key; |
$qresult.="$scope:keys=$vkeys&"; |
$qresult.="$scope:keys=$vkeys&"; |
foreach $key (@keys) { |
foreach $key (@keys) { |
$qresult.="$version:$key=".$hash{"$scope:$rid:$key"}."&"; |
$qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&"; |
} |
} |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
Line 892 sub make_new_child {
|
Line 919 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_WRCREAT,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 952 sub make_new_child {
|
Line 979 sub make_new_child {
|
} else { |
} else { |
$ulsout='no_such_dir'; |
$ulsout='no_such_dir'; |
} |
} |
|
if ($ulsout eq '') { $ulsout='empty'; } |
print $client "$ulsout\n"; |
print $client "$ulsout\n"; |
# ------------------------------------------------------------- unknown command |
# ------------------------------------------------------------- unknown command |
} else { |
} else { |