[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.118.2.8 and 1.1172.2.118.2.11

version 1.1172.2.118.2.8, 2020/10/01 13:19:14 version 1.1172.2.118.2.11, 2020/10/26 01:32:59
Line 1082  sub check_for_balancer_cookie { Line 1082  sub check_for_balancer_cookie {
     return ($otherserver,$cookie);      return ($otherserver,$cookie);
 }  }
   
   sub updatebalcookie {
       my ($cookie,$balancer,$lastentry)=@_;
       if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
           my ($udom,$uname) = ($1,$2);
           my $uprimary_id = &domain($udom,'primary');
           my $uintdom = &internet_dom($uprimary_id);
           my $intdom = &internet_dom($balancer);
           my $serverhomedom = &host_domain($balancer);
           if (($uintdom ne '') && ($uintdom eq $intdom)) {
               return &reply('updatebalcookie:'.&escape($cookie).':'.&escape($lastentry),$balancer);
           }
       }
       return;
   }
   
 sub delbalcookie {  sub delbalcookie {
     my ($cookie,$balancer) =@_;      my ($cookie,$balancer) =@_;
     if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {      if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
Line 1091  sub delbalcookie { Line 1106  sub delbalcookie {
         my $intdom = &internet_dom($balancer);          my $intdom = &internet_dom($balancer);
         my $serverhomedom = &host_domain($balancer);          my $serverhomedom = &host_domain($balancer);
         if (($uintdom ne '') && ($uintdom eq $intdom)) {          if (($uintdom ne '') && ($uintdom eq $intdom)) {
             return &reply("delbalcookie:$cookie",$balancer);              return &reply('delbalcookie:'.&escape($cookie),$balancer);
         }          }
     }      }
 }  }
Line 1578  sub check_loadbalancing { Line 1593  sub check_loadbalancing {
     if ($domneedscache) {      if ($domneedscache) {
         &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);          &do_cache_new('loadbalancing',$domneedscache,$is_balancer,$cachetime);
     }      }
     if ($is_balancer) {      if (($is_balancer) && ($caller ne 'switchserver')) {
         my $lowest_load = 30000;          my $lowest_load = 30000;
         if (ref($offloadto) eq 'HASH') {          if (ref($offloadto) eq 'HASH') {
             if (ref($offloadto->{'primary'}) eq 'ARRAY') {              if (ref($offloadto->{'primary'}) eq 'ARRAY') {
Line 1618  sub check_loadbalancing { Line 1633  sub check_loadbalancing {
                 }                  }
             }              }
         }          }
         unless ($homeintdom) {      }
             undef($setcookie);      if (($is_balancer) && (!$homeintdom)) {
         }          undef($setcookie);
     }      }
     return ($is_balancer,$otherserver,$setcookie);      return ($is_balancer,$otherserver,$setcookie);
 }  }
