loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.456 and 1.489.2.5

version 1.456, 2010/09/26 01:50:28	version 1.489.2.5, 2013/05/11 22:42:22
Line 15	Line 15
#	#
# LON-CAPA is distributed in the hope that it will be useful,	# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of	# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.	# GNU General Public License for more details.
#	#
Line 33 use strict;	Line 34 use strict;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use LONCAPA;	use LONCAPA;
use LONCAPA::Configuration;	use LONCAPA::Configuration;
	use LONCAPA::Lond;

use IO::Socket;	use IO::Socket;
use IO::File;	use IO::File;
Line 52 use LONCAPA::lonlocal;	Line 54 use LONCAPA::lonlocal;
use LONCAPA::lonssl;	use LONCAPA::lonssl;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Apache::lonnet;	use Apache::lonnet;
	use Mail::Send;

my $DEBUG = 0; # Non zero to enable debug log entries.	my $DEBUG = 0; # Non zero to enable debug log entries.

Line 90 my %managers; # Ip -> manager names	Line 93 my %managers; # Ip -> manager names

my %perlvar; # Will have the apache conf defined perl vars.	my %perlvar; # Will have the apache conf defined perl vars.

	my $dist;

#	#
# The hash below is used for command dispatching, and is therefore keyed on the request keyword.	# The hash below is used for command dispatching, and is therefore keyed on the request keyword.
# Each element of the hash contains a reference to an array that contains:	# Each element of the hash contains a reference to an array that contains:
Line 149 my @adderrors = ("ok",	Line 154 my @adderrors = ("ok",
my @installerrors = ("ok",	my @installerrors = ("ok",
"Initial user id of client not that of www",	"Initial user id of client not that of www",
"Usage error, not enough command line arguments",	"Usage error, not enough command line arguments",
"Source file name does not exist",	"Source filename does not exist",
"Destination file name does not exist",	"Destination filename does not exist",
"Some file operation failed",	"Some file operation failed",
"Invalid table filename."	"Invalid table filename."
);	);
Line 419 sub ReadManagerTable {	Line 424 sub ReadManagerTable {

my $tablename = $perlvar{'lonTabDir'}."/managers.tab";	my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
if (!open (MANAGERS, $tablename)) {	if (!open (MANAGERS, $tablename)) {
logthis('<font color="red">No manager table. Nobody can manage!!</font>');	my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
return;	if (&Apache::lonnet::is_LC_dns($hostname)) {
	&logthis('<font color="red">No manager table. Nobody can manage!!</font>');
	}
	return;
}	}
while(my $host = <MANAGERS>) {	while(my $host = <MANAGERS>) {
chomp($host);	chomp($host);
Line 445 sub ReadManagerTable {	Line 453 sub ReadManagerTable {
}	}
} else {	} else {
logthis('<font color="green"> existing host'." $host</font>\n");	logthis('<font color="green"> existing host'." $host</font>\n");
$managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if clumemeber	$managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if cluster memeber
}	}
}	}
}	}
Line 507 sub AdjustHostContents {	Line 515 sub AdjustHostContents {
my $me = $perlvar{'lonHostID'};	my $me = $perlvar{'lonHostID'};

foreach my $line (split(/\n/,$contents)) {	foreach my $line (split(/\n/,$contents)) {
if(!(($line eq "") \|\| ($line =~ /^ \#/) \|\| ($line =~ /^ $/))) {	if(!(($line eq "") \|\| ($line =~ /^ \#/) \|\| ($line =~ /^ $/) \|\|
	($line =~ /^\s*\^/))) {
chomp($line);	chomp($line);
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);	my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
if ($id eq $me) {	if ($id eq $me) {
Line 595 sub InstallFile {	Line 604 sub InstallFile {
#	#
# ConfigFileFromSelector: converts a configuration file selector	# ConfigFileFromSelector: converts a configuration file selector
# into a configuration file pathname.	# into a configuration file pathname.
# It's probably no longer necessary to preserve	# Supports the following file selectors:
# special handling of hosts or domain as those	# hosts, domain, dns_hosts, dns_domain
# files have been superceded by dns_hosts, dns_domain.
# The default action is just to prepend the directory
# and append .tab
#	#
#	#
# Parameters:	# Parameters:
Line 612 sub ConfigFileFromSelector {	Line 618 sub ConfigFileFromSelector {
my $tablefile;	my $tablefile;

my $tabledir = $perlvar{'lonTabDir'}.'/';	my $tabledir = $perlvar{'lonTabDir'}.'/';
if ($selector eq "hosts") {	if (($selector eq "hosts") \|\| ($selector eq "domain") \|\|
$tablefile = $tabledir."hosts.tab";	($selector eq "dns_hosts") \|\| ($selector eq "dns_domain")) {
} elsif ($selector eq "domain") {
$tablefile = $tabledir."domain.tab";
} else {
$tablefile = $tabledir.$selector.'.tab';	$tablefile = $tabledir.$selector.'.tab';
}	}
return $tablefile;	return $tablefile;

}	}
#	#
# PushFile: Called to do an administrative push of a file.	# PushFile: Called to do an administrative push of a file.
Line 646 sub PushFile {	Line 648 sub PushFile {
# supported:	# supported:
# hosts.tab ($filename eq host).	# hosts.tab ($filename eq host).
# domain.tab ($filename eq domain).	# domain.tab ($filename eq domain).
	# dns_hosts.tab ($filename eq dns_host).
	# dns_domain.tab ($filename eq dns_domain).
# Construct the destination filename or reject the request.	# Construct the destination filename or reject the request.
#	#
# lonManage is supposed to ensure this, however this session could be	# lonManage is supposed to ensure this, however this session could be
Line 677 sub PushFile {	Line 681 sub PushFile {
return "error:$!";	return "error:$!";
} else {	} else {
&logthis('<font color="green"> Installed new '.$tablefile	&logthis('<font color="green"> Installed new '.$tablefile
."</font>");	." - transaction by: $clientname ($clientip)</font>");
	my $adminmail = $perlvar{'lonAdmEMail'};
	my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
	if ($admindom ne '') {
	my %domconfig =
	&Apache::lonnet::get_dom('configuration',['contacts'],$admindom);
	if (ref($domconfig{'contacts'}) eq 'HASH') {
	if ($domconfig{'contacts'}{'adminemail'} ne '') {
	$adminmail = $domconfig{'contacts'}{'adminemail'};
	}
	}
	}
	if ($adminmail =~ /^[^\@]+\@[^\@]+$/) {
	my $msg = new Mail::Send;
	$msg->to($adminmail);
	$msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'});
	$msg->add('Content-type','text/plain; charset=UTF-8');
	if (my $fh = $msg->open()) {
	print $fh 'Update to '.$tablefile.' from Cluster Manager '.
	"$clientname ($clientip)\n";
	$fh->close;
	}
	}
}	}


# Indicate success:	# Indicate success:

return "ok";	return "ok";
Line 1121 sub establish_key_handler {	Line 1145 sub establish_key_handler {
sub load_handler {	sub load_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;



# Get the load average from /proc/loadavg and calculate it as a percentage of	# Get the load average from /proc/loadavg and calculate it as a percentage of
# the allowed load limit as set by the perl global variable lonLoadLim	# the allowed load limit as set by the perl global variable lonLoadLim

Line 1618 sub ls3_handler {	Line 1644 sub ls3_handler {
}	}
&register_handler("ls3", \&ls3_handler, 0, 1, 0);	&register_handler("ls3", \&ls3_handler, 0, 1, 0);

	sub read_lonnet_global {
	my ($cmd,$tail,$client) = @_;
	my $userinput = "$cmd:$tail";
	my $requested = &Apache::lonnet::thaw_unescape($tail);
	my $result;
	my %packagevars = (
	spareid => \%Apache::lonnet::spareid,
	perlvar => \%Apache::lonnet::perlvar,
	);
	my %limit_to = (
	perlvar => {
	lonOtherAuthen => 1,
	lonBalancer => 1,
	lonVersion => 1,
	lonSysEMail => 1,
	lonHostID => 1,
	lonRole => 1,
	lonDefDomain => 1,
	lonLoadLim => 1,
	lonUserLoadLim => 1,
	}
	);
	if (ref($requested) eq 'HASH') {
	foreach my $what (keys(%{$requested})) {
	my $response;
	my $items = {};
	if (exists($packagevars{$what})) {
	if (ref($limit_to{$what}) eq 'HASH') {
	foreach my $varname (keys(%{$packagevars{$what}})) {
	if ($limit_to{$what}{$varname}) {
	$items->{$varname} = $packagevars{$what}{$varname};
	}
	}
	} else {
	$items = $packagevars{$what};
	}
	if ($what eq 'perlvar') {
	if (!exists($packagevars{$what}{'lonBalancer'})) {
	if ($dist =~ /^(centos\|rhes\|fedora\|scientific)/) {
	my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf');
	if (ref($othervarref) eq 'HASH') {
	$items->{'lonBalancer'} = $othervarref->{'lonBalancer'};
	}
	}
	}
	}
	$response = &Apache::lonnet::freeze_escape($items);
	}
	$result .= &escape($what).'='.$response.'&';
	}
	}
	$result =~ s/\&$//;
	&Reply($client,\$result,$userinput);
	return 1;
	}
	&register_handler("readlonnetglobal", \&read_lonnet_global, 0, 1, 0);

	sub server_devalidatecache_handler {
	my ($cmd,$tail,$client) = @_;
	my $userinput = "$cmd:$tail";
	my ($name,$id) = map { &unescape($_); } split(/:/,$tail);
	&Apache::lonnet::devalidate_cache_new($name,$id);
	my $result = 'ok';
	&Reply($client,\$result,$userinput);
	return 1;
	}
	&register_handler("devalidatecache", \&server_devalidatecache_handler, 0, 1, 0);

sub server_timezone_handler {	sub server_timezone_handler {
my ($cmd,$tail,$client) = @_;	my ($cmd,$tail,$client) = @_;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";
Line 1666 sub server_homeID_handler {	Line 1760 sub server_homeID_handler {
}	}
&register_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0);	&register_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0);

	sub server_distarch_handler {
	my ($cmd,$tail,$client) = @_;
	my $userinput = "$cmd:$tail";
	my $reply = &distro_and_arch();
	&Reply($client,\$reply,$userinput);
	return 1;
	}
	&register_handler("serverdistarch", \&server_distarch_handler, 0, 1, 0);

# Process a reinit request. Reinit requests that either	# Process a reinit request. Reinit requests that either
# lonc or lond be reinitialized so that an updated	# lonc or lond be reinitialized so that an updated
# host.tab or domain.tab can be processed.	# host.tab or domain.tab can be processed.
Line 1971 sub add_user_handler {	Line 2074 sub add_user_handler {
."makeuser";	."makeuser";
}	}
unless ($fperror) {	unless ($fperror) {
my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);	my $result=&make_passwd_file($uname,$udom,$umode,$npass, $passfilename);
&Reply($client,\$result, $userinput); #BUGBUG - could be fail	&Reply($client,\$result, $userinput); #BUGBUG - could be fail
} else {	} else {
&Failure($client, \$fperror, $userinput);	&Failure($client, \$fperror, $userinput);
Line 2046 sub change_authentication_handler {	Line 2149 sub change_authentication_handler {
&Failure($client, \$result);	&Failure($client, \$result);
}	}
} else {	} else {
my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);	my $result=&make_passwd_file($uname,$udom,$umode,$npass,$passfilename);
#	#
# If the current auth mode is internal, and the old auth mode was	# If the current auth mode is internal, and the old auth mode was
# unix, or krb*, and the user is an author for this domain,	# unix, or krb*, and the user is an author for this domain,
Line 2246 sub fetch_user_file_handler {	Line 2349 sub fetch_user_file_handler {

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 $clientprotocol=$Apache::lonnet::protocol{$clientname};
	$clientprotocol = 'http' if ($clientprotocol ne 'https');
	my $clienthost = &Apache::lonnet::hostname($clientname);
	my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;
my $response;	my $response;
Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");	Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
alarm(120);	alarm(120);
Line 2268 sub fetch_user_file_handler {	Line 2374 sub fetch_user_file_handler {
unlink($transname);	unlink($transname);
&Failure($client, "failed\n", $userinput);	&Failure($client, "failed\n", $userinput);
} else {	} else {
	if ($fname =~ /^default.+\.(page\|sequence)$/) {
	my ($major,$minor) = split(/\./,$clientversion);
	if (($major < 2) \|\| ($major == 2 && $minor < 11)) {
	my $now = time;
	&Apache::lonnet::do_cache_new('crschange',$udom.'_'.$uname,$now,600);
	my $key = &escape('internal.contentchange');
	my $what = "$key=$now";
	my $hashref = &tie_user_hash($udom,$uname,'environment',
	&GDBM_WRCREAT(),"P",$what);
	if ($hashref) {
	$hashref->{$key}=$now;
	if (!&untie_user_hash($hashref)) {
	&logthis("error: ".($!+0)." untie (GDBM) failed ".
	"when updating internal.contentchange");
	}
	}
	}
	}
&Reply($client, "ok\n", $userinput);	&Reply($client, "ok\n", $userinput);
}	}
}	}
Line 2422 sub user_has_session_handler {	Line 2546 sub user_has_session_handler {

my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));	my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));

&logthis("Looking for $udom $uname");
opendir(DIR,$perlvar{'lonIDsDir'});	opendir(DIR,$perlvar{'lonIDsDir'});
my $filename;	my $filename;
while ($filename=readdir(DIR)) {	while ($filename=readdir(DIR)) {
Line 3141 sub dump_profile_database {	Line 3264 sub dump_profile_database {
# that is matched against	# that is matched against
# database keywords to do	# database keywords to do
# selective dumps.	# selective dumps.
	# range - optional range of entries
	# e.g., 10-20 would return the
	# 10th to 19th items, etc.
# $client - Channel open on the client.	# $client - Channel open on the client.
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.
Line 3150 sub dump_profile_database {	Line 3276 sub dump_profile_database {
sub dump_with_regexp {	sub dump_with_regexp {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;

	my $res = LONCAPA::Lond::dump_with_regexp($tail, $clientversion);

my $userinput = "$cmd:$tail";	if ($res =~ /^error:/) {
	&Failure($client, \$res, "$cmd:$tail");
my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);
if (defined($regexp)) {
$regexp=&unescape($regexp);
} else {
$regexp='.';
}
my ($start,$end);
if (defined($range)) {
if ($range =~/^(\d+)\-(\d+)$/) {
($start,$end) = ($1,$2);
} elsif ($range =~/^(\d+)$/) {
($start,$end) = (0,$1);
} else {
undef($range);
}
}
my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_READER());
my $skipcheck;
if ($hashref) {
my $qresult='';
my $count=0;
if ($extra ne '') {
$extra = &Apache::lonnet::thaw_unescape($extra);
$skipcheck = $extra->{'skipcheck'};
}
my @ids = &Apache::lonnet::current_machine_ids();
my (%homecourses,$major,$minor,$now);
if (($namespace eq 'roles') && (!$skipcheck)) {
my $loncaparev = $clientversion;
if ($loncaparev eq '') {
$loncaparev = $Apache::lonnet::loncaparevs{$clientname};
}
if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
$major = $1;
$minor = $2;
}
$now = time;
}
while (my ($key,$value) = each(%$hashref)) {
if ($namespace eq 'roles') {
if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc\|co\|in\|ta\|ep\|ad\|st\|cr)$}) {
my $cdom = $1;
my $cnum = $2;
unless ($skipcheck) {
next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,$minor,
$now,\%homecourses,\@ids));
}
}
}
if ($regexp eq '.') {
$count++;
if (defined($range) && $count >= $end) { last; }
if (defined($range) && $count < $start) { next; }
$qresult.=$key.'='.$value.'&';
} else {
my $unescapeKey = &unescape($key);
if (eval('$unescapeKey=~/$regexp/')) {
$count++;
if (defined($range) && $count >= $end) { last; }
if (defined($range) && $count < $start) { next; }
$qresult.="$key=$value&";
}
}
}
if (&untie_user_hash($hashref)) {
if (($namespace eq 'roles') && (!$skipcheck)) {
if (keys(%homecourses) > 0) {
$qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count,
$range,$start,$end,$major,$minor);
}
}
chop($qresult);
&Reply($client, \$qresult, $userinput);
} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting dump\n", $userinput);
}
} else {	} else {
&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".	&Reply($client, \$res, "$cmd:$tail");
"while attempting dump\n", $userinput);
}	}

return 1;	return 1;
Line 3891 sub dump_course_id_handler {	Line 3939 sub dump_course_id_handler {
$creationcontext = '.';	$creationcontext = '.';
}	}
my $unpack = 1;	my $unpack = 1;
if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&	if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' &&
$typefilter eq '.') {	$typefilter eq '.') {
$unpack = 0;	$unpack = 0;
}	}
Line 4275 sub put_domain_handler {	Line 4323 sub put_domain_handler {
sub get_domain_handler {	sub get_domain_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;


my $userinput = "$client:$tail";	my $userinput = "$client:$tail";

my ($udom,$namespace,$what)=split(/:/,$tail,3);	my ($udom,$namespace,$what)=split(/:/,$tail,3);
Line 4419 sub get_id_handler {	Line 4468 sub get_id_handler {
sub put_dcmail_handler {	sub put_dcmail_handler {
my ($cmd,$tail,$client) = @_;	my ($cmd,$tail,$client) = @_;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";


my ($udom,$what)=split(/:/,$tail);	my ($udom,$what)=split(/:/,$tail);
chomp($what);	chomp($what);
my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());	my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
Line 4946 sub validate_instcode_handler {	Line 4996 sub validate_instcode_handler {
my ($dom,$instcode,$owner) = split(/:/, $tail);	my ($dom,$instcode,$owner) = split(/:/, $tail);
$instcode = &unescape($instcode);	$instcode = &unescape($instcode);
$owner = &unescape($owner);	$owner = &unescape($owner);
my ($outcome,$description) =	my ($outcome,$description,$credits) =
&localenroll::validate_instcode($dom,$instcode,$owner);	&localenroll::validate_instcode($dom,$instcode,$owner);
my $result = &escape($outcome).'&'.&escape($description);	my $result = &escape($outcome).'&'.&escape($description).'&'.
	&escape($credits);
&Reply($client, \$result, $userinput);	&Reply($client, \$result, $userinput);

return 1;	return 1;
Line 5001 sub get_sections_handler {	Line 5052 sub get_sections_handler {
sub validate_course_owner_handler {	sub validate_course_owner_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";
my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);	my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail);

$owner = &unescape($owner);	$owner = &unescape($owner);
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);	$coowners = &unescape($coowners);
	my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);
&Reply($client, \$outcome, $userinput);	&Reply($client, \$outcome, $userinput);


Line 5992 if (-e $pidfile) {	Line 6044 if (-e $pidfile) {
$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},	$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Proto => 'tcp',	Proto => 'tcp',
Reuse => 1,	ReuseAddr => 1,
Listen => 10 )	Listen => 10 )
or die "making socket: $@\n";	or die "making socket: $@\n";

Line 6055 sub HUPSMAN { # sig	Line 6107 sub HUPSMAN { # sig
# a setuid perl script that can be root for us to do this job.	# a setuid perl script that can be root for us to do this job.
#	#
sub ReloadApache {	sub ReloadApache {
my $execdir = $perlvar{'lonDaemons'};	# --------------------------- Handle case of another apachereload process (locking)
my $script = $execdir."/apachereload";	if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) {
system($script);	my $execdir = $perlvar{'lonDaemons'};
	my $script = $execdir."/apachereload";
	system($script);
	unlink('/tmp/lock_apachereload'); # Remove the lock file.
	}
}	}

#	#
Line 6230 sub logstatus {	Line 6286 sub logstatus {
sub initnewstatus {	sub initnewstatus {
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");
my $now=time;	my $now=time();
my $local=localtime($now);	my $local=localtime($now);
print $fh "LOND status $local - parent $$\n\n";	print $fh "LOND status $local - parent $$\n\n";
opendir(DIR,"$docdir/lon-status/londchld");	opendir(DIR,"$docdir/lon-status/londchld");
Line 6321 $SIG{USR2} = \&UpdateHosts;	Line 6377 $SIG{USR2} = \&UpdateHosts;
&Apache::lonnet::load_hosts_tab();	&Apache::lonnet::load_hosts_tab();
my %iphost = &Apache::lonnet::get_iphost(1);	my %iphost = &Apache::lonnet::get_iphost(1);

my $dist=`$perlvar{'lonDaemons'}/distprobe`;	$dist=`$perlvar{'lonDaemons'}/distprobe`;

	my $arch = `uname -i`;
	chomp($arch);
	if ($arch eq 'unknown') {
	$arch = `uname -m`;
	chomp($arch);
	}

# --------------------------------------------------------------	# --------------------------------------------------------------
# Accept connections. When a connection comes in, it is validated	# Accept connections. When a connection comes in, it is validated
Line 6380 sub make_new_child {	Line 6443 sub make_new_child {
or die "Can't unblock SIGINT for fork: $!\n";	or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = $clientip;	$children{$pid} = $clientip;
&status('Started child '.$pid);	&status('Started child '.$pid);
	close($client);
return;	return;
} else {	} else {
# Child can not return from this subroutine.	# Child can not return from this subroutine.
Line 6388 sub make_new_child {	Line 6452 sub make_new_child {
#don't get intercepted	#don't get intercepted
$SIG{USR1}= \&logstatus;	$SIG{USR1}= \&logstatus;
$SIG{ALRM}= \&timeout;	$SIG{ALRM}= \&timeout;
	#
	# Block sigpipe as it gets thrownon socket disconnect and we want to
	# deal with that as a read faiure instead.
	#
	my $blockset = POSIX::SigSet->new(SIGPIPE);
	sigprocmask(SIG_BLOCK, $blockset);

$lastlog='Forked ';	$lastlog='Forked ';
$status='Forked';	$status='Forked';

Line 6399 sub make_new_child {	Line 6470 sub make_new_child {
#---------------------------------------------------- kerberos 5 initialization	#---------------------------------------------------- kerberos 5 initialization
&Authen::Krb5::init_context();	&Authen::Krb5::init_context();
unless (($dist eq 'fedora5') \|\| ($dist eq 'fedora4') \|\|	unless (($dist eq 'fedora5') \|\| ($dist eq 'fedora4') \|\|
($dist eq 'fedora6') \|\| ($dist eq 'suse9.3')) {	($dist eq 'fedora6') \|\| ($dist eq 'suse9.3') \|\|
	($dist eq 'suse12.2') \|\| ($dist eq 'suse12.3')) {
&Authen::Krb5::init_ets();	&Authen::Krb5::init_ets();
}	}

Line 6445 sub make_new_child {	Line 6517 sub make_new_child {
# If the remote is attempting a local init... give that a try:	# If the remote is attempting a local init... give that a try:
#	#
(my $i, my $inittype, $clientversion) = split(/:/, $remotereq);	(my $i, my $inittype, $clientversion) = split(/:/, $remotereq);
	# For LON-CAPA 2.9, the client session will have sent its LON-CAPA
	# version when initiating the connection. For LON-CAPA 2.8 and older,
	# the version is retrieved from the global %loncaparevs in lonnet.pm.
	# $clientversion contains path to keyfile if $inittype eq 'local'
	# it's overridden below in this case
	$clientversion \|\|= $Apache::lonnet::loncaparevs{$clientname};

# If the connection type is ssl, but I didn't get my	# If the connection type is ssl, but I didn't get my
# certificate files yet, then I'll drop back to	# certificate files yet, then I'll drop back to
Line 6588 sub is_author {	Line 6666 sub is_author {

# Author role should show up as a key /domain/_au	# Author role should show up as a key /domain/_au

my $key = "/$domain/_au";
my $value;	my $value;
if (defined($hashref)) {	if ($hashref) {
$value = $hashref->{$key};
}

if(defined($value)) {	my $key = "/$domain/_au";
&Debug("$user @ $domain is an author");	if (defined($hashref)) {
	$value = $hashref->{$key};
	if(!untie_user_hash($hashref)) {
	return 'error: ' . ($!+0)." untie (GDBM) Failed";
	}
	}

	if(defined($value)) {
	&Debug("$user @ $domain is an author");
	}
	} else {
	return 'error: '.($!+0)." tie (GDBM) Failed";
}	}

return defined($value);	return defined($value);
}	}
#	#
# Checks to see if the input roleput request was to set	# Checks to see if the input roleput request was to set
# an author role. If so, invokes the lchtmldir script to set	# an author role. If so, creates construction space
# up a correct public_html
# Parameters:	# Parameters:
# request - The request sent to the rolesput subchunk.	# request - The request sent to the rolesput subchunk.
# We're looking for /domain/_au	# We're looking for /domain/_au
Line 6613 sub is_author {	Line 6698 sub is_author {
#	#
sub manage_permissions {	sub manage_permissions {
my ($request, $domain, $user, $authtype) = @_;	my ($request, $domain, $user, $authtype) = @_;

&Debug("manage_permissions: $request $domain $user $authtype");

# See if the request is of the form /$domain/_au	# See if the request is of the form /$domain/_au
if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...	if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
my $execdir = $perlvar{'lonDaemons'};	my $path=$perlvar{'lonDocRoot'}."/priv/$domain";
my $userhome= "/home/$user" ;	unless (-e $path) {
&logthis("system $execdir/lchtmldir $userhome $user $authtype");	mkdir($path);
&Debug("Setting homedir permissions for $userhome");	}
system("$execdir/lchtmldir $userhome $user $authtype");	unless (-e $path.'/'.$user) {
	mkdir($path.'/'.$user);
	}
}	}
}	}

Line 7111 sub subscribe {	Line 7195 sub subscribe {
# the metadata	# the metadata
unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }	unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
$fname=~s/\/home\/httpd\/html\/res/raw/;	$fname=~s/\/home\/httpd\/html\/res/raw/;
$fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;	my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}};
	$protocol = 'http' if ($protocol ne 'https');
	$fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
$result="$fname\n";	$result="$fname\n";
}	}
} else {	} else {
Line 7153 sub change_unix_password {	Line 7239 sub change_unix_password {


sub make_passwd_file {	sub make_passwd_file {
my ($uname, $umode,$npass,$passfilename)=@_;	my ($uname,$udom,$umode,$npass,$passfilename)=@_;
my $result="ok";	my $result="ok";
if ($umode eq 'krb4' or $umode eq 'krb5') {	if ($umode eq 'krb4' or $umode eq 'krb5') {
{	{
Line 7194 sub make_passwd_file {	Line 7280 sub make_passwd_file {
#	#
my $uid = getpwnam($uname);	my $uid = getpwnam($uname);
if((defined $uid) && ($uid == 0)) {	if((defined $uid) && ($uid == 0)) {
&logthis(">>>Attempted to create privilged account blocked");	&logthis(">>>Attempt to create privileged account blocked");
return "no_priv_account_error\n";	return "no_priv_account_error\n";
}	}

Line 7206 sub make_passwd_file {	Line 7292 sub make_passwd_file {
&Debug("user = ".$uname.", Password =". $npass);	&Debug("user = ".$uname.", Password =". $npass);
my $se = IO::File->new("\|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");	my $se = IO::File->new("\|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
print $se "$uname\n";	print $se "$uname\n";
	print $se "$udom\n";
print $se "$npass\n";	print $se "$npass\n";
print $se "$npass\n";	print $se "$npass\n";
print $se "$lc_error_file\n"; # Status -> unique file.	print $se "$lc_error_file\n"; # Status -> unique file.
Line 7299 sub get_usersession_config {	Line 7386 sub get_usersession_config {
return;	return;
}	}

sub releasereqd_check {
my ($cnum,$cdom,$key,$value,$major,$minor,$now,$homecourses,$ids) = @_;
my $home = &Apache::lonnet::homeserver($cnum,$cdom);
return if ($home eq 'no_host');
my ($reqdmajor,$reqdminor,$displayrole);
if ($cnum =~ /$LONCAPA::match_community/) {
if ($major eq '' && $minor eq '') {
return unless ((ref($ids) eq 'ARRAY') &&
(grep(/^\Q$home\E$/,@{$ids})));
} else {
$reqdmajor = 2;
$reqdminor = 9;
return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
}
}
my ($role,$end,$start) = split(/_/,$value);
if (!$end \|\| $end > $now) {
my $hashid = $cdom.':'.$cnum;
my ($courseinfo,$cached) =
&Apache::lonnet::is_cached_new('courseinfo',$hashid);
if (defined($cached)) {
if (ref($courseinfo) eq 'HASH') {
if (exists($courseinfo->{'releaserequired'})) {
my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
}
}
} else {
if (ref($ids) eq 'ARRAY') {
if (grep(/^\Q$home\E$/,@{$ids})) {
if (ref($homecourses) eq 'HASH') {
if (ref($homecourses->{$hashid}) eq 'ARRAY') {
push(@{$homecourses->{$hashid}},{$key=>$value});
} else {
$homecourses->{$hashid} = [{$key=>$value}];
}
}
return;
}
}
my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
if (ref($courseinfo) eq 'HASH') {
if (exists($courseinfo->{'releaserequired'})) {
my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
}
}
}
}
return 1;
}

sub get_courseinfo_hash {
my ($cnum,$cdom,$home) = @_;
my $hashid = $cdom.':'.$cnum;
my %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
}
return;
}

sub check_homecourses {
my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
my ($result,%addtocache);
if (ref($homecourses) eq 'HASH') {
my %okcourses;
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {
my $unesc_key = &unescape($key);
next if ($unesc_key =~ /^lasttime:/);
my $items = &Apache::lonnet::thaw_unescape($value);
if (ref($items) eq 'HASH') {
my $hashid = $unesc_key;
$hashid =~ s/_/:/;
&Apache::lonnet::do_cache_new('courseinfo',$hashid,$items,600);
if (ref($homecourses->{$hashid}) eq 'ARRAY') {
my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
$okcourses{$hashid} = 1;
}
}
}
}
unless (&untie_domain_hash($hashref)) {
&logthis('Failed to untie tied hash for nohist_courseids.db');
}
} else {
&logthis('Failed to tie hash for nohist_courseids.db');
return;
}
foreach my $hashid (keys(%okcourses)) {
if (ref($homecourses->{$hashid}) eq 'ARRAY') {
foreach my $role (@{$homecourses->{$hashid}}) {
if (ref($role) eq 'HASH') {
while (my ($key,$value) = each(%{$role})) {
if ($regexp eq '.') {
$count++;
if (defined($range) && $count >= $end) { last; }
if (defined($range) && $count < $start) { next; }
$result.=$key.'='.$value.'&';
} else {
my $unescapeKey = &unescape($key);
if (eval('$unescapeKey=~/$regexp/')) {
$count++;
if (defined($range) && $count >= $end) { last; }
if (defined($range) && $count < $start) { next; }
$result.="$key=$value&";
}
}
}
}
}
}
}
}
return $result;
}

sub useable_role {	sub distro_and_arch {
my ($reqdmajor,$reqdminor,$major,$minor) = @_;	return $dist.':'.$arch;
if ($reqdmajor ne '' && $reqdminor ne '') {
return if (($major eq '' && $minor eq '') \|\|
($major < $reqdmajor) \|\|
(($major == $reqdmajor) && ($minor < $reqdminor)));
}
return 1;
}	}

# ----------------------------------- POD (plain old documentation, CPAN style)	# ----------------------------------- POD (plain old documentation, CPAN style)
Line 7636 Place in B<logs/lond.log>	Line 7598 Place in B<logs/lond.log>

stores hash in namespace	stores hash in namespace

=item rolesputy	=item rolesput

put a role into a user's environment	put a role into a user's environment

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

Removed from v.1.456
changed lines
	Added in v.1.489.2.5