loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.90 and 1.109

version 1.90, 2002/08/13 00:37:18	version 1.109, 2003/03/01 04:18:22
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 74 use Crypt::IDEA;	Line 65 use Crypt::IDEA;
use LWP::UserAgent();	use LWP::UserAgent();
use GDBM_File;	use GDBM_File;
use Authen::Krb4;	use Authen::Krb4;
	use Authen::Krb5;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use localauth;	use localauth;

Line 82 my $DEBUG = 0; # Non zero to ena	Line 74 my $DEBUG = 0; # Non zero to ena
my $status='';	my $status='';
my $lastlog='';	my $lastlog='';

	#
	# The array below are password error strings."
	#
	my $lastpwderror = 13; # Largest error number from lcpasswd.
	my @passwderrors = ("ok",
	"lcpasswd must be run as user 'www'",
	"lcpasswd got incorrect number of arguments",
	"lcpasswd did not get the right nubmer of input text lines",
	"lcpasswd too many simultaneous pwd changes in progress",
	"lcpasswd User does not exist.",
	"lcpasswd Incorrect current passwd",
	"lcpasswd Unable to su to root.",
	"lcpasswd Cannot set new passwd.",
	"lcpasswd Username has invalid characters",
	"lcpasswd Invalid characters in password",
	"11", "12",
	"lcpasswd Password mismatch");


	# The array below are lcuseradd error strings.:

	my $lastadderror = 13;
	my @adderrors = ("ok",
	"User ID mismatch, lcuseradd must run as user www",
	"lcuseradd Incorrect number of command line parameters must be 3",
	"lcuseradd Incorrect number of stdinput lines, must be 3",
	"lcuseradd Too many other simultaneous pwd changes in progress",
	"lcuseradd User does not exist",
	"lcuseradd Unabel to mak ewww member of users's group",
	"lcuseradd Unable to su to root",
	"lcuseradd Unable to set password",
	"lcuseradd Usrname has invbalid charcters",
	"lcuseradd Password has an invalid character",
	"lcuseradd User already exists",
	"lcuseradd Could not add user.",
	"lcuseradd Password mismatch");


	#
	# Convert an error return code from lcpasswd to a string value.
	#
	sub lcpasswdstrerror {
	my $ErrorCode = shift;
	if(($ErrorCode < 0) \|\| ($ErrorCode > $lastpwderror)) {
	return "lcpasswd Unrecognized error return value ".$ErrorCode;
	} else {
	return $passwderrors[$ErrorCode];
	}
	}

	#
	# Convert an error return code from lcuseradd to a string value:
	#
	sub lcuseraddstrerror {
	my $ErrorCode = shift;
	if(($ErrorCode < 0) \|\| ($ErrorCode > $lastadderror)) {
	return "lcuseradd - Unrecognized error code: ".$ErrorCode;
	} else {
	return $adderrors[$ErrorCode];
	}
	}