Line 8437  sub constructaccess { Line 8452  sub constructaccess {
 my $cacheduser='';  my $cacheduser='';
 # Course for which data are being temporarily cached.  # Course for which data are being temporarily cached.
 my $cachedcid='';  my $cachedcid='';
 # List of blocks passed to &get_commblock_resources();  
 my $cachedblocks='';  
 # Cached blockers for this user (a hash of blocking items).  # Cached blockers for this user (a hash of blocking items).
 my %cachedblockers=();  my %cachedblockers=();
 # When the data were last cached.  # When the data were last cached.
 my $cachedlast='';  my $cachedlast='';
   
 sub load_all_blockers {  sub load_all_blockers {
     my ($uname,$udom,$blocks)=@_;      my ($uname,$udom)=@_;
     if (($uname ne '') && ($udom ne '')) {      if (($uname ne '') && ($udom ne '')) {
         if (($cacheduser eq $uname.':'.$udom) &&          if (($cacheduser eq $uname.':'.$udom) &&
             ($cachedcid eq $env{'request.course.id'}) &&              ($cachedcid eq $env{'request.course.id'}) &&
             (abs($cachedlast-time)<5) &&              (abs($cachedlast-time)<5)) {
             (((ref($blocks) eq 'HASH') &&  
               ($cachedblocks eq join(',',sort(keys(%{$blocks}))))) ||  
              (!ref($blocks) && $cachedblocks eq ''))) {  
             return;              return;
         }          }
     }      }
     $cachedlast=time;      $cachedlast=time;
     $cacheduser=$uname.':'.$udom;      $cacheduser=$uname.':'.$udom;
     $cachedcid=$env{'request.course.id'};      $cachedcid=$env{'request.course.id'};
     %cachedblockers = &get_commblock_resources($blocks);      %cachedblockers = &get_commblock_resources();
     if ((ref($blocks) eq 'HASH') && (keys(%{$blocks}) > 0)) {  
         $cachedblocks = join(',',sort(keys(%{$blocks})));  
     }  
     return;      return;
 }  }
   
Line 8543  sub get_commblock_resources { Line 8550  sub get_commblock_resources {
                             if ($mapsymb) {                              if ($mapsymb) {
                                 if (ref($navmap)) {                                  if (ref($navmap)) {
                                     my $mapres = $navmap->getBySymb($mapsymb);                                      my $mapres = $navmap->getBySymb($mapsymb);
                                     @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1);                                      if (ref($mapres)) {
                                     foreach my $res (@to_test) {                                          my $first = $mapres->map_start();
                                         my $symb = $res->symb();                                          my $finish = $mapres->map_finish();
                                         next if ($symb eq $mapsymb);                                          my $it = $navmap->getIterator($first,$finish,undef,0,0);
                                         if ($symb ne '') {                                          if (ref($it)) {
                                             @interval=&EXT("resource.0.interval",$symb);                                              my $res;
                                             if ($interval[1] eq 'map') {                                              while ($res = $it->next(undef,1)) {
                                                 last;                                                  next unless (ref($res));
                                                   my $symb = $res->symb();
                                                   next if (($symb eq $mapsymb) || ($symb eq ''));
                                                   @interval=&EXT("resource.0.interval",$symb);
                                                   if ($interval[1] eq 'map') {
                                                       if ($res->answerable()) {
                                                           push(@to_test,$res);
                                                           last;
                                                       }
                                                   }
                                             }                                              }
                                         }                                          }
                                     }                                      }
Line 8601  sub get_commblock_resources { Line 8617  sub get_commblock_resources {
 }  }
   
 sub has_comm_blocking {  sub has_comm_blocking {
     my ($priv,$symb,$uri,$nosymbcache,$noenccheck,$blocked,$blocks) = @_;      my ($priv,$symb,$uri,$ignoresymbdb,$noenccheck,$blocked,$blocks) = @_;
     my @blockers;      my @blockers;
     return unless ($env{'request.course.id'});      return unless ($env{'request.course.id'});
     return unless ($priv eq 'bre');      return unless ($priv eq 'bre');
     return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);      return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
     return if ($env{'request.state'} eq 'construct');      return if ($env{'request.state'} eq 'construct');
     &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks);      my %blockinfo;
     return unless (keys(%cachedblockers) > 0);      if (ref($blocks) eq 'HASH') {
           %blockinfo = &get_commblock_resources($blocks);
       } else {
           &load_all_blockers($env{'user.name'},$env{'user.domain'});
           %blockinfo = %cachedblockers;
       }
       return unless (keys(%blockinfo) > 0);
     my (%possibles,@symbs);      my (%possibles,@symbs);
     if (!$symb) {      if (!$symb) {
         $symb = &symbread($uri,1,1,1,\%possibles,$nosymbcache,$noenccheck);          $symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck);
     }      }
     if ($symb) {      if ($symb) {
         @symbs = ($symb);          @symbs = ($symb);
Line 8622  sub has_comm_blocking { Line 8644  sub has_comm_blocking {
     foreach my $symb (@symbs) {      foreach my $symb (@symbs) {
         last if ($noblock);          last if ($noblock);
         my ($map,$resid,$resurl)=&decode_symb($symb);          my ($map,$resid,$resurl)=&decode_symb($symb);
         foreach my $block (keys(%cachedblockers)) {          foreach my $block (keys(%blockinfo)) {
             if ($block =~ /^firstaccess____(.+)$/) {              if ($block =~ /^firstaccess____(.+)$/) {
                 my $item = $1;                  my $item = $1;
                 unless ($blocked) {                  unless ($blocked) {
Line 8632  sub has_comm_blocking { Line 8654  sub has_comm_blocking {
                     }                      }
                 }                  }
             }              }
             if (ref($cachedblockers{$block}) eq 'HASH') {              if (ref($blockinfo{$block}) eq 'HASH') {
                 if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') {                  if (ref($blockinfo{$block}{'resources'}) eq 'HASH') {
                     if ($cachedblockers{$block}{'resources'}{$symb}) {                      if ($blockinfo{$block}{'resources'}{$symb}) {
                         unless (grep(/^\Q$block\E$/,@blockers)) {                          unless (grep(/^\Q$block\E$/,@blockers)) {
                             push(@blockers,$block);                              push(@blockers,$block);
                         }                          }
                     }                      }
                 }                  }
                 if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') {                  if (ref($blockinfo{$block}{'maps'}) eq 'HASH') {
                     if ($cachedblockers{$block}{'maps'}{$map}) {                      if ($blockinfo{$block}{'maps'}{$map}) {
                         unless (grep(/^\Q$block\E$/,@blockers)) {                          unless (grep(/^\Q$block\E$/,@blockers)) {
                             push(@blockers,$block);                              push(@blockers,$block);
                         }                          }
Line 11346  sub resdata { Line 11368  sub resdata {
     return undef;      return undef;
 }  }
   
 sub get_domain_ltitools {  sub get_domain_lti {
     my ($cdom) = @_;      my ($cdom,$context) = @_;
     my %ltitools;      my ($name,%lti);
     my ($result,$cached)=&is_cached_new('ltitools',$cdom);      if ($context eq 'consumer') {
           $name = 'ltitools';
       } elsif ($context eq 'provider') {
           $name = 'lti';
       } else {
           return %lti;
       }
       my ($result,$cached)=&is_cached_new($name,$cdom);
     if (defined($cached)) {      if (defined($cached)) {
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             %ltitools = %{$result};              %lti = %{$result};
         }          }
     } else {      } else {
         my %domconfig = &get_dom('configuration',['ltitools'],$cdom);          my %domconfig = &get_dom('configuration',[$name],$cdom);
         if (ref($domconfig{'ltitools'}) eq 'HASH') {          if (ref($domconfig{$name}) eq 'HASH') {
             %ltitools = %{$domconfig{'ltitools'}};              %lti = %{$domconfig{$name}};
             my %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom);              my %encdomconfig = &get_dom('encconfig',[$name],$cdom);
             if (ref($encdomconfig{'ltitools'}) eq 'HASH') {              if (ref($encdomconfig{$name}) eq 'HASH') {
                 foreach my $id (keys(%ltitools)) {                  foreach my $id (keys(%lti)) {
                     if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') {                      if (ref($encdomconfig{$name}{$id}) eq 'HASH') {
                         foreach my $item ('key','secret') {                          foreach my $item ('key','secret') {
                             $ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item};                              $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};
                         }                          }
                     }                      }
                 }                  }
             }              }
         }          }
         my $cachetime = 24*60*60;          my $cachetime = 24*60*60;
         &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);          &do_cache_new($name,$cdom,\%lti,$cachetime);
     }      }
     return %ltitools;      return %lti;
 }  }
   
 sub get_numsuppfiles {  sub get_numsuppfiles {
Line 12527  sub deversion { Line 12556  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,      my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
         $nocache,$noenccheck)=@_;          $ignoresymbdb,$noenccheck)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str='request.symbread.cached.'.$thisfn;
     if (defined($env{$cache_str}) && !$nocache) {      if (defined($env{$cache_str})) {
         unless (ref($possibles) eq 'HASH') {          unless (ref($possibles) eq 'HASH') {
             if ($ignorecachednull) {              if ($ignorecachednull) {
                 return $env{$cache_str} unless ($env{$cache_str} eq '');                  return $env{$cache_str} unless ($env{$cache_str} eq '');
Line 12541  sub symbread { Line 12570  sub symbread {
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
             if ($nocache) {              return $env{$cache_str}=&symbclean($env{'request.symb'});
                 return &symbclean($env{'request.symb'});  
             } else {  
                 return $env{$cache_str}=&symbclean($env{'request.symb'});  
             }  
         }          }
         $thisfn=$env{'request.filename'};          $thisfn=$env{'request.filename'};
     }      }
Line 12553  sub symbread { Line 12578  sub symbread {
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {      if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
  if (&symbverify($thisfn,$1)) {   if (&symbverify($thisfn,$1)) {
             if ($nocache) {      return $env{$cache_str}=&symbclean($thisfn);
                 return &symbclean($thisfn);  
             } else {  
         return $env{$cache_str}=&symbclean($thisfn);  
             }  
  }   }
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
Line 12572  sub symbread { Line 12593  sub symbread {
  if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {   if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
     $targetfn=$1;      $targetfn=$1;
  }   }
         unless ($nocache) {          unless ($ignoresymbdb) {
             if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',              if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                           &GDBM_READER(),0640)) {                            &GDBM_READER(),0640)) {
         $syval=$hash{$targetfn};          $syval=$hash{$targetfn};
                 untie(%hash);                  untie(%hash);
             }              }
             if ($syval) {              if ($syval && $checkforblock) {
                 my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$nocache,$noenccheck);                  my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck);
                 if (@blockers) {                  if (@blockers) {
                     $syval='';                      $syval='';
                 }                  }
Line 12626  sub symbread { Line 12647  sub symbread {
                              if (@blockers) {                               if (@blockers) {
                                  $syval = '';                                   $syval = '';
                                  untie(%bighash);                                   untie(%bighash);
                                  return '' if ($nocache);  
                                  return $env{$cache_str}='';                                   return $env{$cache_str}='';
                              }                               }
                          }                           }
Line 12678  sub symbread { Line 12698  sub symbread {
            }             }
         }          }
         if ($syval) {          if ($syval) {
             if ($nocache) {      return $env{$cache_str}=$syval;
                 return $syval;  
             } else {  
         return $env{$cache_str}=$syval;  
             }  
         }          }
     }      }
     &appenv({'request.ambiguous' => $thisfn});      &appenv({'request.ambiguous' => $thisfn});
     return '' if ($nocache);  
     return $env{$cache_str}='';      return $env{$cache_str}='';
 }  }
   
Removed from v.1.1172.2.118.2.8  
changed lines
  Added in v.1.1172.2.118.2.11

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