loncom/lonc - diff

Return to lonc CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/Attic/lonc between versions 1.35 and 1.45

version 1.35, 2002/03/26 04:37:59	version 1.45, 2003/02/03 18:03:52
Line 37	Line 37
# 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19,	# 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19,
# 10/8,10/9,10/15,11/18,12/22,	# 10/8,10/9,10/15,11/18,12/22,
# 2/8,7/25 Gerd Kortemeyer	# 2/8,7/25 Gerd Kortemeyer
# 12/05 Scott Harrison
# 12/05 Gerd Kortemeyer	# 12/05 Gerd Kortemeyer
# YEAR=2001	# YEAR=2001
# 01/10/01 Scott Harrison
# 03/14/01,03/15,06/12,11/26,11/27,11/28 Gerd Kortemeyer	# 03/14/01,03/15,06/12,11/26,11/27,11/28 Gerd Kortemeyer
# 12/20 Scott Harrison
# YEAR=2002	# YEAR=2002
# 2/19/02,02/22/02,02/25/02 Gerd Kortemeyer	# 2/19/02,02/22/02,02/25/02 Gerd Kortemeyer
# 3/07/02 Ron Fox	# 3/07/02 Ron Fox
# based on nonforker from Perl Cookbook	# based on nonforker from Perl Cookbook
# - server who multiplexes without forking	# - server who multiplexes without forking

	use lib '/home/httpd/lib/perl/';
	use LONCAPA::Configuration;

use POSIX;	use POSIX;
use IO::Socket;	use IO::Socket;
use IO::Select;	use IO::Select;
Line 71 $DEBUG = 0; # Set to 1 for annoyingly	Line 71 $DEBUG = 0; # Set to 1 for annoyingly
$SIG{QUIT}=\&catchexception;	$SIG{QUIT}=\&catchexception;
$SIG{__DIE__}=\&catchexception;	$SIG{__DIE__}=\&catchexception;

# ------------------------------------ Read httpd access.conf and get variables	# ---------------------------------- Read loncapa_apache.conf and loncapa.conf
&status("Read access.conf");	&status("Read loncapa.conf and loncapa_apache.conf");
open (CONFIG,"/etc/httpd/conf/access.conf") \|\| die "Can't read access.conf";	my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
	my %perlvar=%{$perlvarref};
while ($configline=<CONFIG>) {	undef $perlvarref;
if ($configline =~ /PerlSetVar/) {
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
chomp($varvalue);
$perlvar{$varname}=$varvalue;
}
}
close(CONFIG);

