[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1172.2.76 and 1.1172.2.82

version 1.1172.2.76, 2016/08/07 01:48:59 version 1.1172.2.82, 2016/09/24 16:30:49
Line 89  use GDBM_File; Line 89  use GDBM_File;
 use HTML::LCParser;  use HTML::LCParser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Storable qw(thaw nfreeze);  use Storable qw(thaw nfreeze);
 use Time::HiRes qw( gettimeofday tv_interval );  use Time::HiRes qw( sleep gettimeofday tv_interval );
 use Cache::Memcached;  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
 use Math::Random;  use Math::Random;
Line 102  use LONCAPA::Lond; Line 102  use LONCAPA::Lond;
 use File::Copy;  use File::Copy;
   
 my $readit;  my $readit;
 my $max_connection_retries = 10;     # Or some such value.  my $max_connection_retries = 20;     # Or some such value.
   
 require Exporter;  require Exporter;
   
Line 370  sub subreply { Line 370  sub subreply {
   
     my $lockfile=$peerfile.".lock";      my $lockfile=$peerfile.".lock";
     while (-e $lockfile) { # Need to wait for the lockfile to disappear.      while (-e $lockfile) { # Need to wait for the lockfile to disappear.
  sleep(1);   sleep(0.1);
     }      }
     # At this point, either a loncnew parent is listening or an old lonc      # At this point, either a loncnew parent is listening or an old lonc
     # or loncnew child is listening so we can connect or everything's dead.      # or loncnew child is listening so we can connect or everything's dead.
Line 388  sub subreply { Line 388  sub subreply {
  } else {   } else {
     &create_connection(&hostname($server),$server);      &create_connection(&hostname($server),$server);
  }   }
         sleep(1); # Try again later if failed connection.          sleep(0.1); # Try again later if failed connection.
     }      }
     my $answer;      my $answer;
     if ($client) {      if ($client) {
Line 481  sub critical { Line 481  sub critical {
     close($dfh);      close($dfh);
  }   }
             }              }
             sleep 2;              sleep 1;
             my $wcmd='';              my $wcmd='';
             {              {
  my $dfh;   my $dfh;
Line 2468  sub make_key { Line 2468  sub make_key {
 sub devalidate_cache_new {  sub devalidate_cache_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }      if ($debug) { &Apache::lonnet::logthis("deleting $name:$id"); }
       my $remembered_id=$name.':'.$id;
     $id=&make_key($name,$id);      $id=&make_key($name,$id);
     $memcache->delete($id);      $memcache->delete($id);
     delete($remembered{$id});      delete($remembered{$remembered_id});
     delete($accessed{$id});      delete($accessed{$remembered_id});
 }  }
   
 sub is_cached_new {  sub is_cached_new {
     my ($name,$id,$debug) = @_;      my ($name,$id,$debug) = @_;
     $id=&make_key($name,$id);      my $remembered_id=$name.':'.$id; # this is to avoid make_key (which is slow) for 
     if (exists($remembered{$id})) {                                       # keys in %remembered hash, which persists for
  if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }                                       # duration of request (no restriction on key length).
  $accessed{$id}=[&gettimeofday()];      if (exists($remembered{$remembered_id})) {
    if ($debug) { &Apache::lonnet::logthis("Early return $remembered_id of $remembered{$remembered_id} "); }
    $accessed{$remembered_id}=[&gettimeofday()];
  $hits++;   $hits++;
  return ($remembered{$id},1);   return ($remembered{$remembered_id},1);
     }      }
       $id=&make_key($name,$id);
     my $value = $memcache->get($id);      my $value = $memcache->get($id);
     if (!(defined($value))) {      if (!(defined($value))) {
  if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is not defined"); }
Line 2492  sub is_cached_new { Line 2496  sub is_cached_new {
  if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }   if ($debug) { &Apache::lonnet::logthis("getting $id is __undef__"); }
  $value=undef;   $value=undef;
     }      }
     &make_room($id,$value,$debug);      &make_room($remembered_id,$value,$debug);
     if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }      if ($debug) { &Apache::lonnet::logthis("getting $id is $value"); }
     return ($value,1);      return ($value,1);
 }  }
   
 sub do_cache_new {  sub do_cache_new {
     my ($name,$id,$value,$time,$debug) = @_;      my ($name,$id,$value,$time,$debug) = @_;
       my $remembered_id=$name.':'.$id;
     $id=&make_key($name,$id);      $id=&make_key($name,$id);
     my $setvalue=$value;      my $setvalue=$value;
     if (!defined($setvalue)) {      if (!defined($setvalue)) {
Line 2514  sub do_cache_new { Line 2519  sub do_cache_new {
  $memcache->disconnect_all();   $memcache->disconnect_all();
     }      }
     # need to make a copy of $value      # need to make a copy of $value
     &make_room($id,$value,$debug);      &make_room($remembered_id,$value,$debug);
     return $value;      return $value;
 }  }
   
 sub make_room {  sub make_room {
     my ($id,$value,$debug)=@_;      my ($remembered_id,$value,$debug)=@_;
   
     $remembered{$id}= (ref($value)) ? &Storable::dclone($value)      $remembered{$remembered_id}= (ref($value)) ? &Storable::dclone($value)
                                     : $value;                                      : $value;
     if ($to_remember<0) { return; }      if ($to_remember<0) { return; }
     $accessed{$id}=[&gettimeofday()];      $accessed{$remembered_id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
     my $to_kick;      my $to_kick;
     my $max_time=0;      my $max_time=0;
Line 3918  sub flushcourselogs { Line 3923  sub flushcourselogs {
         delete $domainrolehash{$entry};          delete $domainrolehash{$entry};
     }      }
     foreach my $dom (keys(%domrolebuffer)) {      foreach my $dom (keys(%domrolebuffer)) {
  my %servers = &get_servers($dom,'library');          my %servers;
           if (defined(&domain($dom,'primary'))) {
               my $primary=&domain($dom,'primary');
               my $hostname=&hostname($primary);
               $servers{$primary} = $hostname;
           } else {
               %servers = &get_servers($dom,'library');
           }
  foreach my $tryserver (keys(%servers)) {   foreach my $tryserver (keys(%servers)) {
     unless (&reply('domroleput:'.$dom.':'.      if (&reply('domroleput:'.$dom.':'.
    $domrolebuffer{$dom},$tryserver) eq 'ok') {                 $domrolebuffer{$dom},$tryserver) eq 'ok') {
           last;
       } else {
  &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);   &logthis('Put of domain roles failed for '.$dom.' and  '.$tryserver);
     }      }
         }          }
Line 6235  sub sixnum_code { Line 6249  sub sixnum_code {
 # -------------------------------------------------- portfolio access checking  # -------------------------------------------------- portfolio access checking
   
 sub portfolio_access {  sub portfolio_access {
     my ($requrl) = @_;      my ($requrl,$clientip) = @_;
     my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);      my (undef,$udom,$unum,$file_name,$group) = &parse_portfolio_url($requrl);
     my $result = &get_portfolio_access($udom,$unum,$file_name,$group);      my $result = &get_portfolio_access($udom,$unum,$file_name,$group,$clientip);
     if ($result) {      if ($result) {
         my %setters;          my %setters;
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
Line 6263  sub portfolio_access { Line 6277  sub portfolio_access {
 }  }
   
 sub get_portfolio_access {  sub get_portfolio_access {
     my ($udom,$unum,$file_name,$group,$access_hash) = @_;      my ($udom,$unum,$file_name,$group,$clientip,$access_hash) = @_;
   
     if (!ref($access_hash)) {      if (!ref($access_hash)) {
  my $current_perms = &get_portfile_permissions($udom,$unum);   my $current_perms = &get_portfile_permissions($udom,$unum);
Line 6272  sub get_portfolio_access { Line 6286  sub get_portfolio_access {
  $access_hash = $access_controls{$file_name};   $access_hash = $access_controls{$file_name};
     }      }
   
     my ($public,$guest,@domains,@users,@courses,@groups);      my ($public,$guest,@domains,@users,@courses,@groups,@ips);
     my $now = time;      my $now = time;
     if (ref($access_hash) eq 'HASH') {      if (ref($access_hash) eq 'HASH') {
         foreach my $key (keys(%{$access_hash})) {          foreach my $key (keys(%{$access_hash})) {
Line 6296  sub get_portfolio_access { Line 6310  sub get_portfolio_access {
                 push(@courses,$key);                  push(@courses,$key);
             } elsif ($scope eq 'group') {              } elsif ($scope eq 'group') {
                 push(@groups,$key);                  push(@groups,$key);
               } elsif ($scope eq 'ip') {
                   push(@ips,$key);
             }              }
         }          }
         if ($public) {          if ($public) {
             return 'ok';              return 'ok';
           } elsif (@ips > 0) {
               my $allowed;
               foreach my $ipkey (@ips) {
                   if (ref($access_hash->{$ipkey}{'ip'}) eq 'ARRAY') {
                       if (&Apache::loncommon::check_ip_acc(join(',',@{$access_hash->{$ipkey}{'ip'}}),$clientip)) {
                           $allowed = 1;
                           last;
                       }
                   }
               }
               if ($allowed) {
                   return 'ok';
               }
         }          }
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
             if ($guest) {              if ($guest) {
Line 7019  sub allowed { Line 7048  sub allowed {
  && $thisallowed ne 'F'    && $thisallowed ne 'F' 
  && $thisallowed ne '2'   && $thisallowed ne '2'
  && &is_portfolio_url($uri)) {   && &is_portfolio_url($uri)) {
  $thisallowed = &portfolio_access($uri);   $thisallowed = &portfolio_access($uri,$clientip);
     }      }
           
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
Line 7740  sub update_allusers_table { Line 7769  sub update_allusers_table {
   
 sub fetch_enrollment_query {  sub fetch_enrollment_query {
     my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;      my ($context,$affiliatesref,$replyref,$dom,$cnum) = @_;
     my $homeserver;      my ($homeserver,$sleep,$loopmax);
     my $maxtries = 1;      my $maxtries = 1;
     if ($context eq 'automated') {      if ($context eq 'automated') {
         $homeserver = $perlvar{'lonHostID'};          $homeserver = $perlvar{'lonHostID'};
           $sleep = 2;
           $loopmax = 100;
         $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout          $maxtries = 10; # will wait for up to 2000s for retrieval of classlist data before timeout
     } else {      } else {
         $homeserver = &homeserver($cnum,$dom);          $homeserver = &homeserver($cnum,$dom);
Line 7761  sub fetch_enrollment_query { Line 7792  sub fetch_enrollment_query {
         &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum);           &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); 
         return 'error: '.$queryid;          return 'error: '.$queryid;
     }      }
     my $reply = &get_query_reply($queryid);      my $reply = &get_query_reply($queryid,$sleep.$loopmax);
     my $tries = 1;      my $tries = 1;
     while (($reply=~/^timeout/) && ($tries < $maxtries)) {      while (($reply=~/^timeout/) && ($tries < $maxtries)) {
         $reply = &get_query_reply($queryid);          $reply = &get_query_reply($queryid,$sleep,$loopmax);
         $tries ++;          $tries ++;
     }      }
     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {      if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);          &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
     } else {      } else {
         my @responses = split(/:/,$reply);          my @responses = split(/:/,$reply);
         if ($homeserver eq $perlvar{'lonHostID'}) {          if (grep { $_ eq $homeserver } &current_machine_ids()) {
             foreach my $line (@responses) {              foreach my $line (@responses) {
                 my ($key,$value) = split(/=/,$line,2);                  my ($key,$value) = split(/=/,$line,2);
                 $$replyref{$key} = $value;                  $$replyref{$key} = $value;
Line 7806  sub fetch_enrollment_query { Line 7837  sub fetch_enrollment_query {
 }  }
   
 sub get_query_reply {  sub get_query_reply {
     my $queryid=shift;      my ($queryid,$sleep,$loopmax) = @_;
       if (($sleep eq '') || ($sleep !~ /^\d+\.?\d*$/)) {
           $sleep = 0.2;
       }
       if (($loopmax eq '') || ($loopmax =~ /\D/)) {
           $loopmax = 100;
       }
     my $replyfile=LONCAPA::tempdir().$queryid;      my $replyfile=LONCAPA::tempdir().$queryid;
     my $reply='';      my $reply='';
     for (1..100) {      for (1..$loopmax) {
  sleep 2;   sleep($sleep);
         if (-e $replyfile.'.end') {          if (-e $replyfile.'.end') {
     if (open(my $fh,$replyfile)) {      if (open(my $fh,$replyfile)) {
  $reply = join('',<$fh>);   $reply = join('',<$fh>);
Line 8232  sub auto_crsreq_update { Line 8269  sub auto_crsreq_update {
     return \%crsreqresponse;      return \%crsreqresponse;
 }  }
   
   sub auto_export_grades {
       my ($cdom,$cnum,$inforef,$gradesref) = @_;
       my ($homeserver,%exportresponse);
       if ($cdom =~ /^$match_domain$/) {
           $homeserver = &domain($cdom,'primary');
       }
       unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
           my $info;
           if (ref($inforef) eq 'HASH') {
               $info = &freeze_escape($inforef);
           }
           if (ref($gradesref) eq 'HASH') {
               my $grades = &freeze_escape($gradesref);
               my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
                                   $info.':'.$grades,$homeserver);
               unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {
                   my @items = split(/&/,$response);
                   foreach my $item (@items) {
                       my ($key,$value) = split('=',$item);
                       $exportresponse{&unescape($key)} = &thaw_unescape($value);
                   }
               }
           }
       }
       return \%exportresponse;
   }
   
 sub check_instcode_cloning {  sub check_instcode_cloning {
     my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;      my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;
     unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {      unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
Line 9568  sub modify_access_controls { Line 9632  sub modify_access_controls {
     my $tries = 0;      my $tries = 0;
     my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);      my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
         
     while (($gotlock ne 'ok') && $tries <3) {      while (($gotlock ne 'ok') && $tries < 10) {
         $tries ++;          $tries ++;
         sleep 1;          sleep(0.1);
         $gotlock = &newput('file_permissions',$lockhash,$domain,$user);          $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
     }      }
     if ($gotlock eq 'ok') {      if ($gotlock eq 'ok') {
Line 9863  sub dirlist { Line 9927  sub dirlist {
             foreach my $user (sort(keys(%allusers))) {              foreach my $user (sort(keys(%allusers))) {
                 push(@alluserslist,$user.'&user');                  push(@alluserslist,$user.'&user');
             }              }
             return (\@alluserslist);              if (!%listerror) {
                   # no errors
                   return (\@alluserslist);
               } elsif (scalar(keys(%servers)) == 1) {
                   # one library server, one error
                   my ($key) = keys(%listerror);
                   return (\@alluserslist, $listerror{$key});
               } elsif ( grep { $_ eq 'con_lost' } values(%listerror) ) {
                   # con_lost indicates that we might miss data from at least one
                   # library server
                   return (\@alluserslist, 'con_lost');
               } else {
                   # multiple library servers and no con_lost -> data should be
                   # complete.
                   return (\@alluserslist);
               }
   
         } else {          } else {
             return ([],'missing username');              return ([],'missing username');
         }          }
Removed from v.1.1172.2.76  
changed lines
  Added in v.1.1172.2.82

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