[BACK]Return to lond CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.467.2.8 and 1.489.2.1

version 1.467.2.8, 2014/06/09 16:58:22 version 1.489.2.1, 2012/05/02 00:30:19
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 637  sub ConfigFileFromSelector { Line 639  sub ConfigFileFromSelector {
 #     String to send to client ("ok" or "refused" if bad file).  #     String to send to client ("ok" or "refused" if bad file).
 #  #
 sub PushFile {  sub PushFile {
     my $request = shift;      my $request = shift;    
     my ($command, $filename, $contents) = split(":", $request, 3);      my ($command, $filename, $contents) = split(":", $request, 3);
     &Debug("PushFile");      &Debug("PushFile");
           
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 667  sub PushFile { Line 669  sub PushFile {
   
     if($filename eq "host") {      if($filename eq "host") {
  $contents = AdjustHostContents($contents);   $contents = AdjustHostContents($contents);
     } elsif ($filename eq 'dns_host' || $filename eq 'dns_domain') {  
         if ($contents eq '') {  
             &logthis('<font color="red"> Pushfile: unable to install '  
                     .$tablefile." - no data received from push. </font>");  
             return 'error: push had no data';  
         }  
         if (&Apache::lonnet::get_host_ip($clientname)) {  
             my $clienthost = &Apache::lonnet::hostname($clientname);  
             if ($managers{$clientip} eq $clientname) {  
                 my $clientprotocol = $Apache::lonnet::protocol{$clientname};  
                 $clientprotocol = 'http' if ($clientprotocol ne 'https');  
                 my $url = '/adm/'.$filename;  
                 $url =~ s{_}{/};  
                 my $ua=new LWP::UserAgent;  
                 $ua->timeout(60);  
                 my $request=new HTTP::Request('GET',"$clientprotocol://$clienthost$url");  
                 my $response=$ua->request($request);  
                 if ($response->is_error()) {  
                     &logthis('<font color="red"> Pushfile: unable to install '  
                             .$tablefile." - error attempting to pull data. </font>");  
                     return 'error: pull failed';  
                 } else {  
                     my $result = $response->content;  
                     chomp($result);  
                     unless ($result eq $contents) {  
                         &logthis('<font color="red"> Pushfile: unable to install '  
                                 .$tablefile." - pushed data and pulled data differ. </font>");  
                         my $pushleng = length($contents);  
                         my $pullleng = length($result);  
                         if ($pushleng != $pullleng) {  
                             return "error: $pushleng vs $pullleng bytes";  
                         } else {  
                             return "error: mismatch push and pull";  
                         }  
                     }  
                 }  
             }  
         }  
     }      }
   
     #  Install the new file:      #  Install the new file:
Line 715  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 1679  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 2041  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 2116  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 3213  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 3225  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 3243  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 3262  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 3294  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 5079  sub validate_course_owner_handler { Line 5142  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 6070  if (-e $pidfile) { Line 6133  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 6133  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 {
   # --------------------------- 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 6402  $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);  chomp($arch);
Line 6477  sub make_new_child { Line 6541  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 6685  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 6710  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 7252  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 7293  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 7305  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 7398  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 7427  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 7449  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 7474  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 7518  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 7550  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 '') {
Removed from v.1.467.2.8  
changed lines
  Added in v.1.489.2.1

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