loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.471 and 1.489.2.1

version 1.471, 2011/05/13 02:32:40	version 1.489.2.1, 2012/05/02 00:30:19
Line 53 use LONCAPA::lonlocal;	Line 53 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 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 420 sub ReadManagerTable {	Line 423 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 446 sub ReadManagerTable {	Line 452 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 508 sub AdjustHostContents {	Line 514 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 596 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.
# 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 613 sub ConfigFileFromSelector {	Line 617 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 647 sub PushFile {	Line 647 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 678 sub PushFile {	Line 680 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 1621 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 1983 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 2058 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 2258 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 3152 sub dump_profile_database {	Line 3245 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 3164 sub dump_with_regexp {	Line 3260 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 3182 sub dump_with_regexp {	Line 3278 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 3201 sub dump_with_regexp {	Line 3307 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 3233 sub dump_with_regexp {	Line 3350 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 3905 sub dump_course_id_handler {	Line 4029 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 6072 sub HUPSMAN { # sig	Line 6196 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 6338 $SIG{USR2} = \&UpdateHosts;	Line 6466 $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);
if ($arch eq 'unknown') {	if ($arch eq 'unknown') {
$arch = `uname -m`;	$arch = `uname -m`;
	chomp($arch);
}	}

# --------------------------------------------------------------	# --------------------------------------------------------------
Line 6618 sub is_author {	Line 6748 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 6643 sub is_author {	Line 6780 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 7141 sub subscribe {	Line 7277 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 7183 sub change_unix_password {	Line 7321 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 7224 sub make_passwd_file {	Line 7362 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 7236 sub make_passwd_file {	Line 7374 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 7329 sub get_usersession_config {	Line 7468 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 7358 sub releasereqd_check {	Line 7511 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 7380 sub releasereqd_check {	Line 7541 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 7405 sub get_courseinfo_hash {	Line 7577 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 7449 sub check_homecourses {	Line 7642 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 7481 sub check_homecourses {	Line 7681 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 '') {

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

Removed from v.1.471
changed lines
	Added in v.1.489.2.1