loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.467.2.4 and 1.489.2.2

version 1.467.2.4, 2011/06/12 00:08:01	version 1.489.2.2, 2012/10/06 14:44:50
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 91 my %managers; # Ip -> manager names	Line 92 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 600 sub InstallFile {	Line 603 sub InstallFile {
#	#
# ConfigFileFromSelector: converts a configuration file selector	# ConfigFileFromSelector: converts a configuration file selector
# into a configuration file pathname.	# into a configuration file pathname.
# Supports the following file selectors:	# Supports the following file selectors:
# hosts, domain, dns_hosts, dns_domain	# hosts, domain, dns_hosts, dns_domain
#	#
#	#
# Parameters:	# Parameters:
Line 614 sub ConfigFileFromSelector {	Line 617 sub ConfigFileFromSelector {
my $tablefile;	my $tablefile;

my $tabledir = $perlvar{'lonTabDir'}.'/';	my $tabledir = $perlvar{'lonTabDir'}.'/';
if (($selector eq "hosts") \|\| ($selector eq "domain") \|\|	if (($selector eq "hosts") \|\| ($selector eq "domain") \|\|
($selector eq "dns_hosts") \|\| ($selector eq "dns_domain")) {	($selector eq "dns_hosts") \|\| ($selector eq "dns_domain")) {
$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 {
# 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_hosts.tab ($filename eq dns_host).
# dns_domain.tab ($filename eq dns_domain).	# 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 679 sub PushFile {
.$tablefile." $! </font>");	.$tablefile." $! </font>");
return "error:$!";	return "error:$!";
} else {	} else {
&logthis('<font color="green"> Installed new '.$tablefile	&logthis('<font color="green"> Installed new '.$tablefile
." - transaction by: $clientname ($clientip)</font>");	." - transaction by: $clientname ($clientip)</font>");
my $adminmail = $perlvar{'lonAdmEMail'};	my $adminmail = $perlvar{'lonAdmEMail'};
my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});	my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
if ($admindom ne '') {	if ($admindom ne '') {
Line 1641 sub ls3_handler {	Line 1643 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 2003 sub add_user_handler {	Line 2073 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 2078 sub change_authentication_handler {	Line 2148 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 2278 sub fetch_user_file_handler {	Line 2348 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 2300 sub fetch_user_file_handler {	Line 2373 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 3172 sub dump_profile_database {	Line 3263 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 3184 sub dump_with_regexp {	Line 3278 sub dump_with_regexp {

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

my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);	my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);
if (defined($regexp)) {	if (defined($regexp)) {
$regexp=&unescape($regexp);	$regexp=&unescape($regexp);
} else {	} else {
Line 3202 sub dump_with_regexp {	Line 3296 sub dump_with_regexp {
}	}
my $hashref = &tie_user_hash($udom, $uname, $namespace,	my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_READER());	&GDBM_READER());
my $skipcheck;
if ($hashref) {	if ($hashref) {
my $qresult='';	my $qresult='';
my $count=0;	my $count=0;
if ($extra ne '') {	#
$extra = &Apache::lonnet::thaw_unescape($extra);	# When dump is for roles.db, determine if LON-CAPA version checking is needed.
$skipcheck = $extra->{'skipcheck'};	# Sessions on 2.10 and later do not require version checking, as that occurs
}	# on the server hosting the user session, when constructing the roles/courses
	# screen).
	#
	my $skipcheck;
my @ids = &Apache::lonnet::current_machine_ids();	my @ids = &Apache::lonnet::current_machine_ids();
my (%homecourses,$major,$minor,$now);	my (%homecourses,$major,$minor,$now);
if (($namespace eq 'roles') && (!$skipcheck)) {	#
	# If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA
	# version on the server which requested the data. 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.
	#
	#
	if ($namespace eq 'roles') {
my $loncaparev = $clientversion;	my $loncaparev = $clientversion;
if ($loncaparev eq '') {	if ($loncaparev eq '') {
$loncaparev = $Apache::lonnet::loncaparevs{$clientname};	$loncaparev = $Apache::lonnet::loncaparevs{$clientname};
Line 3221 sub dump_with_regexp {	Line 3325 sub dump_with_regexp {
$major = $1;	$major = $1;
$minor = $2;	$minor = $2;
}	}
	if (($major > 2) \|\| (($major == 2) && ($minor > 9))) {
	$skipcheck = 1;
	}
$now = time;	$now = time;
}	}
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
if ($namespace eq 'roles') {	if (($namespace eq 'roles') && (!$skipcheck)) {
if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc\|co\|in\|ta\|ep\|ad\|st\|cr)$}) {	if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc\|co\|in\|ta\|ep\|ad\|st\|cr)$}) {
my $cdom = $1;	my $cdom = $1;
my $cnum = $2;	my $cnum = $2;
unless ($skipcheck) {	my ($role,$roleend,$rolestart) = split(/\_/,$value);
my ($role,$end,$start) = split(/\_/,$value);	if (!$roleend \|\| $roleend > $now) {
if (!$end \|\| $end > $now) {	#
next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,	# For active course roles, check that requesting server is running a LON-CAPA
$minor,\%homecourses,\@ids));	# version which meets any version requirements for the course. Do not include
}	# the role amongst the results returned if the requesting server's version is
	# too old.
	#
	# This determination is handled differently depending on whether the course's
	# homeserver is the current server, or whether it is a different server.
	# In both cases, the course's version requirement needs to be retrieved.
	#
	next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
	$minor,\%homecourses,\@ids));
}	}
}	}
}	}
Line 3253 sub dump_with_regexp {	Line 3368 sub dump_with_regexp {
}	}
}	}
if (&untie_user_hash($hashref)) {	if (&untie_user_hash($hashref)) {
	#
	# If dump is for roles.db from a pre-2.10 server, check if the LON-CAPA
	# version requirements for courses for which the current server is the home
	# server permit course roles to be usable on the client server hosting the
	# user's session. If so, include those role results in the data returned to
	# the client server.
	#
if (($namespace eq 'roles') && (!$skipcheck)) {	if (($namespace eq 'roles') && (!$skipcheck)) {
if (keys(%homecourses) > 0) {	if (keys(%homecourses) > 0) {
$qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count,	$qresult .= &check_homecourses(\%homecourses,$regexp,$count,
$range,$start,$end,$major,$minor);	$range,$start,$end,$major,$minor);
}	}
}	}
Line 3925 sub dump_course_id_handler {	Line 4047 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 5038 sub validate_course_owner_handler {	Line 5160 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, $coowners) = split(/:/, $tail);	my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail);

$owner = &unescape($owner);	$owner = &unescape($owner);
$coowners = &unescape($coowners);	$coowners = &unescape($coowners);
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);	my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);
Line 6029 if (-e $pidfile) {	Line 6151 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',
ReuseAddr => 1,	ReuseAddr => 1,
Listen => 10 )	Listen => 10 )
or die "making socket: $@\n";	or die "making socket: $@\n";