# ----------------------------- Make sure this process is running from user=www	# ----------------------------- Make sure this process is running from user=www
&status("Check user ID");	&status("Check user ID");
Line 175 $SIG{USR1} = \&USRMAN;	Line 168 $SIG{USR1} = \&USRMAN;
# And maintain the population.	# And maintain the population.
while (1) {	while (1) {
my $deadpid = wait; # Wait for the next child to die.	my $deadpid = wait; # Wait for the next child to die.
# See who died and start new one	# See who died and start new one
	# or a signal (e.g. USR1 for restart).
	# if a signal, the wait will fail
	# This is ordinarily detected by
	# checking for the existence of the
	# pid index inthe children hash since
	# the return value from a failed wait is -1
	# which is an impossible PID.
&status("Woke up");	&status("Woke up");
my $skipping='';	my $skipping='';

Line 255 unlink($port);	Line 255 unlink($port);
@allbuffered=grep /\.$conserver$/, readdir DIRHANDLE;	@allbuffered=grep /\.$conserver$/, readdir DIRHANDLE;
closedir(DIRHANDLE);	closedir(DIRHANDLE);
my $dfname;	my $dfname;
foreach (@allbuffered) {	foreach (sort @allbuffered) {
&status("Sending delayed: $_");	&status("Sending delayed: $_");
$dfname="$path/$_";	$dfname="$path/$_";
if($DEBUG) { &logthis('Sending '.$dfname); }	if($DEBUG) { &logthis('Sending '.$dfname); }
Line 315 unless (	Line 315 unless (
%outbuffer = ();	%outbuffer = ();
%ready = ();	%ready = ();
%servers = (); # To be compatible with make filevector. indexed by	%servers = (); # To be compatible with make filevector. indexed by
# File descriptors, values are file descriptors.	# File ids, values are sockets.
# note that the accept socket is omitted.	# note that the accept socket is omitted.

tie %ready, 'Tie::RefHash';	tie %ready, 'Tie::RefHash';

nonblock($server);	# nonblock($server);
$select = IO::Select->new($server);	# $select = IO::Select->new($server);

# Main loop: check reads/accepts, check writes, check ready to process	# Main loop: check reads/accepts, check writes, check ready to process

	status("Main loop");
while (1) {	while (1) {
my $client;	my $client;
my $rv;	my $rv;
my $data;	my $data;

my $infdset; # bit vec of fd's to select on input.	my $infdset; # bit vec of fd's to select on input.
my $inreadyset; # Bit vec of fd's ready for input.

my $outfdset; # Bit vec of fd's to select on output.	my $outfdset; # Bit vec of fd's to select on output.
my $outreadyset; # bit vec of fds ready for output.


$infdset = MakeFileVector(\%servers);	$infdset = MakeFileVector(\%servers);
$outfdset= MakeFileVector(\%outbuffer);	$outfdset= MakeFileVector(\%outbuffer);
	vec($infdset, $server->fileno, 1) = 1;
# check for new information on the connections we have	if($DEBUG) {
# anything to read or accept?	&logthis("Adding ".$server->fileno.
	" to input select vector (listner)".
foreach $client ($select->can_read(00.10)) {	unpack("b*",$infdset)."\n");
if ($client == $server) {
# accept a new connection
&status("Accept new connection: $conserver");
$client = $server->accept();
$select->add($client);
nonblock($client);
} else {
# read data
$data = '';
$rv = $client->recv($data, POSIX::BUFSIZ, 0);

unless (defined($rv) && length $data) {
# This would be the end of file, so close the client
delete $inbuffer{$client};
delete $outbuffer{$client};
delete $ready{$client};

&status("Idle");
$select->remove($client);
close $client;
next;
}

$inbuffer{$client} .= $data;


# test whether the data in the buffer or the data we
# just read means there is a complete request waiting
# to be fulfilled. If there is, set $ready{$client}
# to the requests waiting to be fulfilled.
while ($inbuffer{$client} =~ s/(.*\n)//) {
push( @{$ready{$client}}, $1 );
}
}
}	}
	DoSelect(\$infdset, \$outfdset); # Wait for input.
# Any complete requests to process?	if($DEBUG) {
foreach $client (keys %ready) {	&logthis("Doselect completed!");
handle($client);	&logthis("ins = ".unpack("b*",$infdset)."\n");
	&logthis("outs= ".unpack("b*",$outfdset)."\n");

}	}

# Buffers to flush?
foreach $client ($select->can_write(1)) {
# Skip this client if we have nothing to say
next unless exists $outbuffer{$client};

$rv = $client->send($outbuffer{$client}, 0);

unless ($outbuffer{$client} eq "con_lost\n") {
unless (defined $rv) {
# Whine, but move on.
&logthis("I was told I could write, but I can't.\n");
next;
}
$errno=$!;
if (($rv == length $outbuffer{$client}) \|\|
($errno == POSIX::EWOULDBLOCK) \|\| ($errno == 0)) {
substr($outbuffer{$client}, 0, $rv) = '';
delete $outbuffer{$client} unless length $outbuffer{$client};
} else {
# Couldn't write all the data, and it wasn't because
# it would have blocked. Shutdown and move on.

&logthis("Dropping data with ".$errno.": ".
length($outbuffer{$client}).", $rv");

delete $inbuffer{$client};	# Checkfor new connections:
delete $outbuffer{$client};	if (vec($infdset, $server->fileno, 1)) {
delete $ready{$client};	if($DEBUG) {
	&logthis("New connection established");
$select->remove($client);	}
close($client);	# accept a new connection
next;	&status("Accept new connection: $conserver");
}	$client = $server->accept();
} else {	if($DEBUG) {
# -------------------------------------------------------- Wow, connection lost	&logthis("New client fd = ".$client->fileno."\n");
&logthis(	}
"<font color=red>CRITICAL: Closing connection</font>");	$servers{$client->fileno} = $client;
&status("Connection lost");	nonblock($client);
$remotesock->shutdown(2);
&logthis("Attempting to open new connection");
&openremote($conserver);
}
}	}
	HandleInput($infdset, \%servers, \%inbuffer, \%outbuffer, \%ready);
	HandleOutput($outfdset, \%servers, \%outbuffer, \%inbuffer,
	\%ready);
	# -------------------------------------------------------- Wow, connection lost

}	}

	}
}	}

