loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.171 and 1.199

version 1.171, 2004/01/14 01:08:31	version 1.199, 2004/06/18 23:57:17
Line 45 use Authen::Krb4;	Line 45 use Authen::Krb4;
use Authen::Krb5;	use Authen::Krb5;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use localauth;	use localauth;
	use localenroll;
use File::Copy;	use File::Copy;
use LONCAPA::ConfigFileEdit;	use LONCAPA::ConfigFileEdit;

Line 225 sub ValidManager {	Line 226 sub ValidManager {
# 1 - Success.	# 1 - Success.
#	#
sub CopyFile {	sub CopyFile {
my $oldfile = shift;
my $newfile = shift;	my ($oldfile, $newfile) = @_;

# The file must exist:	# The file must exist:

Line 326 sub AdjustHostContents {	Line 327 sub AdjustHostContents {
# 0 - failure and $! has an errno.	# 0 - failure and $! has an errno.
#	#
sub InstallFile {	sub InstallFile {
my $Filename = shift;
my $Contents = shift;	my ($Filename, $Contents) = @_;
my $TempFile = $Filename.".tmp";	my $TempFile = $Filename.".tmp";

# Open the file for write:	# Open the file for write:
Line 564 sub isValidEditCommand {	Line 565 sub isValidEditCommand {
# file being edited.	# file being edited.
#	#
sub ApplyEdit {	sub ApplyEdit {
my $directive = shift;
my $editor = shift;	my ($directive, $editor) = @_;

# Break the directive down into its command and its parameters	# Break the directive down into its command and its parameters
# (at most two at this point. The meaning of the parameters, if in fact	# (at most two at this point. The meaning of the parameters, if in fact
Line 649 sub AdjustOurHost {	Line 650 sub AdjustOurHost {
# editor - Editor containing the file.	# editor - Editor containing the file.
#	#
sub ReplaceConfigFile {	sub ReplaceConfigFile {
my $filename = shift;
my $editor = shift;	my ($filename, $editor) = @_;

CopyFile ($filename, $filename.".old");	CopyFile ($filename, $filename.".old");

Line 749 sub catchexception {	Line 750 sub catchexception {
$SIG{'QUIT'}='DEFAULT';	$SIG{'QUIT'}='DEFAULT';
$SIG{__DIE__}='DEFAULT';	$SIG{__DIE__}='DEFAULT';
&status("Catching exception");	&status("Catching exception");
&logthis("<font color=red>CRITICAL: "	&logthis("<font color='red'>CRITICAL: "
."ABNORMAL EXIT. Child $$ for server $thisserver died through "	."ABNORMAL EXIT. Child $$ for server $thisserver died through "
."a crash with this error msg->[$error]</font>");	."a crash with this error msg->[$error]</font>");
&logthis('Famous last words: '.$status.' - '.$lastlog);	&logthis('Famous last words: '.$status.' - '.$lastlog);
Line 760 sub catchexception {	Line 761 sub catchexception {

sub timeout {	sub timeout {
&status("Handling Timeout");	&status("Handling Timeout");
&logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");	&logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
&catchexception('Timeout');	&catchexception('Timeout');
}	}
# -------------------------------- Set signal handlers to record abnormal exits	# -------------------------------- Set signal handlers to record abnormal exits
Line 812 $server = IO::Socket::INET->new(LocalPor	Line 813 $server = IO::Socket::INET->new(LocalPor
# global variables	# global variables

my %children = (); # keys are current child process IDs	my %children = (); # keys are current child process IDs
my $children = 0; # current number of children

sub REAPER { # takes care of dead children	sub REAPER { # takes care of dead children
$SIG{CHLD} = \&REAPER;	$SIG{CHLD} = \&REAPER;
&status("Handling child death");	&status("Handling child death");
my $pid = wait;	my $pid;
if (defined($children{$pid})) {	do {
&logthis("Child $pid died");	$pid = waitpid(-1,&WNOHANG());
$children --;	if (defined($children{$pid})) {
delete $children{$pid};	&logthis("Child $pid died");
} else {	delete($children{$pid});
&logthis("Unknown Child $pid died");	} elsif ($pid > 0) {
	&logthis("Unknown Child $pid died");
	}
	} while ( $pid > 0 );
	foreach my $child (keys(%children)) {
	$pid = waitpid($child,&WNOHANG());
	if ($pid > 0) {
	&logthis("Child $child - $pid looks like we missed it's death");
	delete($children{$pid});
	}
}	}
&status("Finished Handling child death");	&status("Finished Handling child death");
}	}
Line 835 sub HUNTSMAN { # si	Line 844 sub HUNTSMAN { # si
&logthis("Free socket: ".shutdown($server,2)); # free up socket	&logthis("Free socket: ".shutdown($server,2)); # free up socket
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
unlink("$execdir/logs/lond.pid");	unlink("$execdir/logs/lond.pid");
&logthis("<font color=red>CRITICAL: Shutting down</font>");	&logthis("<font color='red'>CRITICAL: Shutting down</font>");
&status("Done killing children");	&status("Done killing children");
exit; # clean up with dignity	exit; # clean up with dignity
}	}
Line 845 sub HUPSMAN { # sig	Line 854 sub HUPSMAN { # sig
&status("Killing children for restart (HUP)");	&status("Killing children for restart (HUP)");
kill 'INT' => keys %children;	kill 'INT' => keys %children;
&logthis("Free socket: ".shutdown($server,2)); # free up socket	&logthis("Free socket: ".shutdown($server,2)); # free up socket
&logthis("<font color=red>CRITICAL: Restarting</font>");	&logthis("<font color='red'>CRITICAL: Restarting</font>");
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
unlink("$execdir/logs/lond.pid");	unlink("$execdir/logs/lond.pid");
&status("Restarting self (HUP)");	&status("Restarting self (HUP)");
Line 879 sub ReadHostTable {	Line 888 sub ReadHostTable {
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";	open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";

while (my $configline=<CONFIG>) {	while (my $configline=<CONFIG>) {
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);	if (!($configline =~ /^\s*\#/)) {
chomp($ip); $ip=~s/\D+$//;	my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
$hostid{$ip}=$id;	chomp($ip); $ip=~s/\D+$//;
$hostdom{$id}=$domain;	$hostid{$ip}=$id;
$hostip{$id}=$ip;	$hostdom{$id}=$domain;
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }	$hostip{$id}=$ip;
	if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
	}
}	}
close(CONFIG);	close(CONFIG);
}	}
Line 1005 sub Debug {	Line 1016 sub Debug {
# request - Original request from client.	# request - Original request from client.
#	#
sub Reply {	sub Reply {
my $fd = shift;
my $reply = shift;	my ($fd, $reply, $request) = @_;
my $request = shift;

print $fd $reply;	print $fd $reply;
Debug("Request was $request Reply was $reply");	Debug("Request was $request Reply was $reply");
Line 1020 sub logstatus {	Line 1030 sub logstatus {
my $docdir=$perlvar{'lonDocRoot'};	my $docdir=$perlvar{'lonDocRoot'};
{	{
my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");	my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";	print $fh $$."\t".$clientname."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
$fh->close();	$fh->close();
}	}
&status("Finished londstatus.txt");	&status("Finished londstatus.txt");
Line 1085 sub reconlonc {	Line 1095 sub reconlonc {
kill USR1 => $loncpid;	kill USR1 => $loncpid;
} else {	} else {
&logthis(	&logthis(
"<font color=red>CRITICAL: "	"<font color='red'>CRITICAL: "
."lonc at pid $loncpid not responding, giving up</font>");	."lonc at pid $loncpid not responding, giving up</font>");
}	}
} else {	} else {
&logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');	&logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');
}	}
}	}

Line 1193 my $execdir=$perlvar{'lonDaemons'};	Line 1203 my $execdir=$perlvar{'lonDaemons'};
open (PIDSAVE,">$execdir/logs/lond.pid");	open (PIDSAVE,">$execdir/logs/lond.pid");
print PIDSAVE "$$\n";	print PIDSAVE "$$\n";
close(PIDSAVE);	close(PIDSAVE);
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");	&logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
&status('Starting');	&status('Starting');


Line 1248 sub make_new_child {	Line 1258 sub make_new_child {
# the pid hash.	# the pid hash.
#	#
my $caller = getpeername($client);	my $caller = getpeername($client);
my ($port,$iaddr)=unpack_sockaddr_in($caller);	my ($port,$iaddr);
$clientip=inet_ntoa($iaddr);	if (defined($caller) && length($caller) > 0) {
	($port,$iaddr)=unpack_sockaddr_in($caller);
	} else {
	&logthis("Unable to determine who caller was, getpeername returned nothing");
	}
	if (defined($iaddr)) {
	$clientip=inet_ntoa($iaddr);
	} else {
	&logthis("Unable to determine clinetip");
	$clientip='Unavailable';
	}

if ($pid) {	if ($pid) {
# Parent records the child's birth and returns.	# Parent records the child's birth and returns.
sigprocmask(SIG_UNBLOCK, $sigset)	sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";	or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = $clientip;	$children{$pid} = $clientip;
$children++;
&status('Started child '.$pid);	&status('Started child '.$pid);
return;	return;
} else {	} else {
Line 1321 sub make_new_child {	Line 1340 sub make_new_child {
print $client "ok\n";	print $client "ok\n";
} else {	} else {
&logthis(	&logthis(
"<font color=blue>WARNING: $clientip did not reply challenge</font>");	"<font color='blue'>WARNING: $clientip did not reply challenge</font>");
&status('No challenge reply '.$clientip);	&status('No challenge reply '.$clientip);
}	}
} else {	} else {
&logthis(	&logthis(
"<font color=blue>WARNING: "	"<font color='blue'>WARNING: "
."$clientip failed to initialize: >$remotereq< </font>");	."$clientip failed to initialize: >$remotereq< </font>");
&status('No init '.$clientip);	&status('No init '.$clientip);
}	}
} else {	} else {
&logthis(	&logthis(
"<font color=blue>WARNING: Unknown client $clientip</font>");	"<font color='blue'>WARNING: Unknown client $clientip</font>");
&status('Hung up on '.$clientip);	&status('Hung up on '.$clientip);
}	}
if ($clientok) {	if ($clientok) {
Line 1346 sub make_new_child {	Line 1365 sub make_new_child {
}	}
&reconlonc("$perlvar{'lonSockDir'}/$id");	&reconlonc("$perlvar{'lonSockDir'}/$id");
}	}
&logthis("<font color=green>Established connection: $clientname</font>");	&logthis("<font color='green'>Established connection: $clientname</font>");
&status('Will listen to '.$clientname);	&status('Will listen to '.$clientname);
# ------------------------------------------------------------ Process requests	# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {	while (my $userinput=<$client>) {
Line 1543 sub make_new_child {	Line 1562 sub make_new_child {
$pwdcorrect=0;	$pwdcorrect=0;
# log error if it is not a bad password	# log error if it is not a bad password
if ($krb4_error != 62) {	if ($krb4_error != 62) {
&logthis('krb4:'.$uname.','.$contentpwd.','.	&logthis('krb4:'.$uname.','.
&Authen::Krb4::get_err_txt($Authen::Krb4::error));	&Authen::Krb4::get_err_txt($Authen::Krb4::error));
}	}
}	}
Line 1809 sub make_new_child {	Line 1828 sub make_new_child {
} elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.	} elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
if(isClient) {	if(isClient) {
my ($cmd,$fname)=split(/:/,$userinput);	my ($cmd,$fname)=split(/:/,$userinput);
my ($udom,$uname,$ufile)=split(/\//,$fname);	my ($udom,$uname,$ufile) = ($fname =~ m\|^([^/]+)/([^/]+)/(.+)$\|);
my $udir=propath($udom,$uname).'/userfiles';	my $udir=propath($udom,$uname).'/userfiles';
unless (-e $udir) { mkdir($udir,0770); }	unless (-e $udir) { mkdir($udir,0770); }
if (-e $udir) {	if (-e $udir) {
$ufile=~s/^[\.\~]+//;	$ufile=~s/^[\.\~]+//;
$ufile=~s/\///g;	my $path = $udir;
	if ($ufile =~m\|(.+)/([^/]+)$\|) {
	my @parts=split('/',$1);
	foreach my $part (@parts) {
	$path .= '/'.$part;
	if ((-e $path)!=1) {
	mkdir($path,0770);
	}
	}
	}
my $destname=$udir.'/'.$ufile;	my $destname=$udir.'/'.$ufile;
my $transname=$udir.'/'.$ufile.'.in.transit';	my $transname=$udir.'/'.$ufile.'.in.transit';
my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;	my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
Line 1843 sub make_new_child {	Line 1871 sub make_new_child {
}	}
} else {	} else {
Reply($client, "refused\n", $userinput);	Reply($client, "refused\n", $userinput);
	}
	# --------------------------------------------------------- remove a user file
	} elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.
	if(isClient) {
	my ($cmd,$fname)=split(/:/,$userinput);
	my ($udom,$uname,$ufile) = ($fname =~ m\|^([^/]+)/([^/]+)/(.+)$\|);
	&logthis("$udom - $uname - $ufile");
	if ($ufile =~m\|/\.\./\|) {
	# any files paths with /../ in them refuse
	# to deal with
	print $client "refused\n";
	} else {
	my $udir=propath($udom,$uname);
	if (-e $udir) {
	my $file=$udir.'/userfiles/'.$ufile;
	if (-e $file) {
	unlink($file);
	if (-e $file) {
	print $client "failed\n";
	} else {
	print $client "ok\n";
	}
	} else {
	print $client "not_found\n";
	}
	} else {
	print $client "not_home\n";
	}
	}
	} else {
	Reply($client, "refused\n", $userinput);
}	}
# ------------------------------------------ authenticate access to a user file	# ------------------------------------------ authenticate access to a user file
} elsif ($userinput =~ /^tokenauthuserfile/) { # Client only	} elsif ($userinput =~ /^tokenauthuserfile/) { # Client only
Line 1854 sub make_new_child {	Line 1912 sub make_new_child {
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.	if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
$session.'.id')) {	$session.'.id')) {
while (my $line=<ENVIN>) {	while (my $line=<ENVIN>) {
if ($line=~/userfile\.$fname\=/) { $reply='ok'; }	if ($line=~ m\|userfile\.\Q$fname\E\=\|) { $reply='ok'; }
}	}
close(ENVIN);	close(ENVIN);
print $client $reply."\n";	print $client $reply."\n";
Line 1870 sub make_new_child {	Line 1928 sub make_new_child {
if(isClient) {	if(isClient) {
my ($cmd,$fname)=split(/:/,$userinput);	my ($cmd,$fname)=split(/:/,$userinput);
if (-e $fname) {	if (-e $fname) {
print $client &unsub($client,$fname,$clientip);	print $client &unsub($fname,$clientip);
} else {	} else {
print $client "not_found\n";	print $client "not_found\n";
}	}
Line 1997 sub make_new_child {	Line 2055 sub make_new_child {
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) failed ".	." untie(GDBM) failed ".
"while attempting put\n";	"while attempting inc\n";
}	}
} else {	} else {
print $client "error: ".($!)	print $client "error: ".($!)
." tie(GDBM) Failed ".	." tie(GDBM) Failed ".
"while attempting put\n";	"while attempting inc\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 2213 sub make_new_child {	Line 2271 sub make_new_child {
my %hash;	my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
foreach my $key (@keys) {	foreach my $key (@keys) {
delete($hash{&unescape($key)});	delete($hash{$key});
}	}
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
Line 2328 sub make_new_child {	Line 2386 sub make_new_child {
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my %hash;	my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
study($regexp);
while (my ($key,$value) = each(%hash)) {	while (my ($key,$value) = each(%hash)) {
if ($regexp eq '.') {	if ($regexp eq '.') {
$qresult.=$key.'='.$value.'&';	$qresult.=$key.'='.$value.'&';
Line 2476 sub make_new_child {	Line 2533 sub make_new_child {
}	}
# ------------------------------------------------------------------- querysend	# ------------------------------------------------------------------- querysend
} elsif ($userinput =~ /^querysend/) {	} elsif ($userinput =~ /^querysend/) {
if(isClient) {	if (isClient) {
my ($cmd,$query,	my ($cmd,$query,
$arg1,$arg2,$arg3)=split(/\:/,$userinput);	$arg1,$arg2,$arg3)=split(/\:/,$userinput);
$query=~s/\n*$//g;	$query=~s/\n*$//g;
Line 2566 sub make_new_child {	Line 2623 sub make_new_child {
$qresult.=$key.'='.$descr.'&';	$qresult.=$key.'='.$descr.'&';
} else {	} else {
my $unescapeVal = &unescape($descr);	my $unescapeVal = &unescape($descr);
if (eval('$unescapeVal=~/$description/i')) {	if (eval('$unescapeVal=~/\Q$description\E/i')) {
$qresult.="$key=$descr&";	$qresult.="$key=$descr&";
}	}
}	}
Line 2721 sub make_new_child {	Line 2778 sub make_new_child {
Reply($client, "refused\n", $userinput);	Reply($client, "refused\n", $userinput);

}	}
	# ----------------------------------------------------------portfolio directory list (portls)
	} elsif ($userinput =~ /^portls/) {
	if(isClient) {
	my ($cmd,$uname,$udom)=split(/:/,$userinput);
	my $udir=propath($udom,$uname).'/userfiles/portfolio';
	my $dirLine='';
	my $dirContents='';
	if (opendir(LSDIR,$udir.'/')){
	while ($dirLine = readdir(LSDIR)){
	$dirContents = $dirContents.$dirLine.'<br />';
	}
	}else{
	$dirContents = "No directory found\n";
	}
	print $client $dirContents."\n";
	} else {
	Reply($client, "refused\n", $userinput);
	}

# -------------------------------------------------------------------------- ls	# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {	} elsif ($userinput =~ /^ls/) {
if(isClient) {	if(isClient) {
	my $obs;
	my $rights;
my ($cmd,$ulsdir)=split(/:/,$userinput);	my ($cmd,$ulsdir)=split(/:/,$userinput);
my $ulsout='';	my $ulsout='';
my $ulsfn;	my $ulsfn;
Line 2731 sub make_new_child {	Line 2809 sub make_new_child {
if(-d $ulsdir) {	if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {	while ($ulsfn=readdir(LSDIR)) {
	undef $obs, $rights;
my @ulsstats=stat($ulsdir.'/'.$ulsfn);	my @ulsstats=stat($ulsdir.'/'.$ulsfn);
$ulsout.=$ulsfn.'&'.	#We do some obsolete checking here
join('&',@ulsstats).':';	if(-e $ulsdir.'/'.$ulsfn.".meta") {
	open(FILE, $ulsdir.'/'.$ulsfn.".meta");
	my @obsolete=<FILE>;
	foreach my $obsolete (@obsolete) {
	if($obsolete =~ m\|(<obsolete>)(on)\|) { $obs = 1; }
	if($obsolete =~ m\|(<copyright>)(default)\|) { $rights = 1; }
	}
	}
	$ulsout.=$ulsfn.'&'.join('&',@ulsstats);
	if($obs eq '1') { $ulsout.="&1"; }
	else { $ulsout.="&0"; }
	if($rights eq '1') { $ulsout.="&1:"; }
	else { $ulsout.="&0:"; }
}	}
closedir(LSDIR);	closedir(LSDIR);
}	}
Line 2792 sub make_new_child {	Line 2883 sub make_new_child {
} else {	} else {
print $client "refused\n";	print $client "refused\n";
}	}
	#------------------------------- is auto-enrollment enabled?
	} elsif ($userinput =~/^autorun/) {
	if (isClient) {
	my $outcome = &localenroll::run();
	print $client "$outcome\n";
	} else {
	print $client "0\n";
	}
	#------------------------------- get official sections (for auto-enrollment).
	} elsif ($userinput =~/^autogetsections/) {
	if (isClient) {
	my ($cmd,$coursecode)=split(/:/,$userinput);
	my @secs = &localenroll::get_sections($coursecode);
	my $seclist = &escape(join(':',@secs));
	print $client "$seclist\n";
	} else {
	print $client "refused\n";
	}
	#----------------------- validate owner of new course section (for auto-enrollment).
	} elsif ($userinput =~/^autonewcourse/) {
	if (isClient) {
	my ($cmd,$course_id,$owner)=split(/:/,$userinput);
	my $outcome = &localenroll::new_course($course_id,$owner);
	print $client "$outcome\n";
	} else {
	print $client "refused\n";
	}
	#-------------- validate course section in schedule of classes (for auto-enrollment).
	} elsif ($userinput =~/^autovalidatecourse/) {
	if (isClient) {
	my ($cmd,$course_id)=split(/:/,$userinput);
	my $outcome=&localenroll::validate_courseID($course_id);
	print $client "$outcome\n";
	} else {
	print $client "refused\n";
	}
	#--------------------------- create password for new user (for auto-enrollment).
	} elsif ($userinput =~/^autocreatepassword/) {
	if (isClient) {
	my ($cmd,$authparam)=split(/:/,$userinput);
	my ($create_passwd,$authchk) = @_;
	($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam);
	print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";
	} else {
	print $client "refused\n";
	}
	#--------------------------- read and remove temporary files (for auto-enrollment).
	} elsif ($userinput =~/^autoretrieve/) {
	if (isClient) {
	my ($cmd,$filename) = split(/:/,$userinput);
	my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
	if ( (-e $source) && ($filename ne '') ) {
	my $reply = '';
	if (open(my $fh,$source)) {
	while (<$fh>) {
	chomp($_);
	$_ =~ s/^\s+//g;
	$_ =~ s/\s+$//g;
	$reply .= $_;
	}
	close($fh);
	print $client &escape($reply)."\n";
	# unlink($source);
	} else {
	print $client "error\n";
	}
	} else {
	print $client "error\n";
	}
	} else {
	print $client "refused\n";
	}
# ------------------------------------------------------------- unknown command	# ------------------------------------------------------------- unknown command

} else {	} else {
Line 2806 sub make_new_child {	Line 2969 sub make_new_child {
} else {	} else {
print $client "refused\n";	print $client "refused\n";
$client->close();	$client->close();
&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 ($clientname)</font>");	."Disconnect from $clientip ($clientname)</font>");


Line 2838 sub make_new_child {	Line 3001 sub make_new_child {
#	#
sub ManagePermissions	sub ManagePermissions
{	{
my $request = shift;
my $domain = shift;	my ($request, $domain, $user, $authtype) = @_;
my $user = shift;
my $authtype= shift;

# See if the request is of the form /$domain/_au	# See if the request is of the form /$domain/_au
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...	if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
Line 2858 sub ManagePermissions	Line 3019 sub ManagePermissions
#	#
sub GetAuthType	sub GetAuthType
{	{
my $domain = shift;
my $user = shift;	my ($domain, $user) = @_;

Debug("GetAuthType( $domain, $user ) \n");	Debug("GetAuthType( $domain, $user ) \n");
my $proname = &propath($domain, $user);	my $proname = &propath($domain, $user);
Line 2968 sub chatadd {	Line 3129 sub chatadd {
sub unsub {	sub unsub {
my ($fname,$clientip)=@_;	my ($fname,$clientip)=@_;
my $result;	my $result;
	my $unsubs = 0; # Number of successful unsubscribes:


	# An old way subscriptions were handled was to have a
	# subscription marker file:

	Debug("Attempting unlink of $fname.$clientname");
if (unlink("$fname.$clientname")) {	if (unlink("$fname.$clientname")) {
$result="ok\n";	$unsubs++; # Successful unsub via marker file.
} else {	}
$result="not_subscribed\n";
}	# The more modern way to do it is to have a subscription list
	# file:

if (-e "$fname.subscription") {	if (-e "$fname.subscription") {
my $found=&addline($fname,$clientname,$clientip,'');	my $found=&addline($fname,$clientname,$clientip,'');
if ($found) { $result="ok\n"; }	if ($found) {
	$unsubs++;
	}
	}

	# If either or both of these mechanisms succeeded in unsubscribing a
	# resource we can return ok:

	if($unsubs) {
	$result = "ok\n";
} else {	} else {
if ($result != "ok\n") { $result="not_subscribed\n"; }	$result = "not_subscribed\n";
}	}

return $result;	return $result;
}	}

Line 3100 sub make_passwd_file {	Line 3280 sub make_passwd_file {
}	}
} elsif ($umode eq 'unix') {	} elsif ($umode eq 'unix') {
{	{
	#
	# Don't allow the creation of privileged accounts!!! that would
	# be real bad!!!
	#
	my $uid = getpwnam($uname);
	if((defined $uid) && ($uid == 0)) {
	&logthis(">>>Attempted to create privilged account blocked");
	return "no_priv_account_error\n";
	}

my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";	my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
{	{
&Debug("Executing external: ".$execpath);	&Debug("Executing external: ".$execpath);

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

Removed from v.1.171
changed lines
	Added in v.1.199