Line 6092 sub HUPSMAN { # sig	Line 6214 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 {
	# --------------------------- Handle case of another apachereload process (locking)
if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) {	if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) {
my $execdir = $perlvar{'lonDaemons'};	my $execdir = $perlvar{'lonDaemons'};
my $script = $execdir."/apachereload";	my $script = $execdir."/apachereload";
Line 6361 $SIG{USR2} = \&UpdateHosts;	Line 6484 $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`;	my $arch = `uname -i`;
chomp($arch);	chomp($arch);
Line 6436 sub make_new_child {	Line 6559 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
# Block sigpipe as it gets thrownon socket disconnect and we want to	# deal with that as a read faiure instead.
# deal with that as a read faiure instead.	#
#	my $blockset = POSIX::SigSet->new(SIGPIPE);
my $blockset = POSIX::SigSet->new(SIGPIPE);	sigprocmask(SIG_BLOCK, $blockset);
sigprocmask(SIG_BLOCK, $blockset);

$lastlog='Forked ';	$lastlog='Forked ';
$status='Forked';	$status='Forked';
Line 6455 sub make_new_child {	Line 6577 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')) {
&Authen::Krb5::init_ets();	&Authen::Krb5::init_ets();
}	}

Line 6644 sub is_author {	Line 6767 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 6669 sub is_author {	Line 6799 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 7167 sub subscribe {	Line 7296 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 7209 sub change_unix_password {	Line 7340 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 7250 sub make_passwd_file {	Line 7381 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 7262 sub make_passwd_file {	Line 7393 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 7355 sub get_usersession_config {	Line 7487 sub get_usersession_config {
return;	return;
}	}

	#
	# releasereqd_check() will determine if a LON-CAPA version (defined in the
	# $major,$minor args passed) is not too old to allow use of a role in a
	# course ($cnum,$cdom args passed), if at least one of the following applies:
	# (a) the course is a Community, (b) the course's home server is not the
	# current server, or (c) cached course information is not stale.
	#
	# For the case where none of these apply, the course is added to the
	# $homecourse hash ref (keys = courseIDs, values = array of a hash of roles).
	# The $homecourse hash ref is for courses for which the current server is the
	# home server. LON-CAPA version requirements are checked elsewhere for the
	# items in $homecourse.
	#

sub releasereqd_check {	sub releasereqd_check {
my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;	my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
my $home = &Apache::lonnet::homeserver($cnum,$cdom);	my $home = &Apache::lonnet::homeserver($cnum,$cdom);
Line 7384 sub releasereqd_check {	Line 7530 sub releasereqd_check {
if (ref($ids) eq 'ARRAY') {	if (ref($ids) eq 'ARRAY') {
if (grep(/^\Q$home\E$/,@{$ids})) {	if (grep(/^\Q$home\E$/,@{$ids})) {
if (ref($homecourses) eq 'HASH') {	if (ref($homecourses) eq 'HASH') {
if (ref($homecourses->{$hashid}) eq 'ARRAY') {	if (ref($homecourses->{$cdom}) eq 'HASH') {
push(@{$homecourses->{$hashid}},{$key=>$value});	if (ref($homecourses->{$cdom}{$cnum}) eq 'HASH') {
	if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
	push(@{$homecourses->{$cdom}{$cnum}},{$key=>$value});
	} else {
	$homecourses->{$cdom}{$cnum} = [{$key=>$value}];
	}
	} else {
	$homecourses->{$cdom}{$cnum} = [{$key=>$value}];
	}
} else {	} else {
$homecourses->{$hashid} = [{$key=>$value}];	$homecourses->{$cdom}{$cnum} = [{$key=>$value}];
}	}
}	}
return;	return;
Line 7406 sub releasereqd_check {	Line 7560 sub releasereqd_check {
return 1;	return 1;
}	}

	#
	# get_courseinfo_hash() is used to retrieve course information from the db
	# file: nohist_courseids.db for a course for which the current server is not
	# the home server.
	#
	# A hash of a hash will be retrieved. The outer hash contains a single key --
	# courseID -- for the course for which the data are being requested.
	# The contents of the inner hash, for that single item in the outer hash
	# are returned (and cached in memcache for 10 minutes).
	#

sub get_courseinfo_hash {	sub get_courseinfo_hash {
my ($cnum,$cdom,$home) = @_;	my ($cnum,$cdom,$home) = @_;
my %info;	my %info;
Line 7431 sub get_courseinfo_hash {	Line 7596 sub get_courseinfo_hash {
return;	return;
}	}

	#
	# check_homecourses() will retrieve course information for those courses which
	# are keys of the $homecourses hash ref (first arg). The nohist_courseids.db
	# GDBM file is tied and course information for each course retrieved. Last
	# visit (lasttime key) is also retrieved for each, and cached values updated
	# for any courses last visited less than 24 hours ago. Cached values are also
	# updated for any courses included in the $homecourses hash ref.
	#
	# The reason for the 24 hours constraint is that the cron entry in
	# /etc/cron.d/loncapa for /home/httpd/perl/refresh_courseids_db.pl causes
	# cached course information to be updated nightly for courses with activity
	# within the past 24 hours.
	#
	# Role information for the user (included in a ref to an array of hashes as the
	# value for each key in $homecourses) is appended to the result returned by the
	# routine, which will in turn be appended to the string returned to the client
	# hosting the user's session.
	#

sub check_homecourses {	sub check_homecourses {
my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;	my ($homecourses,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
my ($result,%addtocache);	my ($result,%addtocache);
my $yesterday = time - 24*3600;	my $yesterday = time - 24*3600;
if (ref($homecourses) eq 'HASH') {	if (ref($homecourses) eq 'HASH') {
my (%okcourses,%courseinfo,%recent);	my (%okcourses,%courseinfo,%recent);
my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());	foreach my $domain (keys(%{$homecourses})) {
if ($hashref) {	my $hashref =
while (my ($key,$value) = each(%$hashref)) {	&tie_domain_hash($domain, "nohist_courseids", &GDBM_WRCREAT());
my $unesc_key = &unescape($key);	if (ref($hashref) eq 'HASH') {
if ($unesc_key =~ /^lasttime:(\w+)$/) {	while (my ($key,$value) = each(%$hashref)) {
my $cid = $1;	my $unesc_key = &unescape($key);
$cid =~ s/_/:/;	if ($unesc_key =~ /^lasttime:(\w+)$/) {
if ($value > $yesterday ) {	my $cid = $1;
$recent{$cid} = 1;	$cid =~ s/_/:/;
	if ($value > $yesterday ) {
	$recent{$cid} = 1;
	}
	next;
}	}
next;	my $items = &Apache::lonnet::thaw_unescape($value);
}	if (ref($items) eq 'HASH') {
my $items = &Apache::lonnet::thaw_unescape($value);	my ($cdom,$cnum) = split(/_/,$unesc_key);
if (ref($items) eq 'HASH') {	my $hashid = $cdom.':'.$cnum;
my $hashid = $unesc_key;	$courseinfo{$hashid} = $items;
$hashid =~ s/_/:/;	if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
$courseinfo{$hashid} = $items;	my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
if (ref($homecourses->{$hashid}) eq 'ARRAY') {	if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});	$okcourses{$hashid} = 1;
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 for $domain");
	}
	} else {
	&logthis("Failed to tie hash for nohist_courseids.db for $domain");
}	}
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)) {	foreach my $hashid (keys(%recent)) {
my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);	my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
Line 7475 sub check_homecourses {	Line 7661 sub check_homecourses {
&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);	&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
}	}
}	}
foreach my $hashid (keys(%{$homecourses})) {	foreach my $cdom (keys(%{$homecourses})) {
next if ($recent{$hashid});	if (ref($homecourses->{$cdom}) eq 'HASH') {
&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);	foreach my $cnum (keys(%{$homecourses->{$cdom}})) {
	my $hashid = $cdom.':'.$cnum;
	next if ($recent{$hashid});
	&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
	}
	}
}	}
foreach my $hashid (keys(%okcourses)) {	foreach my $hashid (keys(%okcourses)) {
if (ref($homecourses->{$hashid}) eq 'ARRAY') {	my ($cdom,$cnum) = split(/:/,$hashid);
foreach my $role (@{$homecourses->{$hashid}}) {	if ((ref($homecourses->{$cdom}) eq 'HASH') &&
	(ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY')) {
	foreach my $role (@{$homecourses->{$cdom}{$cnum}}) {
if (ref($role) eq 'HASH') {	if (ref($role) eq 'HASH') {
while (my ($key,$value) = each(%{$role})) {	while (my ($key,$value) = each(%{$role})) {
if ($regexp eq '.') {	if ($regexp eq '.') {
Line 7507 sub check_homecourses {	Line 7700 sub check_homecourses {
return $result;	return $result;
}	}

	#
	# useable_role() will compare the LON-CAPA version required by a course with
	# the version available on the client server. If the client server's version
	# is compatible, 1 will be returned.
	#

sub useable_role {	sub useable_role {
my ($reqdmajor,$reqdminor,$major,$minor) = @_;	my ($reqdmajor,$reqdminor,$major,$minor) = @_;
if ($reqdmajor ne '' && $reqdminor ne '') {	if ($reqdmajor ne '' && $reqdminor ne '') {
Line 7728 Place in B<logs/lond.log>	Line 7927 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.467.2.4
changed lines
	Added in v.1.489.2.2