version 1.98, 2002/09/19 21:16:24
|
version 1.113, 2003/03/13 21:01:52
|
Line 31
|
Line 31
|
# 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16, |
# 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16, |
# 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/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer |
# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer |
# 12/05 Scott Harrison |
|
# 12/05,12/13,12/29 Gerd Kortemeyer |
# 12/05,12/13,12/29 Gerd Kortemeyer |
# YEAR=2001 |
# YEAR=2001 |
# Jan 01 Scott Harrison |
|
# 02/12 Gerd Kortemeyer |
# 02/12 Gerd Kortemeyer |
# 03/15 Scott Harrison |
|
# 03/24 Gerd Kortemeyer |
# 03/24 Gerd Kortemeyer |
# 04/02 Scott Harrison |
|
# 05/11,05/28,08/30 Gerd Kortemeyer |
# 05/11,05/28,08/30 Gerd Kortemeyer |
# 9/30,10/22,11/13,11/15,11/16 Scott Harrison |
|
# 11/26,11/27 Gerd Kortemeyer |
# 11/26,11/27 Gerd Kortemeyer |
# 12/20 Scott Harrison |
|
# 12/22 Gerd Kortemeyer |
# 12/22 Gerd Kortemeyer |
# YEAR=2002 |
# YEAR=2002 |
# 01/20/02,02/05 Gerd Kortemeyer |
# 01/20/02,02/05 Gerd Kortemeyer |
# 02/05 Guy Albertelli |
# 02/05 Guy Albertelli |
# 02/07 Scott Harrison |
|
# 02/12 Gerd Kortemeyer |
# 02/12 Gerd Kortemeyer |
# 02/19 Matthew Hall |
# 02/19 Matthew Hall |
# 02/25 Gerd Kortemeyer |
# 02/25 Gerd Kortemeyer |
# 05/11 Scott Harrison |
# 01/xx/2003 Ron Fox.. Remove preforking. This makes the general daemon |
|
# logic simpler (and there were problems maintaining the preforked |
|
# population). Since the time averaged connection rate is close to zero |
|
# because lonc's purpose is to maintain near continuous connnections, |
|
# preforking is not really needed. |
### |
### |
|
|
# based on "Perl Cookbook" ISBN 1-56592-243-3 |
|
# preforker - server who forks first |
|
# runs as a daemon |
|
# HUPs |
|
# uses IDEA encryption |
|
|
|
use lib '/home/httpd/lib/perl/'; |
use lib '/home/httpd/lib/perl/'; |
use LONCAPA::Configuration; |
use LONCAPA::Configuration; |
Line 272 sub checkchildren {
|
Line 263 sub checkchildren {
|
} |
} |
} |
} |
sleep 5; |
sleep 5; |
|
$SIG{ALRM} = sub { die "timeout" }; |
|
$SIG{__DIE__} = 'DEFAULT'; |
foreach (sort keys %children) { |
foreach (sort keys %children) { |
unless (-e "$docdir/lon-status/londchld/$_.txt") { |
unless (-e "$docdir/lon-status/londchld/$_.txt") { |
|
eval { |
|
alarm(300); |
&logthis('Child '.$_.' did not respond'); |
&logthis('Child '.$_.' did not respond'); |
kill 9 => $_; |
kill 9 => $_; |
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; |
$subj="LON: $perlvar{'lonHostID'} killed lond process $_"; |
$subj="LON: $perlvar{'lonHostID'} killed lond process $_"; |
my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; |
my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; |
$execdir=$perlvar{'lonDaemons'}; |
$execdir=$perlvar{'lonDaemons'}; |
$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_` |
$result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_`; |
|
alarm(0); |
|
} |
} |
} |
} |
} |
|
$SIG{ALRM} = 'DEFAULT'; |
|
$SIG{__DIE__} = \&cathcexception; |
} |
} |
|
|
# --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
Line 340 sub status {
|
Line 339 sub status {
|
my $now=time; |
my $now=time; |
my $local=localtime($now); |
my $local=localtime($now); |
$status=$local.': '.$what; |
$status=$local.': '.$what; |
|
$0='lond: '.$what.' '.$local; |
} |
} |
|
|
# -------------------------------------------------------- Escape Special Chars |
# -------------------------------------------------------- Escape Special Chars |
Line 490 close(PIDSAVE);
|
Line 490 close(PIDSAVE);
|
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>"); |
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>"); |
&status('Starting'); |
&status('Starting'); |
|
|
# ------------------------------------------------------- Now we are on our own |
|
|
|
# Fork off our children. |
|
for (1 .. $PREFORK) { |
|
make_new_child(); |
|
} |
|
|
|
# ----------------------------------------------------- Install signal handlers |
# ----------------------------------------------------- Install signal handlers |
|
|
&status('Forked children'); |
|
|
|
$SIG{CHLD} = \&REAPER; |
$SIG{CHLD} = \&REAPER; |
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN; |
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN; |
$SIG{HUP} = \&HUPSMAN; |
$SIG{HUP} = \&HUPSMAN; |
$SIG{USR1} = \&checkchildren; |
$SIG{USR1} = \&checkchildren; |
|
|
# And maintain the population. |
|
|
|
|
# -------------------------------------------------------------- |
|
# Accept connections. When a connection comes in, it is validated |
|
# and if good, a child process is created to process transactions |
|
# along the connection. |
|
|
while (1) { |
while (1) { |
&status('Sleeping'); |
$client = $server->accept() or next; |
sleep; # wait for a signal (i.e., child's death) |
make_new_child($client); |
&logthis('Woke up'); |
|
&status('Woke up'); |
|
for ($i = $children; $i < $PREFORK; $i++) { |
|
make_new_child(); # top up the child pool |
|
} |
|
} |
} |
|
|
sub make_new_child { |
sub make_new_child { |
|
my $client; |
my $pid; |
my $pid; |
my $cipher; |
my $cipher; |
my $sigset; |
my $sigset; |
|
|
|
$client = shift; |
&logthis("Attempting to start child"); |
&logthis("Attempting to start child"); |
# block signal for fork |
# block signal for fork |
$sigset = POSIX::SigSet->new(SIGINT); |
$sigset = POSIX::SigSet->new(SIGINT); |
Line 554 sub make_new_child {
|
Line 552 sub make_new_child {
|
&Authen::Krb5::init_context(); |
&Authen::Krb5::init_context(); |
&Authen::Krb5::init_ets(); |
&Authen::Krb5::init_ets(); |
|
|
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD |
|
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { |
|
&status('Idle, waiting for connection'); |
|
$client = $server->accept() or last; |
|
&status('Accepted connection'); |
&status('Accepted connection'); |
# ============================================================================= |
# ============================================================================= |
# do something with the connection |
# do something with the connection |
Line 565 sub make_new_child {
|
Line 559 sub make_new_child {
|
$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of |
$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of |
# connection liveness. |
# connection liveness. |
# see if we know client and check for spoof IP by challenge |
# see if we know client and check for spoof IP by challenge |
my $caller=getpeername($client); |
my $caller = getpeername($client); |
my ($port,$iaddr)=unpack_sockaddr_in($caller); |
my ($port,$iaddr)=unpack_sockaddr_in($caller); |
my $clientip=inet_ntoa($iaddr); |
my $clientip=inet_ntoa($iaddr); |
my $clientrec=($hostid{$clientip} ne undef); |
my $clientrec=($hostid{$clientip} ne undef); |
Line 695 sub make_new_child {
|
Line 689 sub make_new_child {
|
my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
my ($howpwd,$contentpwd)=split(/:/,$realpasswd); |
my $pwdcorrect=0; |
my $pwdcorrect=0; |
if ($howpwd eq 'internal') { |
if ($howpwd eq 'internal') { |
|
&Debug("Internal auth"); |
$pwdcorrect= |
$pwdcorrect= |
(crypt($upass,$contentpwd) eq $contentpwd); |
(crypt($upass,$contentpwd) eq $contentpwd); |
} elsif ($howpwd eq 'unix') { |
} elsif ($howpwd eq 'unix') { |
$contentpwd=(getpwnam($uname))[1]; |
&Debug("Unix auth"); |
my $pwauth_path="/usr/local/sbin/pwauth"; |
if((getpwnam($uname))[1] eq "") { #no such user! |
unless ($contentpwd eq 'x') { |
$pwdcorrect = 0; |
$pwdcorrect= |
} else { |
(crypt($upass,$contentpwd) eq $contentpwd); |
$contentpwd=(getpwnam($uname))[1]; |
} |
my $pwauth_path="/usr/local/sbin/pwauth"; |
|
unless ($contentpwd eq 'x') { |
|
$pwdcorrect= |
|
(crypt($upass,$contentpwd) eq |
|
$contentpwd); |
|
} |
|
|
elsif (-e $pwauth_path) { |
elsif (-e $pwauth_path) { |
open PWAUTH, "|$pwauth_path" or |
open PWAUTH, "|$pwauth_path" or |
die "Cannot invoke authentication"; |
die "Cannot invoke authentication"; |
Line 711 sub make_new_child {
|
Line 712 sub make_new_child {
|
close PWAUTH; |
close PWAUTH; |
$pwdcorrect=!$?; |
$pwdcorrect=!$?; |
} |
} |
|
} |
} elsif ($howpwd eq 'krb4') { |
} elsif ($howpwd eq 'krb4') { |
$null=pack("C",0); |
$null=pack("C",0); |
unless ($upass=~/$null/) { |
unless ($upass=~/$null/) { |
$pwdcorrect=( |
my $krb4_error = &Authen::Krb4::get_pw_in_tkt |
Authen::Krb4::get_pw_in_tkt($uname,"", |
($uname,"",$contentpwd,'krbtgt', |
$contentpwd,'krbtgt',$contentpwd,1, |
$contentpwd,1,$upass); |
$upass) == 0); |
if (!$krb4_error) { |
} else { $pwdcorrect=0; } |
$pwdcorrect = 1; |
|
} else { |
|
$pwdcorrect=0; |
|
# log error if it is not a bad password |
|
if ($krb4_error != 62) { |
|
&logthis('krb4:'.$uname.','.$contentpwd.','. |
|
&Authen::Krb4::get_err_txt($Authen::Krb4::error)); |
|
} |
|
} |
|
} |
} elsif ($howpwd eq 'krb5') { |
} elsif ($howpwd eq 'krb5') { |
$null=pack("C",0); |
$null=pack("C",0); |
unless ($upass=~/$null/) { |
unless ($upass=~/$null/) { |
Line 852 sub make_new_child {
|
Line 863 sub make_new_child {
|
$fpnow.='/'.$fpparts[$i]; |
$fpnow.='/'.$fpparts[$i]; |
unless (-e $fpnow) { |
unless (-e $fpnow) { |
unless (mkdir($fpnow,0777)) { |
unless (mkdir($fpnow,0777)) { |
$fperror="error:$!"; |
$fperror="error: ".($!+0) |
|
." mkdir failed while attempting " |
|
."makeuser\n"; |
} |
} |
} |
} |
} |
} |
Line 1007 sub make_new_child {
|
Line 1020 sub make_new_child {
|
# ------------------------------------------------------------------- subscribe |
# ------------------------------------------------------------------- subscribe |
} elsif ($userinput =~ /^sub/) { |
} elsif ($userinput =~ /^sub/) { |
print $client &subscribe($userinput,$clientip); |
print $client &subscribe($userinput,$clientip); |
|
# ------------------------------------------------------------- current version |
|
} elsif ($userinput =~ /^currentversion/) { |
|
my ($cmd,$fname)=split(/:/,$userinput); |
|
print $client ¤tversion($fname)."\n"; |
# ------------------------------------------------------------------------- log |
# ------------------------------------------------------------------------- log |
} elsif ($userinput =~ /^log/) { |
} elsif ($userinput =~ /^log/) { |
my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); |
my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); |
Line 1019 sub make_new_child {
|
Line 1036 sub make_new_child {
|
print $hfh "$now:$hostid{$clientip}:$what\n"; |
print $hfh "$now:$hostid{$clientip}:$what\n"; |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." IO::File->new Failed " |
|
."while attempting log\n"; |
} |
} |
} |
} |
# ------------------------------------------------------------------------- put |
# ------------------------------------------------------------------------- put |
Line 1047 sub make_new_child {
|
Line 1066 sub make_new_child {
|
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) failed ". |
|
"while attempting put\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!) |
|
." tie(GDBM) Failed ". |
|
"while attempting put\n"; |
} |
} |
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
Line 1089 sub make_new_child {
|
Line 1112 sub make_new_child {
|
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting rolesput\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting rolesput\n"; |
} |
} |
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
Line 1115 sub make_new_child {
|
Line 1142 sub make_new_child {
|
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting get\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
if ($!+0 == 2) { |
|
print $client "error:No such file or ". |
|
"GDBM reported bad block error\n"; |
|
} else { |
|
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting get\n"; |
|
} |
} |
} |
# ------------------------------------------------------------------------ eget |
# ------------------------------------------------------------------------ eget |
} elsif ($userinput =~ /^eget/) { |
} elsif ($userinput =~ /^eget/) { |
Line 1151 sub make_new_child {
|
Line 1187 sub make_new_child {
|
print $client "error:no_key\n"; |
print $client "error:no_key\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting eget\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting eget\n"; |
} |
} |
# ------------------------------------------------------------------------- del |
# ------------------------------------------------------------------------- del |
} elsif ($userinput =~ /^del/) { |
} elsif ($userinput =~ /^del/) { |
Line 1179 sub make_new_child {
|
Line 1219 sub make_new_child {
|
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting del\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting del\n"; |
} |
} |
# ------------------------------------------------------------------------ keys |
# ------------------------------------------------------------------------ keys |
} elsif ($userinput =~ /^keys/) { |
} elsif ($userinput =~ /^keys/) { |
Line 1200 sub make_new_child {
|
Line 1244 sub make_new_child {
|
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting keys\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting keys\n"; |
|
} |
|
# ----------------------------------------------------------------- dumpcurrent |
|
} elsif ($userinput =~ /^currentdump/) { |
|
my ($cmd,$udom,$uname,$namespace) |
|
=split(/:/,$userinput); |
|
$namespace=~s/\//\_/g; |
|
$namespace=~s/\W//g; |
|
my $qresult=''; |
|
my $proname=propath($udom,$uname); |
|
if (tie(%hash,'GDBM_File', |
|
"$proname/$namespace.db", |
|
&GDBM_READER(),0640)) { |
|
# Structure of %data: |
|
# $data{$symb}->{$parameter}=$value; |
|
# $data{$symb}->{'v.'.$parameter}=$version; |
|
# since $parameter will be unescaped, we do not |
|
# have to worry about silly parameter names... |
|
my %data = (); |
|
while (my ($key,$value) = each(%hash)) { |
|
my ($v,$symb,$param) = split(/:/,$key); |
|
next if ($v eq 'version' || $symb eq 'keys'); |
|
next if (exists($data{$symb}) && |
|
exists($data{$symb}->{$param}) && |
|
$data{$symb}->{'v.'.$param} > $v); |
|
$data{$symb}->{$param}=$value; |
|
$data{$symb}->{'v.'.$param}=$v; |
|
} |
|
if (untie(%hash)) { |
|
while (my ($symb,$param_hash) = each(%data)) { |
|
while(my ($param,$value) = each (%$param_hash)){ |
|
next if ($param =~ /^v\./); |
|
$qresult.=$symb.':'.$param.'='.$value.'&'; |
|
} |
|
} |
|
chop($qresult); |
|
print $client "$qresult\n"; |
|
} else { |
|
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting currentdump\n"; |
|
} |
|
} else { |
|
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting currentdump\n"; |
} |
} |
# ------------------------------------------------------------------------ dump |
# ------------------------------------------------------------------------ dump |
} elsif ($userinput =~ /^dump/) { |
} elsif ($userinput =~ /^dump/) { |
Line 1216 sub make_new_child {
|
Line 1309 sub make_new_child {
|
} else { |
} else { |
$regexp='.'; |
$regexp='.'; |
} |
} |
my $proname=propath($udom,$uname); |
|
my $qresult=''; |
my $qresult=''; |
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { |
my $proname=propath($udom,$uname); |
|
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { |
study($regexp); |
study($regexp); |
foreach $key (keys %hash) { |
while (($key,$value) = each(%hash)) { |
my $unescapeKey = &unescape($key); |
if ($regexp eq '.') { |
if (eval('$unescapeKey=~/$regexp/')) { |
$qresult.=$key.'='.$value.'&'; |
$qresult.="$key=$hash{$key}&"; |
} else { |
} |
my $unescapeKey = &unescape($key); |
|
if (eval('$unescapeKey=~/$regexp/')) { |
|
$qresult.="$key=$value&"; |
|
} |
|
} |
} |
} |
if (untie(%hash)) { |
if (untie(%hash)) { |
$qresult=~s/\&$//; |
chop($qresult); |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting dump\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting dump\n"; |
} |
} |
# ----------------------------------------------------------------------- store |
# ----------------------------------------------------------------------- store |
} elsif ($userinput =~ /^store/) { |
} elsif ($userinput =~ /^store/) { |
Line 1270 sub make_new_child {
|
Line 1371 sub make_new_child {
|
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting store\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting store\n"; |
} |
} |
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
Line 1304 sub make_new_child {
|
Line 1409 sub make_new_child {
|
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting restore\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting restore\n"; |
} |
} |
# -------------------------------------------------------------------- chatsend |
# -------------------------------------------------------------------- chatsend |
} elsif ($userinput =~ /^chatsend/) { |
} elsif ($userinput =~ /^chatsend/) { |
Line 1346 sub make_new_child {
|
Line 1455 sub make_new_child {
|
print $client "ok\n"; |
print $client "ok\n"; |
} |
} |
else { |
else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." IO::File->new Failed ". |
|
"while attempting queryreply\n"; |
} |
} |
# ----------------------------------------------------------------------- idput |
# ----------------------------------------------------------------------- idput |
} elsif ($userinput =~ /^idput/) { |
} elsif ($userinput =~ /^idput/) { |
Line 1370 sub make_new_child {
|
Line 1481 sub make_new_child {
|
if (untie(%hash)) { |
if (untie(%hash)) { |
print $client "ok\n"; |
print $client "ok\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting idput\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting idput\n"; |
} |
} |
# ----------------------------------------------------------------------- idget |
# ----------------------------------------------------------------------- idget |
} elsif ($userinput =~ /^idget/) { |
} elsif ($userinput =~ /^idget/) { |
Line 1391 sub make_new_child {
|
Line 1506 sub make_new_child {
|
$qresult=~s/\&$//; |
$qresult=~s/\&$//; |
print $client "$qresult\n"; |
print $client "$qresult\n"; |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." untie(GDBM) Failed ". |
|
"while attempting idget\n"; |
} |
} |
} else { |
} else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
." tie(GDBM) Failed ". |
|
"while attempting idget\n"; |
} |
} |
# ---------------------------------------------------------------------- tmpput |
# ---------------------------------------------------------------------- tmpput |
} elsif ($userinput =~ /^tmpput/) { |
} elsif ($userinput =~ /^tmpput/) { |
Line 1411 sub make_new_child {
|
Line 1530 sub make_new_child {
|
print $client "$id\n"; |
print $client "$id\n"; |
} |
} |
else { |
else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
."IO::File->new Failed ". |
|
"while attempting tmpput\n"; |
} |
} |
|
|
# ---------------------------------------------------------------------- tmpget |
# ---------------------------------------------------------------------- tmpget |
Line 1427 sub make_new_child {
|
Line 1548 sub make_new_child {
|
close $store; |
close $store; |
} |
} |
else { |
else { |
print $client "error:$!\n"; |
print $client "error: ".($!+0) |
|
."IO::File->new Failed ". |
|
"while attempting tmpget\n"; |
} |
} |
|
|
|
# ---------------------------------------------------------------------- tmpdel |
|
} elsif ($userinput =~ /^tmpdel/) { |
|
my ($cmd,$id)=split(/:/,$userinput); |
|
chomp($id); |
|
$id=~s/\W/\_/g; |
|
my $execdir=$perlvar{'lonDaemons'}; |
|
if (unlink("$execdir/tmp/$id.tmp")) { |
|
print $client "ok\n"; |
|
} else { |
|
print $client "error: ".($!+0) |
|
."Unlink tmp Failed ". |
|
"while attempting tmpdel\n"; |
|
} |
# -------------------------------------------------------------------------- ls |
# -------------------------------------------------------------------------- ls |
} elsif ($userinput =~ /^ls/) { |
} elsif ($userinput =~ /^ls/) { |
my ($cmd,$ulsdir)=split(/:/,$userinput); |
my ($cmd,$ulsdir)=split(/:/,$userinput); |
Line 1478 sub make_new_child {
|
Line 1614 sub make_new_child {
|
&logthis("<font color=blue>WARNING: " |
&logthis("<font color=blue>WARNING: " |
."Rejected client $clientip, closing connection</font>"); |
."Rejected client $clientip, closing connection</font>"); |
} |
} |
} |
} |
|
|
# ============================================================================= |
# ============================================================================= |
|
|
&logthis("<font color=red>CRITICAL: " |
&logthis("<font color=red>CRITICAL: " |
."Disconnect from $clientip ($hostid{$clientip})</font>"); |
."Disconnect from $clientip ($hostid{$clientip})</font>"); |
# tidy up gracefully and finish |
|
|
|
$server->close(); |
|
|
|
# this exit is VERY important, otherwise the child will become |
# this exit is VERY important, otherwise the child will become |
# a producer of more and more children, forking yourself into |
# a producer of more and more children, forking yourself into |
# process death. |
# process death. |
exit; |
exit; |
} |
|
} |
} |
|
|
|
|
Line 1635 sub unsub {
|
Line 1769 sub unsub {
|
return $result; |
return $result; |
} |
} |
|
|
|
sub currentversion { |
|
my $fname=shift; |
|
my $version=-1; |
|
my $ulsdir=''; |
|
if ($fname=~/^(.+)\/[^\/]+$/) { |
|
$ulsdir=$1; |
|
} |
|
$fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; |
|
$fname=~s/\.(\w+(?:\.meta)*)$/\.\(\\d\+\)\.$1\$/; |
|
|
|
if (-e $fname) { $version=1; } |
|
if (-e $ulsdir) { |
|
if(-d $ulsdir) { |
|
if (opendir(LSDIR,$ulsdir)) { |
|
while ($ulsfn=readdir(LSDIR)) { |
|
# see if this is a regular file (ignore links produced earlier) |
|
my $thisfile=$ulsdir.'/'.$ulsfn; |
|
unless (-l $thisfile) { |
|
if ($thisfile=~/$fname/) { |
|
if ($1>$version) { $version=$1; } |
|
} |
|
} |
|
} |
|
closedir(LSDIR); |
|
$version++; |
|
} |
|
} |
|
} |
|
return $version; |
|
} |
|
|
|
sub thisversion { |
|
my $fname=shift; |
|
my $version=-1; |
|
if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) { |
|
$version=$1; |
|
} |
|
return $version; |
|
} |
|
|
sub subscribe { |
sub subscribe { |
my ($userinput,$clientip)=@_; |
my ($userinput,$clientip)=@_; |
my $result; |
my $result; |
my ($cmd,$fname)=split(/:/,$userinput); |
my ($cmd,$fname)=split(/:/,$userinput); |
my $ownership=&ishome($fname); |
my $ownership=&ishome($fname); |
if ($ownership eq 'owner') { |
if ($ownership eq 'owner') { |
|
# explitly asking for the current version? |
|
unless (-e $fname) { |
|
my $currentversion=¤tversion($fname); |
|
if (&thisversion($fname)==$currentversion) { |
|
if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { |
|
my $root=$1; |
|
my $extension=$2; |
|
symlink($root.'.'.$extension, |
|
$root.'.'.$currentversion.'.'.$extension); |
|
unless ($extension=~/\.meta$/) { |
|
symlink($root.'.'.$extension.'.meta', |
|
$root.'.'.$currentversion.'.'.$extension.'.meta'); |
|
} |
|
} |
|
} |
|
} |
if (-e $fname) { |
if (-e $fname) { |
if (-d $fname) { |
if (-d $fname) { |
$result="directory\n"; |
$result="directory\n"; |