# grabs exception and records it to log before exiting	# grabs exception and records it to log before exiting
sub catchexception {	sub catchexception {
my ($error)=@_;	my ($error)=@_;
Line 106 $SIG{'QUIT'}=\&catchexception;	Line 160 $SIG{'QUIT'}=\&catchexception;
$SIG{__DIE__}=\&catchexception;	$SIG{__DIE__}=\&catchexception;

# ---------------------------------- Read loncapa_apache.conf and loncapa.conf	# ---------------------------------- Read loncapa_apache.conf and loncapa.conf
&status("Read loncapa_apache.conf and loncapa.conf");	&status("Read loncapa.conf and loncapa_apache.conf");
my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',	my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
'loncapa.conf');
my %perlvar=%{$perlvarref};	my %perlvar=%{$perlvarref};
undef $perlvarref;	undef $perlvarref;

Line 278 sub status {	Line 331 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 428 close(PIDSAVE);	Line 482 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 488 sub make_new_child {	Line 540 sub make_new_child {
or die "Can't unblock SIGINT for fork: $!\n";	or die "Can't unblock SIGINT for fork: $!\n";

$tmpsnum=0;	$tmpsnum=0;
	#---------------------------------------------------- kerberos 5 initialization
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD	&Authen::Krb5::init_context();
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {	&Authen::Krb5::init_ets();
&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
# -----------------------------------------------------------------------------	# -----------------------------------------------------------------------------
	$client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of
	# 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 628 sub make_new_child {	Line 681 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 644 sub make_new_child {	Line 704 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') {
	$null=pack("C",0);
	unless ($upass=~/$null/) {
	my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd);
	my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd;
	my $krbserver=&Authen::Krb5::parse_name($krbservice);
	my $credentials=&Authen::Krb5::cc_default();
	$credentials->initialize($krbclient);
	my $krbreturn =
	&Authen::Krb5::get_in_tkt_with_password(
	$krbclient,$krbserver,$upass,$credentials);
	# unless ($krbreturn) {
	# &logthis("Krb5 Error: ".
	# &Authen::Krb5::error());
	# }
	$pwdcorrect = ($krbreturn == 1);
	} else { $pwdcorrect=0; }
} elsif ($howpwd eq 'localauth') {	} elsif ($howpwd eq 'localauth') {
$pwdcorrect=&localauth::localauth($uname,$upass,	$pwdcorrect=&localauth::localauth($uname,$upass,
$contentpwd);	$contentpwd);
Line 675 sub make_new_child {	Line 762 sub make_new_child {
chomp($npass);	chomp($npass);
$upass=&unescape($upass);	$upass=&unescape($upass);
$npass=&unescape($npass);	$npass=&unescape($npass);
&logthis("Trying to change password for $uname");	&Debug("Trying to change password for $uname");
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my $passfilename="$proname/passwd";	my $passfilename="$proname/passwd";
if (-e $passfilename) {	if (-e $passfilename) {
Line 685 sub make_new_child {	Line 772 sub make_new_child {
chomp($realpasswd);	chomp($realpasswd);
my ($howpwd,$contentpwd)=split(/:/,$realpasswd);	my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
if ($howpwd eq 'internal') {	if ($howpwd eq 'internal') {
	&Debug("internal auth");
if (crypt($upass,$contentpwd) eq $contentpwd) {	if (crypt($upass,$contentpwd) eq $contentpwd) {
my $salt=time;	my $salt=time;
$salt=substr($salt,6,2);	$salt=substr($salt,6,2);
Line 701 sub make_new_child {	Line 789 sub make_new_child {
# one way or another.	# one way or another.
# First: Make sure the current password is	# First: Make sure the current password is
# correct	# correct
	&Debug("auth is unix");
$contentpwd=(getpwnam($uname))[1];	$contentpwd=(getpwnam($uname))[1];
my $pwdcorrect = "0";	my $pwdcorrect = "0";
my $pwauth_path="/usr/local/sbin/pwauth";	my $pwauth_path="/usr/local/sbin/pwauth";
Line 712 sub make_new_child {	Line 801 sub make_new_child {
die "Cannot invoke authentication";	die "Cannot invoke authentication";
print PWAUTH "$uname\n$upass\n";	print PWAUTH "$uname\n$upass\n";
close PWAUTH;	close PWAUTH;
$pwdcorrect=!$?;	&Debug("exited pwauth with $? ($uname,$upass) ");
	$pwdcorrect=($? == 0);
}	}
if ($pwdcorrect) {	if ($pwdcorrect) {
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
my $pf = IO::File->new("\|$execdir/lcpasswd");	&Debug("Opening lcpasswd pipeline");
	my $pf = IO::File->new("\|$execdir/lcpasswd > /home/www/lcpasswd.log");
print $pf "$uname\n$npass\n$npass\n";	print $pf "$uname\n$npass\n$npass\n";
close $pf;	close $pf;
my $result = ($?>0 ? 'pwchange_failure'	my $err = $?;
	my $result = ($err>0 ? 'pwchange_failure'
: 'ok');	: 'ok');
&logthis("Result of password change for $uname: $result");	&logthis("Result of password change for $uname: ".
	&lcpasswdstrerror($?));
print $client "$result\n";	print $client "$result\n";
} else {	} else {
print $client "non_authorized\n";	print $client "non_authorized\n";
Line 737 sub make_new_child {	Line 830 sub make_new_child {
}	}
# -------------------------------------------------------------------- makeuser	# -------------------------------------------------------------------- makeuser
} elsif ($userinput =~ /^makeuser/) {	} elsif ($userinput =~ /^makeuser/) {
Debug("Make user received");	&Debug("Make user received");
my $oldumask=umask(0077);	my $oldumask=umask(0077);
if ($wasenc==1) {	if ($wasenc==1) {
my	my
Line 762 sub make_new_child {	Line 855 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\n";
}	}
}	}
}	}
unless ($fperror) {	unless ($fperror) {
if ($umode eq 'krb4') {	my $result=&make_passwd_file($uname, $umode,$npass,
{	$passfilename);
my $pf = IO::File->new(">$passfilename");	print $client $result;
print $pf "krb4:$npass\n";
}
print $client "ok\n";
} elsif ($umode eq 'internal') {
my $salt=time;
$salt=substr($salt,6,2);
my $ncpass=crypt($npass,$salt);
{
&Debug("Creating internal auth");
my $pf = IO::File->new(">$passfilename");
print $pf "internal:$ncpass\n";
}
print $client "ok\n";
} elsif ($umode eq 'localauth') {
{
my $pf = IO::File->new(">$passfilename");
print $pf "localauth:$npass\n";
}
print $client "ok\n";
} elsif ($umode eq 'unix') {
{
my $execpath="$perlvar{'lonDaemons'}/".
"lcuseradd";
{
&Debug("Executing external: ".
$execpath);
my $se = IO::File->new("\|$execpath");
print $se "$uname\n";
print $se "$npass\n";
print $se "$npass\n";
}
my $pf = IO::File->new(">$passfilename");
print $pf "unix:\n";
}
print $client "ok\n";
} elsif ($umode eq 'none') {
{
my $pf = IO::File->new(">$passfilename");
print $pf "none:\n";
}
print $client "ok\n";
} else {
print $client "auth_mode_error\n";
}
} else {	} else {
print $client "$fperror\n";	print $client "$fperror\n";
}	}
Line 827 sub make_new_child {	Line 877 sub make_new_child {
&Debug("Changing authorization");	&Debug("Changing authorization");
if ($wasenc==1) {	if ($wasenc==1) {
my	my
($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);	($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);
chomp($npass);	chomp($npass);
&Debug("cmd = ".$cmd." domain= ".$udom.	&Debug("cmd = ".$cmd." domain= ".$udom.
"uname =".$uname." umode= ".$umode);	"uname =".$uname." umode= ".$umode);
$npass=&unescape($npass);	$npass=&unescape($npass);
my $proname=propath($udom,$uname);	my $proname=&propath($udom,$uname);
my $passfilename="$proname/passwd";	my $passfilename="$proname/passwd";
if ($udom ne $perlvar{'lonDefDomain'}) {	if ($udom ne $perlvar{'lonDefDomain'}) {
print $client "not_right_domain\n";	print $client "not_right_domain\n";
} else {	} else {
if ($umode eq 'krb4') {	my $result=&make_passwd_file($uname, $umode,$npass,
{	$passfilename);
my $pf = IO::File->new(">$passfilename");	print $client $result;
print $pf "krb4:$npass\n";
}
print $client "ok\n";
} elsif ($umode eq 'internal') {
my $salt=time;
$salt=substr($salt,6,2);
my $ncpass=crypt($npass,$salt);
{
my $pf = IO::File->new(">$passfilename");
print $pf "internal:$ncpass\n";
}
print $client "ok\n";
} elsif ($umode eq 'localauth') {
{
my $pf = IO::File->new(">$passfilename");
print $pf "localauth:$npass\n";
}
print $client "ok\n";
} elsif ($umode eq 'unix') {
{
my $execpath="$perlvar{'lonDaemons'}/".
"lcuseradd";
{
my $se = IO::File->new("\|$execpath");
print $se "$uname\n";
print $se "$npass\n";
print $se "$npass\n";
}
my $pf = IO::File->new(">$passfilename");
print $pf "unix:\n";
}
print $client "ok\n";
} elsif ($umode eq 'none') {
{
my $pf = IO::File->new(">$passfilename");
print $pf "none:\n";
}
print $client "ok\n";
} else {
print $client "auth_mode_error\n";
}
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1002 sub make_new_child {	Line 1011 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 &currentversion($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 1014 sub make_new_child {	Line 1027 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\n";
}	}
}	}
# ------------------------------------------------------------------------- put	# ------------------------------------------------------------------------- put
Line 1042 sub make_new_child {	Line 1056 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!)
	." tie(GDBM) Failed\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1084 sub make_new_child {	Line 1100 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1110 sub make_new_child {	Line 1128 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed\n";
}	}
# ------------------------------------------------------------------------ eget	# ------------------------------------------------------------------------ eget
} elsif ($userinput =~ /^eget/) {	} elsif ($userinput =~ /^eget/) {
Line 1146 sub make_new_child {	Line 1166 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed\n";
}	}
# ------------------------------------------------------------------------- del	# ------------------------------------------------------------------------- del
} elsif ($userinput =~ /^del/) {	} elsif ($userinput =~ /^del/) {
Line 1174 sub make_new_child {	Line 1196 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed\n";
}	}
# ------------------------------------------------------------------------ keys	# ------------------------------------------------------------------------ keys
} elsif ($userinput =~ /^keys/) {	} elsif ($userinput =~ /^keys/) {
Line 1195 sub make_new_child {	Line 1219 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed\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\n";
	}
	} else {
	print $client "error: ".($!+0)
	." tie(GDBM) Failed\n";
}	}
# ------------------------------------------------------------------------ dump	# ------------------------------------------------------------------------ dump
} elsif ($userinput =~ /^dump/) {	} elsif ($userinput =~ /^dump/) {
Line 1211 sub make_new_child {	Line 1280 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed\n";
}	}
# ----------------------------------------------------------------------- store	# ----------------------------------------------------------------------- store
} elsif ($userinput =~ /^store/) {	} elsif ($userinput =~ /^store/) {
Line 1265 sub make_new_child {	Line 1340 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 1299 sub make_new_child {	Line 1376 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed\n";
}	}
# -------------------------------------------------------------------- chatsend	# -------------------------------------------------------------------- chatsend
} elsif ($userinput =~ /^chatsend/) {	} elsif ($userinput =~ /^chatsend/) {
Line 1341 sub make_new_child {	Line 1420 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\n";
}	}
# ----------------------------------------------------------------------- idput	# ----------------------------------------------------------------------- idput
} elsif ($userinput =~ /^idput/) {	} elsif ($userinput =~ /^idput/) {
Line 1365 sub make_new_child {	Line 1445 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed\n";
}	}
# ----------------------------------------------------------------------- idget	# ----------------------------------------------------------------------- idget
} elsif ($userinput =~ /^idget/) {	} elsif ($userinput =~ /^idget/) {
Line 1386 sub make_new_child {	Line 1468 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\n";
}	}
} else {	} else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	." tie(GDBM) Failed\n";
}	}
# ---------------------------------------------------------------------- tmpput	# ---------------------------------------------------------------------- tmpput
} elsif ($userinput =~ /^tmpput/) {	} elsif ($userinput =~ /^tmpput/) {
Line 1406 sub make_new_child {	Line 1490 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\n";
}	}

# ---------------------------------------------------------------------- tmpget	# ---------------------------------------------------------------------- tmpget
Line 1422 sub make_new_child {	Line 1507 sub make_new_child {
close $store;	close $store;
}	}
else {	else {
print $client "error:$!\n";	print $client "error: ".($!+0)
	."IO::File->new Failed\n";
}	}

# -------------------------------------------------------------------------- ls	# -------------------------------------------------------------------------- ls
Line 1473 sub make_new_child {	Line 1559 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 1539 sub GetAuthType	Line 1623 sub GetAuthType
my ($authtype, $contentpwd) = split(/:/, $realpassword);	my ($authtype, $contentpwd) = split(/:/, $realpassword);
Debug("Authtype = $authtype, content = $contentpwd\n");	Debug("Authtype = $authtype, content = $contentpwd\n");
my $availinfo = '';	my $availinfo = '';
if($authtype eq 'krb4') {	if($authtype eq 'krb4' or $authtype eq 'krb5') {
$availinfo = $contentpwd;	$availinfo = $contentpwd;
}	}

Line 1630 sub unsub {	Line 1714 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=&currentversion($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";
Line 1661 sub subscribe {	Line 1801 sub subscribe {
}	}
return $result;	return $result;
}	}

	sub make_passwd_file {
	my ($uname, $umode,$npass,$passfilename)=@_;
	my $result="ok\n";
	if ($umode eq 'krb4' or $umode eq 'krb5') {
	{
	my $pf = IO::File->new(">$passfilename");
	print $pf "$umode:$npass\n";
	}
	} elsif ($umode eq 'internal') {
	my $salt=time;
	$salt=substr($salt,6,2);
	my $ncpass=crypt($npass,$salt);
	{
	&Debug("Creating internal auth");
	my $pf = IO::File->new(">$passfilename");
	print $pf "internal:$ncpass\n";
	}
	} elsif ($umode eq 'localauth') {
	{
	my $pf = IO::File->new(">$passfilename");
	print $pf "localauth:$npass\n";
	}
	} elsif ($umode eq 'unix') {
	{
	my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
	{
	&Debug("Executing external: ".$execpath);
	&Debug("user = ".$uname.", Password =". $npass);
	my $se = IO::File->new("\|$execpath > /home/www/lcuseradd.log");
	print $se "$uname\n";
	print $se "$npass\n";
	print $se "$npass\n";
	}
	my $useraddok = $?;
	if($useraddok > 0) {
	&logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok));
	}
	my $pf = IO::File->new(">$passfilename");
	print $pf "unix:\n";
	}
	} elsif ($umode eq 'none') {
	{
	my $pf = IO::File->new(">$passfilename");
	print $pf "none:\n";
	}
	} else {
	$result="auth_mode_error\n";
	}
	return $result;
	}

# ----------------------------------- POD (plain old documentation, CPAN style)	# ----------------------------------- POD (plain old documentation, CPAN style)

=head1 NAME	=head1 NAME
Line 1959 Crypt::IDEA	Line 2151 Crypt::IDEA
LWP::UserAgent()	LWP::UserAgent()
GDBM_File	GDBM_File
Authen::Krb4	Authen::Krb4
	Authen::Krb5

=head1 COREQUISITES	=head1 COREQUISITES

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

Removed from v.1.90
changed lines
	Added in v.1.109