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

Diff for /loncom/lond between versions 1.451 and 1.468

version 1.451, 2010/08/17 20:06:25 version 1.468, 2011/01/11 10:32:00
Line 1121  sub establish_key_handler { Line 1121  sub establish_key_handler {
 sub load_handler {  sub load_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
   
   
    # Get the load average from /proc/loadavg and calculate it as a percentage of     # 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     # the allowed load limit as set by the perl global variable lonLoadLim
   
Line 1789  sub authenticate_handler { Line 1791  sub authenticate_handler {
         unless ($clientcancheckhost) {          unless ($clientcancheckhost) {
             my $uprimary_id = &Apache::lonnet::domain($udom,'primary');              my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
             my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);              my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
             my @intdoms = &Apache::lonnet::get_internet_names($clientname);                my @intdoms;
               my $internet_names = &Apache::lonnet::get_internet_names($clientname);
               if (ref($internet_names) eq 'ARRAY') {
                   @intdoms = @{$internet_names};
               }
             unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {              unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
                 my ($remote,$hosted);                  my ($remote,$hosted);
                 my $remotesession = &get_usersession_config($udom,'remotesession');                  my $remotesession = &get_usersession_config($udom,'remotesession');
Line 2151  sub update_resource_handler { Line 2157  sub update_resource_handler {
  my $transname="$fname.in.transfer";   my $transname="$fname.in.transfer";
  my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");   my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
  my $response;   my $response;
  alarm(120);  # FIXME: cannot replicate files that take more than two minutes to transfer?
   # alarm(120);
   # FIXME: this should use the LWP mechanism, not internal alarms.
                   alarm(1200);
  {   {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',"$remoteurl");      my $request=new HTTP::Request('GET',"$remoteurl");
Line 2159  sub update_resource_handler { Line 2168  sub update_resource_handler {
  }   }
  alarm(0);   alarm(0);
  if ($response->is_error()) {   if ($response->is_error()) {
   # FIXME: we should probably clean up here instead of just whine
     unlink($transname);      unlink($transname);
     my $message=$response->status_line;      my $message=$response->status_line;
     &logthis("LWP GET: $message for $fname ($remoteurl)");      &logthis("LWP GET: $message for $fname ($remoteurl)");
  } else {   } else {
     if ($remoteurl!~/\.meta$/) {      if ($remoteurl!~/\.meta$/) {
   # FIXME: isn't there an internal LWP mechanism for this?
  alarm(120);   alarm(120);
  {   {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
Line 2413  sub user_has_session_handler { Line 2424  sub user_has_session_handler {
   
     my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));      my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
           
     &logthis("Looking for $udom $uname");  
     opendir(DIR,$perlvar{'lonIDsDir'});      opendir(DIR,$perlvar{'lonIDsDir'});
     my $filename;      my $filename;
     while ($filename=readdir(DIR)) {      while ($filename=readdir(DIR)) {
Line 3162  sub dump_with_regexp { Line 3172  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 $clientcheckrole;      my $skipcheck;
     if ($hashref) {      if ($hashref) {
         my $qresult='';          my $qresult='';
  my $count=0;   my $count=0;
         if ($extra ne '') {          if ($extra ne '') {
             $extra = &Apache::lonnet::thaw_unescape($extra);              $extra = &Apache::lonnet::thaw_unescape($extra);
             $clientcheckrole = $extra->{'clientcheckrole'};              $skipcheck = $extra->{'skipcheck'};
         }          }
         my @ids = &Apache::lonnet::current_machine_ids();          my @ids = &Apache::lonnet::current_machine_ids();
           my (%homecourses,$major,$minor,$now);
           if (($namespace eq 'roles') && (!$skipcheck)) {
               my $loncaparev = $clientversion;
               if ($loncaparev eq '') {
                   $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
               }
               if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
                   $major = $1;
                   $minor = $2;
               }
               $now = time;
           }
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
             if ($namespace eq 'roles') {              if ($namespace eq 'roles') {
                 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 ($clientcheckrole) {                      unless ($skipcheck) {
                         my $home = &Apache::lonnet::homeserver($cnum,$cdom);                          my ($role,$end,$start) = split(/\_/,$value);
                         my $loncaparev = $clientversion;                          if (!$end || $end > $now) {
                         if ($loncaparev eq '') {                              next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
                             $loncaparev = $Apache::lonnet::loncaparevs{$clientname};                                                              $minor,\%homecourses,\@ids));
                         }  
                         my ($major,$minor);  
                         if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {  
                             $major = $1;  
                             $minor = $2;  
                         }  
                         if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_community)_(co|in|ta|ep|ad|st|cr)}) {  
                             if ($major eq '' && $minor eq '') {  
                                 next unless (($home ne 'no_host') && grep(/^\Q$home\E$/,@ids));  
                             }  
                         }  
                         unless ($home eq 'no_host') {  
                             my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);  
                             if (ref($courseinfo) eq 'HASH') {  
                                 if (exists($courseinfo->{'releaserequired'})) {  
                                     my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});  
                                     if ($reqdmajor ne '' && $reqdminor ne '') {  
                                         next if (($major eq '' && $minor eq '') ||  
                                                  ($major < $reqdmajor) ||   
                                                  (($major == $reqdmajor) && ($minor < $reqdminor)));  
                                     }  
                                 }  
                             }  
                         }                          }
                     }                      }
                 }                  }
Line 3224  sub dump_with_regexp { Line 3223  sub dump_with_regexp {
     }      }
  }   }
  if (&untie_user_hash($hashref)) {   if (&untie_user_hash($hashref)) {
               if (($namespace eq 'roles') && (!$skipcheck)) {
                   if (keys(%homecourses) > 0) {
                       $qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count,
                                                      $range,$start,$end,$major,$minor);
                   }
               }
     chop($qresult);      chop($qresult);
     &Reply($client, \$qresult, $userinput);      &Reply($client, \$qresult, $userinput);
  } else {   } else {
Line 4274  sub put_domain_handler { Line 4279  sub put_domain_handler {
 sub get_domain_handler {  sub get_domain_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
   
     my $userinput = "$client:$tail";      my $userinput = "$client:$tail";
   
     my ($udom,$namespace,$what)=split(/:/,$tail,3);      my ($udom,$namespace,$what)=split(/:/,$tail,3);
Line 4418  sub get_id_handler { Line 4424  sub get_id_handler {
 sub put_dcmail_handler {  sub put_dcmail_handler {
     my ($cmd,$tail,$client) = @_;      my ($cmd,$tail,$client) = @_;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
                                                                                   
   
     my ($udom,$what)=split(/:/,$tail);      my ($udom,$what)=split(/:/,$tail);
     chomp($what);      chomp($what);
     my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
Line 4682  sub tmp_put_handler { Line 4689  sub tmp_put_handler {
     }      }
     my ($id,$store);      my ($id,$store);
     $tmpsnum++;      $tmpsnum++;
     if ($context eq 'resetpw') {      if (($context eq 'resetpw') || ($context eq 'createaccount')) {
         $id = &md5_hex(&md5_hex(time.{}.rand().$$));          $id = &md5_hex(&md5_hex(time.{}.rand().$$));
     } else {      } else {
         $id = $$.'_'.$clientip.'_'.$tmpsnum;          $id = $$.'_'.$clientip.'_'.$tmpsnum;
Line 6229  sub logstatus { Line 6236  sub logstatus {
 sub initnewstatus {  sub initnewstatus {
     my $docdir=$perlvar{'lonDocRoot'};      my $docdir=$perlvar{'lonDocRoot'};
     my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");      my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
     my $now=time;      my $now=time();
     my $local=localtime($now);      my $local=localtime($now);
     print $fh "LOND status $local - parent $$\n\n";      print $fh "LOND status $local - parent $$\n\n";
     opendir(DIR,"$docdir/lon-status/londchld");      opendir(DIR,"$docdir/lon-status/londchld");
Line 6379  sub make_new_child { Line 6386  sub make_new_child {
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
         $children{$pid} = $clientip;          $children{$pid} = $clientip;
         &status('Started child '.$pid);          &status('Started child '.$pid);
    close($client);
         return;          return;
     } else {      } else {
         # Child can *not* return from this subroutine.          # Child can *not* return from this subroutine.
Line 6387  sub make_new_child { Line 6395  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 
    # deal with that as a read faiure instead.
    #
    my $blockset = POSIX::SigSet->new(SIGPIPE);
    sigprocmask(SIG_BLOCK, $blockset);
   
         $lastlog='Forked ';          $lastlog='Forked ';
         $status='Forked';          $status='Forked';
   
Line 7298  sub get_usersession_config { Line 7313  sub get_usersession_config {
     return;      return;
 }  }
   
 sub get_courseinfo_hash {  sub releasereqd_check {
     my ($cnum,$cdom,$home) = @_;      my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
       my $home = &Apache::lonnet::homeserver($cnum,$cdom);
       return if ($home eq 'no_host');
       my ($reqdmajor,$reqdminor,$displayrole);
       if ($cnum =~ /$LONCAPA::match_community/) {
           if ($major eq '' && $minor eq '') {
               return unless ((ref($ids) eq 'ARRAY') && 
                              (grep(/^\Q$home\E$/,@{$ids})));
           } else {
               $reqdmajor = 2;
               $reqdminor = 9;
               return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
           }
       }
     my $hashid = $cdom.':'.$cnum;      my $hashid = $cdom.':'.$cnum;
     my ($courseinfo,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);      my ($courseinfo,$cached) =
           &Apache::lonnet::is_cached_new('courseinfo',$hashid);
     if (defined($cached)) {      if (defined($cached)) {
         return $courseinfo;          if (ref($courseinfo) eq 'HASH') {
               if (exists($courseinfo->{'releaserequired'})) {
                   my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
                   return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
               }
           }
       } else {
           if (ref($ids) eq 'ARRAY') {
               if (grep(/^\Q$home\E$/,@{$ids})) {
                   if (ref($homecourses) eq 'HASH') {
                       if (ref($homecourses->{$hashid}) eq 'ARRAY') {
                           push(@{$homecourses->{$hashid}},{$key=>$value});
                       } else {
                           $homecourses->{$hashid} = [{$key=>$value}];
                       }
                   }
                   return;
               }
           }
           my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
           if (ref($courseinfo) eq 'HASH') {
               if (exists($courseinfo->{'releaserequired'})) {
                   my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
                   return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
               }
           } else {
               return;
           }
       }
       return 1;
   }
   
   sub get_courseinfo_hash {
       my ($cnum,$cdom,$home) = @_;
       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("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
           } else {
               &logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
           }
     } else {      } else {
         my %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');  
         if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {          if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
               my $hashid = $cdom.':'.$cnum;
             return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);              return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
         }          }
     }      }
     return;      return;
 }  }
   
   sub check_homecourses {
       my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
       my ($result,%addtocache);
       my $yesterday = time - 24*3600; 
       if (ref($homecourses) eq 'HASH') {
           my (%okcourses,%courseinfo,%recent);
           my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
           if ($hashref) {
               while (my ($key,$value) = each(%$hashref)) {
                   my $unesc_key = &unescape($key);
                   if ($unesc_key =~ /^lasttime:(\w+)$/) {
                       my $cid = $1;
                       $cid =~ s/_/:/;
                       if ($value > $yesterday ) {
                           $recent{$cid} = 1;
                       }
                       next;
                   }
                   my $items = &Apache::lonnet::thaw_unescape($value);
                   if (ref($items) eq 'HASH') {
                       my $hashid = $unesc_key;
                       $hashid =~ s/_/:/;
                       $courseinfo{$hashid} = $items;
                       if (ref($homecourses->{$hashid}) eq 'ARRAY') {
                           my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
                           if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
                               $okcourses{$hashid} = 1;
                           }
                       }
                   }
               }
               unless (&untie_domain_hash($hashref)) {
                   &logthis('Failed to untie tied hash for nohist_courseids.db');
               }
           } else {
               &logthis('Failed to tie hash for nohist_courseids.db');
               return;
           }
           foreach my $hashid (keys(%recent)) {
               my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
               unless ($cached) {
                   &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
               }
           }
           foreach my $hashid (keys(%{$homecourses})) {
               next if ($recent{$hashid});
               &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
           }
           foreach my $hashid (keys(%okcourses)) {
               if (ref($homecourses->{$hashid}) eq 'ARRAY') {
                   foreach my $role (@{$homecourses->{$hashid}}) {
                       if (ref($role) eq 'HASH') {
                           while (my ($key,$value) = each(%{$role})) {
                               if ($regexp eq '.') {
                                   $count++;
                                   if (defined($range) && $count >= $end)   { last; }
                                   if (defined($range) && $count <  $start) { next; }
                                   $result.=$key.'='.$value.'&';
                               } else {
                                   my $unescapeKey = &unescape($key);
                                   if (eval('$unescapeKey=~/$regexp/')) {
                                       $count++;
                                       if (defined($range) && $count >= $end)   { last; }
                                       if (defined($range) && $count <  $start) { next; }
                                       $result.="$key=$value&";
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return $result;
   }
   
   sub useable_role {
       my ($reqdmajor,$reqdminor,$major,$minor) = @_; 
       if ($reqdmajor ne '' && $reqdminor ne '') {
           return if (($major eq '' && $minor eq '') ||
                      ($major < $reqdmajor) ||
                      (($major == $reqdmajor) && ($minor < $reqdminor)));
       }
       return 1;
   }
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   
 =head1 NAME  =head1 NAME
Removed from v.1.451  
changed lines
  Added in v.1.468

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.