--- loncom/lond 2010/10/26 09:46:23 1.461 +++ loncom/lond 2012/05/02 00:30:19 1.489.2.1 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.461 2010/10/26 09:46:23 foxr Exp $ +# $Id: lond,v 1.489.2.1 2012/05/02 00:30:19 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -15,6 +15,7 @@ # # LON-CAPA is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of + # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # @@ -52,13 +53,14 @@ use LONCAPA::lonlocal; use LONCAPA::lonssl; use Fcntl qw(:flock); use Apache::lonnet; +use Mail::Send; -my $DEBUG = 1; # Non zero to enable debug log entries. +my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.461 $'; #' stupid emacs +my $VERSION='$Revision: 1.489.2.1 $'; #' stupid emacs my $remoteVERSION; my $currenthostid="default"; my $currentdomainid; @@ -90,6 +92,8 @@ my %managers; # Ip -> manager names 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. # Each element of the hash contains a reference to an array that contains: @@ -419,8 +423,11 @@ sub ReadManagerTable { my $tablename = $perlvar{'lonTabDir'}."/managers.tab"; if (!open (MANAGERS, $tablename)) { - logthis('No manager table. Nobody can manage!!'); - return; + my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'}); + if (&Apache::lonnet::is_LC_dns($hostname)) { + &logthis('No manager table. Nobody can manage!!'); + } + return; } while(my $host = ) { chomp($host); @@ -445,7 +452,7 @@ sub ReadManagerTable { } } else { logthis(' existing host'." $host\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 } } } @@ -507,7 +514,8 @@ sub AdjustHostContents { my $me = $perlvar{'lonHostID'}; foreach my $line (split(/\n/,$contents)) { - if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) { + if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/) || + ($line =~ /^\s*\^/))) { chomp($line); my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line); if ($id eq $me) { @@ -595,11 +603,8 @@ sub InstallFile { # # ConfigFileFromSelector: converts a configuration file selector # into a configuration file pathname. -# It's probably no longer necessary to preserve -# special handling of hosts or domain as those -# files have been superceded by dns_hosts, dns_domain. -# The default action is just to prepend the directory -# and append .tab +# Supports the following file selectors: +# hosts, domain, dns_hosts, dns_domain # # # Parameters: @@ -612,15 +617,11 @@ sub ConfigFileFromSelector { my $tablefile; my $tabledir = $perlvar{'lonTabDir'}.'/'; - if ($selector eq "hosts") { - $tablefile = $tabledir."hosts.tab"; - } elsif ($selector eq "domain") { - $tablefile = $tabledir."domain.tab"; - } else { + if (($selector eq "hosts") || ($selector eq "domain") || + ($selector eq "dns_hosts") || ($selector eq "dns_domain")) { $tablefile = $tabledir.$selector.'.tab'; } return $tablefile; - } # # PushFile: Called to do an administrative push of a file. @@ -646,6 +647,8 @@ sub PushFile { # supported: # hosts.tab ($filename eq host). # 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. # # lonManage is supposed to ensure this, however this session could be @@ -677,11 +680,31 @@ sub PushFile { return "error:$!"; } else { &logthis(' Installed new '.$tablefile - .""); - + ." - transaction by: $clientname ($clientip)"); + 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: return "ok"; @@ -1121,6 +1144,8 @@ sub establish_key_handler { sub load_handler { my ($cmd, $tail, $replyfd) = @_; + + # 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 @@ -1618,6 +1643,74 @@ sub ls3_handler { } ®ister_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; +} +®ister_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; +} +®ister_handler("devalidatecache", \&server_devalidatecache_handler, 0, 1, 0); + sub server_timezone_handler { my ($cmd,$tail,$client) = @_; my $userinput = "$cmd:$tail"; @@ -1666,6 +1759,15 @@ sub server_homeID_handler { } ®ister_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; +} +®ister_handler("serverdistarch", \&server_distarch_handler, 0, 1, 0); + # Process a reinit request. Reinit requests that either # lonc or lond be reinitialized so that an updated # host.tab or domain.tab can be processed. @@ -1971,7 +2073,7 @@ sub add_user_handler { ."makeuser"; } 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 } else { &Failure($client, \$fperror, $userinput); @@ -2046,7 +2148,7 @@ sub change_authentication_handler { &Failure($client, \$result); } } 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 # unix, or krb*, and the user is an author for this domain, @@ -2246,7 +2348,10 @@ sub fetch_user_file_handler { my $destname=$udir.'/'.$ufile; 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; Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname"); alarm(120); @@ -2422,7 +2527,6 @@ sub user_has_session_handler { my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail)); - &logthis("Looking for $udom $uname"); opendir(DIR,$perlvar{'lonIDsDir'}); my $filename; while ($filename=readdir(DIR)) { @@ -3141,6 +3245,9 @@ sub dump_profile_database { # that is matched against # database keywords to do # 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. # Returns: # 1 - Continue processing. @@ -3153,7 +3260,7 @@ sub dump_with_regexp { my $userinput = "$cmd:$tail"; - my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail); + my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail); if (defined($regexp)) { $regexp=&unescape($regexp); } else { @@ -3171,17 +3278,27 @@ sub dump_with_regexp { } 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'}; - } +# +# When dump is for roles.db, determine if LON-CAPA version checking is needed. +# 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 (%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; if ($loncaparev eq '') { $loncaparev = $Apache::lonnet::loncaparevs{$clientname}; @@ -3190,19 +3307,30 @@ sub dump_with_regexp { $major = $1; $minor = $2; } + if (($major > 2) || (($major == 2) && ($minor > 9))) { + $skipcheck = 1; + } $now = time; } 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)$}) { 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)); - } + my ($role,$roleend,$rolestart) = split(/\_/,$value); + if (!$roleend || $roleend > $now) { +# +# For active course roles, check that requesting server is running a LON-CAPA +# 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)); } } } @@ -3222,9 +3350,16 @@ sub dump_with_regexp { } } 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 (keys(%homecourses) > 0) { - $qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count, + $qresult .= &check_homecourses(\%homecourses,$regexp,$count, $range,$start,$end,$major,$minor); } } @@ -3894,7 +4029,7 @@ sub dump_course_id_handler { $creationcontext = '.'; } my $unpack = 1; - if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' && + if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' && $typefilter eq '.') { $unpack = 0; } @@ -4423,7 +4558,8 @@ sub get_id_handler { sub put_dcmail_handler { my ($cmd,$tail,$client) = @_; my $userinput = "$cmd:$tail"; - + + my ($udom,$what)=split(/:/,$tail); chomp($what); my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT()); @@ -5005,10 +5141,11 @@ sub get_sections_handler { sub validate_course_owner_handler { my ($cmd, $tail, $client) = @_; my $userinput = "$cmd:$tail"; - my ($inst_course_id, $owner, $cdom) = split(/:/, $tail); - + my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail); + $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); @@ -5996,7 +6133,7 @@ if (-e $pidfile) { $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'}, Type => SOCK_STREAM, Proto => 'tcp', - Reuse => 1, + ReuseAddr => 1, Listen => 10 ) or die "making socket: $@\n"; @@ -6059,9 +6196,13 @@ sub HUPSMAN { # sig # a setuid perl script that can be root for us to do this job. # sub ReloadApache { - my $execdir = $perlvar{'lonDaemons'}; - my $script = $execdir."/apachereload"; - system($script); +# --------------------------- Handle case of another apachereload process (locking) + if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) { + my $execdir = $perlvar{'lonDaemons'}; + my $script = $execdir."/apachereload"; + system($script); + unlink('/tmp/lock_apachereload'); # Remove the lock file. + } } # @@ -6325,7 +6466,14 @@ $SIG{USR2} = \&UpdateHosts; &Apache::lonnet::load_hosts_tab(); 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 @@ -6384,6 +6532,7 @@ sub make_new_child { or die "Can't unblock SIGINT for fork: $!\n"; $children{$pid} = $clientip; &status('Started child '.$pid); + close($client); return; } else { # Child can *not* return from this subroutine. @@ -6392,6 +6541,13 @@ sub make_new_child { #don't get intercepted $SIG{USR1}= \&logstatus; $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 '; $status='Forked'; @@ -6592,22 +6748,29 @@ sub is_author { # Author role should show up as a key /domain/_au - my $key = "/$domain/_au"; my $value; - if (defined($hashref)) { - $value = $hashref->{$key}; - } + if ($hashref) { - if(defined($value)) { - &Debug("$user @ $domain is an author"); + my $key = "/$domain/_au"; + 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); } # # Checks to see if the input roleput request was to set -# an author role. If so, invokes the lchtmldir script to set -# up a correct public_html +# an author role. If so, creates construction space # Parameters: # request - The request sent to the rolesput subchunk. # We're looking for /domain/_au @@ -6617,16 +6780,15 @@ sub is_author { # sub manage_permissions { my ($request, $domain, $user, $authtype) = @_; - - &Debug("manage_permissions: $request $domain $user $authtype"); - # See if the request is of the form /$domain/_au if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput... - my $execdir = $perlvar{'lonDaemons'}; - my $userhome= "/home/$user" ; - &logthis("system $execdir/lchtmldir $userhome $user $authtype"); - &Debug("Setting homedir permissions for $userhome"); - system("$execdir/lchtmldir $userhome $user $authtype"); + my $path=$perlvar{'lonDocRoot'}."/priv/$domain"; + unless (-e $path) { + mkdir($path); + } + unless (-e $path.'/'.$user) { + mkdir($path.'/'.$user); + } } } @@ -7115,7 +7277,9 @@ sub subscribe { # the metadata unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } $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"; } } else { @@ -7157,7 +7321,7 @@ sub change_unix_password { sub make_passwd_file { - my ($uname, $umode,$npass,$passfilename)=@_; + my ($uname,$udom,$umode,$npass,$passfilename)=@_; my $result="ok"; if ($umode eq 'krb4' or $umode eq 'krb5') { { @@ -7198,7 +7362,7 @@ sub make_passwd_file { # my $uid = getpwnam($uname); 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"; } @@ -7210,6 +7374,7 @@ sub make_passwd_file { &Debug("user = ".$uname.", Password =". $npass); my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); print $se "$uname\n"; + print $se "$udom\n"; print $se "$npass\n"; print $se "$npass\n"; print $se "$lc_error_file\n"; # Status -> unique file. @@ -7303,6 +7468,20 @@ sub get_usersession_config { 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 { my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_; my $home = &Apache::lonnet::homeserver($cnum,$cdom); @@ -7332,10 +7511,18 @@ sub releasereqd_check { 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}); + if (ref($homecourses->{$cdom}) eq 'HASH') { + 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 { - $homecourses->{$hashid} = [{$key=>$value}]; + $homecourses->{$cdom}{$cnum} = [{$key=>$value}]; } } return; @@ -7347,69 +7534,128 @@ sub releasereqd_check { my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'}); return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor)); } + } else { + return; } } 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 { 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); + my %info; + eval { + local($SIG{ALRM}) = sub { die "timeout\n"; }; + local($SIG{__DIE__})='DEFAULT'; + alarm(3); + %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.'); + alarm(0); + }; + if ($@) { + if ($@ eq "timeout\n") { + &logthis("WARNING courseiddump for $cnum:$cdom from $home timedout"); + } else { + &logthis("WARNING unexpected error during eval of call for courseiddump from $home"); + } + } else { + if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') { + my $hashid = $cdom.':'.$cnum; + return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600); + } } 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 { - my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_; + my ($homecourses,$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; + foreach my $domain (keys(%{$homecourses})) { + my $hashref = + &tie_domain_hash($domain, "nohist_courseids", &GDBM_WRCREAT()); + if (ref($hashref) eq 'HASH') { + 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; } - 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; + my $items = &Apache::lonnet::thaw_unescape($value); + if (ref($items) eq 'HASH') { + my ($cdom,$cnum) = split(/_/,$unesc_key); + my $hashid = $cdom.':'.$cnum; + $courseinfo{$hashid} = $items; + if (ref($homecourses->{$cdom}{$cnum}) 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 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)) { - &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600); + 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 $cdom (keys(%{$homecourses})) { + if (ref($homecourses->{$cdom}) eq 'HASH') { + 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)) { - if (ref($homecourses->{$hashid}) eq 'ARRAY') { - foreach my $role (@{$homecourses->{$hashid}}) { + my ($cdom,$cnum) = split(/:/,$hashid); + if ((ref($homecourses->{$cdom}) eq 'HASH') && + (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY')) { + foreach my $role (@{$homecourses->{$cdom}{$cnum}}) { if (ref($role) eq 'HASH') { while (my ($key,$value) = each(%{$role})) { if ($regexp eq '.') { @@ -7435,6 +7681,12 @@ sub check_homecourses { 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 { my ($reqdmajor,$reqdminor,$major,$minor) = @_; if ($reqdmajor ne '' && $reqdminor ne '') { @@ -7445,6 +7697,10 @@ sub useable_role { return 1; } +sub distro_and_arch { + return $dist.':'.$arch; +} + # ----------------------------------- POD (plain old documentation, CPAN style) =head1 NAME