# ------------------------------------------------------- End of make_new_child	# ------------------------------------------------------- End of make_new_child
Line 446 sub MakeFileVector	Line 391 sub MakeFileVector
my $fdhash = shift;	my $fdhash = shift;
my $selvar = "";	my $selvar = "";

foreach $socket (keys %fdhash) {	foreach $socket (keys %$fdhash) {
vec($selvar, ($fdhash->{$socket})->fileno, 1) = 1;	if($DEBUG) {
	&logthis("Adding ".$socket.
	"to select vector. (client)\n");
	}
	vec($selvar, $socket, 1) = 1;
}	}
return $selvar;	return $selvar;
}	}
Line 458 sub MakeFileVector	Line 407 sub MakeFileVector
# Processes output on a buffered set of file descriptors which are	# Processes output on a buffered set of file descriptors which are
# ready to be read.	# ready to be read.
# Parameters:	# Parameters:
# $selvector - Vector of writable file descriptors which are writable.	# $selvector - Vector of file descriptors which are writable.
# \%sockets - Vector of socket references indexed by socket.	# \%sockets - Vector of socket references indexed by socket.
# \%buffers - Reference to a hash containing output buffers.	# \%buffers - Reference to a hash containing output buffers.
# Hashes are indexed by sockets. The file descriptors of some	# Hashes are indexed by sockets. The file descriptors of some
Line 477 sub HandleOutput	Line 426 sub HandleOutput
my $buffers = shift;	my $buffers = shift;
my $inbufs = shift;	my $inbufs = shift;
my $readys = shift;	my $readys = shift;
	my $sock;

	if($DEBUG) {
	&logthis("HandleOutput entered\n");
	}

foreach $sock (keys %buffers) {	foreach $sock (keys %$sockets) {
my $socket = $sockets->{$sock};	my $socket = $sockets->{$sock};
if(vec($selvector, $$socket->fileno, 1)) { # $socket is writable.	if(vec($selvector, $sock, 1)) { # $socket is writable.
my $rv = $$socket->send($buffers->{$sock}, 0);	if($DEBUG) {
	&logthis("Sending $buffers->{$sock} \n");
	}
	my $rv = $socket->send($buffers->{$sock}, 0);
$errno = $!;	$errno = $!;
unless ($buffers->{$sock} eq "con_lost\n") {	unless ($buffers->{$sock} eq "con_lost\n") {
unless (defined $rv) { # Write failed... could be EINTR	unless (defined $rv) { # Write failed... could be EINTR
Line 510 sub HandleOutput	Line 467 sub HandleOutput
delete $inbufs->{$sock};	delete $inbufs->{$sock};
delete $readys->{$sock};	delete $readys->{$sock};

close($$socket); # Close the client socket.	close($socket); # Close the client socket.
next;	next;
}	}
} else { # Kludgy way to mark lond connection lost.	} else { # Kludgy way to mark lond connection lost.
Line 519 sub HandleOutput	Line 476 sub HandleOutput
status("Connection lost");	status("Connection lost");
$remotesock->shutdown(2);	$remotesock->shutdown(2);
&logthis("Attempting to open a new connection");	&logthis("Attempting to open a new connection");
&openremot($conserver);	&openremote($conserver);
}	}

}	}
Line 553 sub HandleInput	Line 510 sub HandleInput
my $ibufs = shift;	my $ibufs = shift;
my $obufs = shift;	my $obufs = shift;
my $ready = shift;	my $ready = shift;
	my $sock;

