loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.468 and 1.492

version 1.468, 2011/01/11 10:32:00	version 1.492, 2012/04/26 19:51:40
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 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 1620 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 1668 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 1806 sub authenticate_handler {	Line 1907 sub authenticate_handler {
if (ref($hostedsession) eq 'HASH') {	if (ref($hostedsession) eq 'HASH') {
$hosted = $hostedsession->{'hosted'};	$hosted = $hostedsession->{'hosted'};
}	}
my $loncaparev = $clientversion;
if ($loncaparev eq '') {
$loncaparev = $Apache::lonnet::loncaparevs{$clientname};
}
$canhost = &Apache::lonnet::can_host_session($udom,$clientname,	$canhost = &Apache::lonnet::can_host_session($udom,$clientname,
$loncaparev,	$clientversion,
$remote,$hosted);	$remote,$hosted);
}	}
}	}
Line 1973 sub add_user_handler {	Line 2070 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 2048 sub change_authentication_handler {	Line 2145 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 2248 sub fetch_user_file_handler {	Line 2345 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 3142 sub dump_profile_database {	Line 3242 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 3151 sub dump_profile_database {	Line 3254 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, $clientname, $clientversion);
my $userinput = "$cmd:$tail";
	if ($res =~ /^error:/) {
my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);	Failure($client, \$res, "$cmd:$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) {
my ($role,$end,$start) = split(/\_/,$value);
if (!$end \|\| $end > $now) {
next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
$minor,\%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 3895 sub dump_course_id_handler {	Line 3917 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 5007 sub get_sections_handler {	Line 5029 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 5998 if (-e $pidfile) {	Line 6021 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 6061 sub HUPSMAN { # sig	Line 6084 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 6174 sub Debug {	Line 6201 sub Debug {
# reply - Text to send to client.	# reply - Text to send to client.
# request - Original request from client.	# request - Original request from client.
#	#
	#NOTE $reply must be terminated by exactly one \n. If $reply is a reference
	#this is done automatically ($$reply must not contain any \n in this case).
	#If $reply is a string the caller has to ensure this.
sub Reply {	sub Reply {
my ($fd, $reply, $request) = @_;	my ($fd, $reply, $request) = @_;
if (ref($reply)) {	if (ref($reply)) {
Line 6327 $SIG{USR2} = \&UpdateHosts;	Line 6357 $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 6459 sub make_new_child {	Line 6496 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 \|\|= $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 6602 sub is_author {	Line 6643 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 6627 sub is_author {	Line 6675 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 7125 sub subscribe {	Line 7172 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 7167 sub change_unix_password {	Line 7216 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 7208 sub make_passwd_file {	Line 7257 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 7220 sub make_passwd_file {	Line 7269 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 7313 sub get_usersession_config {	Line 7363 sub get_usersession_config {
return;	return;
}	}

sub releasereqd_check {
my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;	#
my $home = &Apache::lonnet::homeserver($cnum,$cdom);	# get_courseinfo_hash() is used to retrieve course information from the db
return if ($home eq 'no_host');	# file: nohist_courseids.db for a course for which the current server is not
my ($reqdmajor,$reqdminor,$displayrole);	# the home server.
if ($cnum =~ /$LONCAPA::match_community/) {	#
if ($major eq '' && $minor eq '') {	# A hash of a hash will be retrieved. The outer hash contains a single key --
return unless ((ref($ids) eq 'ARRAY') &&	# courseID -- for the course for which the data are being requested.
(grep(/^\Q$home\E$/,@{$ids})));	# The contents of the inner hash, for that single item in the outer hash
} else {	# are returned (and cached in memcache for 10 minutes).
$reqdmajor = 2;	#
$reqdminor = 9;
return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
}
}
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));
}
} else {
return;
}
}
return 1;
}

sub get_courseinfo_hash {	sub get_courseinfo_hash {
my ($cnum,$cdom,$home) = @_;	my ($cnum,$cdom,$home) = @_;
Line 7389 sub get_courseinfo_hash {	Line 7400 sub get_courseinfo_hash {
return;	return;
}	}

sub check_homecourses {
my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
my ($result,%addtocache);
my $yesterday = time - 24*3600;
if (ref($homecourses) eq 'HASH') {
my (%okcourses,%courseinfo,%recent);
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
if ($hashref) {
while (my ($key,$value) = each(%$hashref)) {
my $unesc_key = &unescape($key);
if ($unesc_key =~ /^lasttime:(\w+)$/) {
my $cid = $1;
$cid =~ s/_/:/;
if ($value > $yesterday ) {
$recent{$cid} = 1;
}
next;
}
my $items = &Apache::lonnet::thaw_unescape($value);
if (ref($items) eq 'HASH') {
my $hashid = $unesc_key;
$hashid =~ s/_/:/;
$courseinfo{$hashid} = $items;
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(%recent)) {
my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
unless ($cached) {
&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
}
}
foreach my $hashid (keys(%{$homecourses})) {
next if ($recent{$hashid});
&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
}
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 7799 Authen::Krb5	Line 7729 Authen::Krb5

=head1 COREQUISITES	=head1 COREQUISITES

	none

=head1 OSNAMES	=head1 OSNAMES

linux	linux
Line 7886 or the CA's certificate in the call to l	Line 7818 or the CA's certificate in the call to l
<error> is the textual reason this failed. Usual reasons:	<error> is the textual reason this failed. Usual reasons:

=over 2	=over 2

=item Apache config file for loncapa incorrect:	=item Apache config file for loncapa incorrect:

one of the variables	one of the variables
lonCertificateDirectory, lonnetCertificateAuthority, or lonnetCertificate	lonCertificateDirectory, lonnetCertificateAuthority, or lonnetCertificate
undefined or incorrect	undefined or incorrect
Line 8007 Could not rewrite the	Line 7939 Could not rewrite the
internal password file for a user	internal password file for a user

=item Result of password change for <user> : <result>	=item Result of password change for <user> : <result>

A unix password change for <user> was attempted	A unix password change for <user> was attempted
and the pipe returned <result>	and the pipe returned <result>

Line 8036 lond has been asked to exit by its clien	Line 7968 lond has been asked to exit by its clien
client systemand <input> is the full exit command sent to the server.	client systemand <input> is the full exit command sent to the server.

=item Red CRITICAL: ABNORMAL EXIT. child <pid> for server <hostname> died through a crass with this error->[<message>].	=item Red CRITICAL: ABNORMAL EXIT. child <pid> for server <hostname> died through a crass with this error->[<message>].

A lond child terminated. NOte that this termination can also occur when the	A lond child terminated. NOte that this termination can also occur when the
child receives the QUIT or DIE signals. <pid> is the process id of the child,	child receives the QUIT or DIE signals. <pid> is the process id of the child,
<hostname> the host lond is working for, and <message> the reason the child died	<hostname> the host lond is working for, and <message> the reason the child died
Line 8120 file when sent it's USR1 signal. That p	Line 8052 file when sent it's USR1 signal. That p
assumed to be hung in some un-fixable way.	assumed to be hung in some un-fixable way.

=item Finished checking children	=item Finished checking children

Master processs's USR1 processing is cojmplete.	Master processs's USR1 processing is cojmplete.

=item (Red) CRITICAL: ------- Starting ------	=item (Red) CRITICAL: ------- Starting ------
Line 8134 Started a new child process for <client>	Line 8066 Started a new child process for <client>
connected to the child. This was as a result of a TCP/IP connection from a client.	connected to the child. This was as a result of a TCP/IP connection from a client.

=item Unable to determine who caller was, getpeername returned nothing	=item Unable to determine who caller was, getpeername returned nothing

In child process initialization. either getpeername returned undef or	In child process initialization. either getpeername returned undef or
a zero sized object was returned. Processing continues, but in my opinion,	a zero sized object was returned. Processing continues, but in my opinion,
this should be cause for the child to exit.	this should be cause for the child to exit.
Line 8145 In child process initialization. The pe	Line 8077 In child process initialization. The pe
The client address is stored as "Unavailable" and processing continues.	The client address is stored as "Unavailable" and processing continues.

=item (Yellow) INFO: Connection <ip> <name> connection type = <type>	=item (Yellow) INFO: Connection <ip> <name> connection type = <type>

In child initialization. A good connectionw as received from <ip>.	In child initialization. A good connectionw as received from <ip>.

=over 2	=over 2
Line 8195 The client (<client> is the peer's name	Line 8127 The client (<client> is the peer's name
negotiated an SSL connection with this child process.	negotiated an SSL connection with this child process.

=item (Green) Successful insecure authentication with <client>	=item (Green) Successful insecure authentication with <client>


The client has successfully negotiated an insecure connection withthe child process.	The client has successfully negotiated an insecure connection withthe child process.

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

Removed from v.1.468
changed lines
	Added in v.1.492