foreach $sock (keys %sockets) {	if($DEBUG) {
	&logthis("Entered HandleInput\n");
	}
	foreach $sock (keys %$sockets) {
my $socket = $sockets->{$sock};	my $socket = $sockets->{$sock};
if(vec($selvec, $$socket->fileno, 1)) { # Socket which is readable.	if(vec($selvec, $sock, 1)) { # Socket which is readable.

# Attempt to read the data and do error management.	# Attempt to read the data and do error management.
my $data = '';	my $data = '';
my $rv = $$socket->recv($data, POSIX::BUFSIZ, 0);	my $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
	if($DEBUG) {
	&logthis("Received $data from socket");
	}
unless (defined($rv) && length $data) {	unless (defined($rv) && length $data) {

# Read an end of file.. this is a disconnect from the peer.	# Read an end of file.. this is a disconnect from the peer.
Line 571 sub HandleInput	Line 535 sub HandleInput
delete $ready->{$sock};	delete $ready->{$sock};

status("Idle");	status("Idle");
close $$socket;	close $socket;
next;	next;
}	}
# Append the read data to the input buffer. If the buffer	# Append the read data to the input buffer. If the buffer
Line 592 sub HandleInput	Line 556 sub HandleInput
}	}
}	}

	# DoSelect: does a select with no timeout. On signal (errno == EINTR),
	# the select is retried until there are items in the returned
	# vectors.
	#
	# Parameters:
	# \$readvec - Reference to a vector of file descriptors to
	# check for readability.
	# \$writevec - Reference to a vector of file descriptors to check for
	# writability.
	# On exit, the referents are modified with vectors indicating which
	# file handles are readable/writable.
	#
	sub DoSelect {
	my $readvec = shift;
	my $writevec= shift;
	my $outs;
	my $ins;

	while (1) {
	my $nfds = select( $ins = $$readvec, $outs = $$writevec, undef, undef);
	if($nfds) {
	if($DEBUG) {
	&logthis("select exited with ".$nfds." fds\n");
	&logthis("ins = ".unpack("b*",$ins).
	" readvec = ".unpack("b*",$$readvec)."\n");
	&logthis("outs = ".unpack("b*",$outs).
	" writevec = ".unpack("b*",$$writevec)."\n");
	}
	$$readvec = $ins;
	$$writevec = $outs;
	return;
	} else {
	if($DEBUG) {
	&logthis("Select exited with no bits set in mask\n");
	}
	die "Select failed" unless $! == EINTR;
	}
	}
	}

# handle($socket) deals with all pending requests for $client	# handle($socket) deals with all pending requests for $client
#	#
sub handle {	sub handle {
Line 677 sub handle {	Line 681 sub handle {
}	}
}	}
# ---------------------------------------------------------- End make_new_child	# ---------------------------------------------------------- End make_new_child
}

# nonblock($socket) puts socket into nonblocking mode	# nonblock($socket) puts socket into nonblocking mode
sub nonblock {	sub nonblock {
Line 867 sub checkchildren {	Line 870 sub checkchildren {

sub USRMAN {	sub USRMAN {
&logthis("USR1: Trying to establish connections again");	&logthis("USR1: Trying to establish connections again");
%childatt=();	#
&checkchildren();	# It is really important not to just clear the childatt hash or we will
	# lose all memory of the children. What we really want to do is this:
	# For each index where childatt is >= $childmaxattempts
	# Zero the associated counter and do a make_child for the host.
	# Regardles, the childatt entry is zeroed:
	my $host;
	foreach $host (keys %childatt) {
	if ($childatt{$host} >= $childmaxattempts) {
	$childatt{$host} = 0;
	&logthis("<font color=green>INFO: Restarting child for server: "
	.$host."</font>\n");
	make_new_child($host);
	}
	else {
	$childatt{$host} = 0;
	}
	}
	&checkchildren(); # See if any children are still dead...
}	}

# -------------------------------------------------- Non-critical communication	# -------------------------------------------------- Non-critical communication
Line 1013 sub status {	Line 1033 sub status {
my $now=time;	my $now=time;
my $local=localtime($now);	my $local=localtime($now);
$status=$local.': '.$what;	$status=$local.': '.$what;
	$0='lonc: '.$what.' '.$local;
}	}

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.35
changed lines
	Added in v.1.45