[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.1421 and 1.1429

version 1.1421, 2020/05/13 01:58:16 version 1.1429, 2020/10/15 19:17:40
Line 3383  sub repcopy { Line 3383  sub repcopy {
     }      }
 }  }
   
   # ------------------------------------------------- Unsubscribe from a resource
   
   sub unsubscribe {
       my ($fname) = @_;
       my $answer;
       if ($fname=~/\/(aboutme|syllabus|bulletinboard|smppg)$/) { return $answer; }
       $fname=~s/[\n\r]//g;
       my $author=$fname;
       $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
       my ($udom,$uname)=split(/\//,$author);
       my $home=homeserver($uname,$udom);
       if ($home eq 'no_host') {
           $answer = 'no_host';
       } elsif (grep { $_ eq $home } &current_machine_ids()) {
           $answer = 'home';
       } else {
           my $defdom = $perlvar{'lonDefDomain'};
           if (&will_trust('content',$defdom,$udom)) {
               $answer = reply("unsub:$fname",$home);
           } else {
               $answer = 'untrusted';
           }
       }
       return $answer;
   }
   
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
Line 3534  sub remove_stale_resfile { Line 3560  sub remove_stale_resfile {
                                                 unlink($fname.'.meta');                                                  unlink($fname.'.meta');
                                             }                                              }
                                         }                                          }
                                         &reply("unsub:$fname",$homeserver);                                          my $unsubresult = &unsubscribe($fname);
                                           unless ($unsubresult eq 'ok') {
                                               &logthis("no unsub of $fname from $homeserver, reason: $unsubresult");
                                           }
                                         $removed = 1;                                          $removed = 1;
                                     }                                      }
                                 }                                  }
Line 8007  sub customaccess { Line 8036  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_;      my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_;
     my $ver_orguri=$uri;      my $ver_orguri=$uri;
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
Line 8238  sub allowed { Line 8267  sub allowed {
                 } elsif ($noblockcheck) {                  } elsif ($noblockcheck) {
                     $thisallowed.=$value;                      $thisallowed.=$value;
                 } else {                  } else {
                     my @blockers = &has_comm_blocking($priv,$symb,$uri);                      my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
                     if (@blockers > 0) {                      if (@blockers > 0) {
                         $thisallowed = 'B';                          $thisallowed = 'B';
                     } else {                      } else {
Line 8261  sub allowed { Line 8290  sub allowed {
                         } elsif ($noblockcheck) {                          } elsif ($noblockcheck) {
                             $thisallowed='F';                              $thisallowed='F';
                         } else {                          } else {
                             my @blockers = &has_comm_blocking($priv,$symb,$refuri);                              my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
                             if (@blockers > 0) {                              if (@blockers > 0) {
                                 $thisallowed = 'B';                                  $thisallowed = 'B';
                             } else {                              } else {
Line 8334  sub allowed { Line 8363  sub allowed {
                    if ($noblockcheck) {                     if ($noblockcheck) {
                        $thisallowed.=$value;                         $thisallowed.=$value;
                    } else {                     } else {
                        my @blockers = &has_comm_blocking($priv,$symb,$uri);                         my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
                        if (@blockers > 0) {                         if (@blockers > 0) {
                            $thisallowed = 'B';                             $thisallowed = 'B';
                        } else {                         } else {
Line 8347  sub allowed { Line 8376  sub allowed {
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
          
        if ($checkreferer) {         if ($checkreferer) {
   my $refuri=$env{'httpref.'.$orguri};    my $refuri=$env{'httpref.'.$orguri};
             unless ($refuri) {              unless ($refuri) {
Line 8379  sub allowed { Line 8408  sub allowed {
                       } elsif ($noblockcheck) {                        } elsif ($noblockcheck) {
                           $thisallowed.=$value;                            $thisallowed.=$value;
                       } else {                        } else {
                           my @blockers = &has_comm_blocking($priv,$symb,$refuri);                            my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
                           if (@blockers > 0) {                            if (@blockers > 0) {
                               $thisallowed = 'B';                                $thisallowed = 'B';
                           } else {                            } else {
Line 8465  sub allowed { Line 8494  sub allowed {
    }     }
        }         }
     }      }
      
 #  #
 # Rest of the restrictions depend on selected course  # Rest of the restrictions depend on selected course
 #  #
Line 8634  sub constructaccess { Line 8663  sub constructaccess {
 #  #
 # User for whom data are being temporarily cached.  # User for whom data are being temporarily cached.
 my $cacheduser='';  my $cacheduser='';
   # Course for which data are being temporarily cached.
   my $cachedcid='';
 # 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'}) &&
             (abs($cachedlast-time)<5)) {              (abs($cachedlast-time)<5)) {
             return;              return;
         }          }
     }      }
     $cachedlast=time;      $cachedlast=time;
     $cacheduser=$uname.':'.$udom;      $cacheduser=$uname.':'.$udom;
     %cachedblockers = &get_commblock_resources($blocks);      $cachedcid=$env{'request.course.id'};
       %cachedblockers = &get_commblock_resources();
       return;
 }  }
   
 sub get_comm_blocks {  sub get_comm_blocks {
Line 8729  sub get_commblock_resources { Line 8763  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 8787  sub get_commblock_resources { Line 8830  sub get_commblock_resources {
 }  }
   
 sub has_comm_blocking {  sub has_comm_blocking {
     my ($priv,$symb,$uri,$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);          $symb = &symbread($uri,1,1,1,\%possibles,$ignoresymbdb,$noenccheck);
     }      }
     if ($symb) {      if ($symb) {
         @symbs = ($symb);          @symbs = ($symb);
Line 8808  sub has_comm_blocking { Line 8857  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;
                 if (($item eq $map) || ($item eq $symb)) {                  unless ($blocked) {
                     $noblock = 1;                      if (($item eq $map) || ($item eq $symb)) {
                     last;                          $noblock = 1;
                           last;
                       }
                 }                  }
             }              }
             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($blockinfo{$block}{'maps'}) eq 'HASH') {
             if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') {                      if ($blockinfo{$block}{'maps'}{$map}) {
                 if ($cachedblockers{$block}{'maps'}{$map}) {                          unless (grep(/^\Q$block\E$/,@blockers)) {
                     unless (grep(/^\Q$block\E$/,@blockers)) {                              push(@blockers,$block);
                         push(@blockers,$block);                          }
                     }                      }
                 }                  }
             }              }
         }          }
     }      }
     return if ($noblock);      unless ($noblock) { 
     return @blockers;          return @blockers;
       }
       return;
 }  }
 }  }
   
Line 10578  sub writecoursepref { Line 10631  sub writecoursepref {
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
         $course_owner,$crstype,$cnum,$context,$category)=@_;          $course_owner,$crstype,$cnum,$context,$category,$callercontext)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     if ($context eq 'requestcourses') {      if ($context eq 'requestcourses') {
         my $can_create = 0;          my $can_create = 0;
         my ($ownername,$ownerdom) = split(':',$course_owner);          my ($ownername,$ownerdom) = split(':',$course_owner);
         if ($udom eq $ownerdom) {          if ($udom eq $ownerdom) {
             if (&usertools_access($ownername,$ownerdom,$category,undef,              my $reload;
               if (($callercontext eq 'auto') &&
                  ($ownerdom eq $env{'user.domain'}) && ($ownername eq $env{'user.name'})) {
                   $reload = 'reload';
               }
               if (&usertools_access($ownername,$ownerdom,$category,$reload,
                                   $context)) {                                    $context)) {
                 $can_create = 1;                  $can_create = 1;
             }              }
Line 13258  sub deversion { Line 13316  sub deversion {
 # ------------------------------------------------------ Return symb list entry  # ------------------------------------------------------ Return symb list entry
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_;      my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles,
           $ignoresymbdb,$noenccheck)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str='request.symbread.cached.'.$thisfn;
     if (defined($env{$cache_str})) {      if (defined($env{$cache_str})) {
         if ($ignorecachednull) {          unless (ref($possibles) eq 'HASH') {
             return $env{$cache_str} unless ($env{$cache_str} eq '');              if ($ignorecachednull) {
         } else {                  return $env{$cache_str} unless ($env{$cache_str} eq '');
             return $env{$cache_str};              } else {
                   return $env{$cache_str};
               }
         }          }
     }      }
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
     return $env{$cache_str}=&symbclean($env{'request.symb'});              return $env{$cache_str}=&symbclean($env{'request.symb'});
  }   }
  $thisfn=$env{'request.filename'};   $thisfn=$env{'request.filename'};
     }      }
Line 13293  sub symbread { Line 13354  sub symbread {
  if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {   if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {
     $targetfn=$1;      $targetfn=$1;
  }   }
         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',          unless ($ignoresymbdb) {
                       &GDBM_READER(),0640)) {              if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
     $syval=$hash{$targetfn};                            &GDBM_READER(),0640)) {
             untie(%hash);          $syval=$hash{$targetfn};
                   untie(%hash);
               }
               if ($syval && $checkforblock) {
                   my @blockers = &has_comm_blocking('bre',$syval,$thisfn,$ignoresymbdb,$noenccheck);
                   if (@blockers) {
                       $syval='';
                   }
               }
         }          }
 # ---------------------------------------------------------- There was an entry  # ---------------------------------------------------------- There was an entry
         if ($syval) {          if ($syval) {
Line 13329  sub symbread { Line 13398  sub symbread {
      $syval=&encode_symb($bighash{'map_id_'.$mapid},       $syval=&encode_symb($bighash{'map_id_'.$mapid},
     $resid,$thisfn);      $resid,$thisfn);
                      if (ref($possibles) eq 'HASH') {                       if (ref($possibles) eq 'HASH') {
                          $possibles->{$syval} = 1;                               unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
                                $possibles->{$syval} = 1;
                            }
                      }                       }
                      if ($checkforblock) {                       if ($checkforblock) {
                          my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids});                           unless ($bighash{'randomout_'.$ids} || $env{'request.role.adv'}) {
                          if (@blockers) {                               my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids},'',$noenccheck);
                              $syval = '';                               if (@blockers) {
                              return;                                   $syval = '';
                                    untie(%bighash);
                                    return $env{$cache_str}='';
                                }
                          }                           }
                      }                       }
                  } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {                    } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) { 
Line 13354  sub symbread { Line 13428  sub symbread {
                              if ($bighash{'map_type_'.$mapid} ne 'page') {                               if ($bighash{'map_type_'.$mapid} ne 'page') {
                                  my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},                                   my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},
              $resid,$thisfn);               $resid,$thisfn);
                                  if (ref($possibles) eq 'HASH') {                                   next if ($bighash{'randomout_'.$id} && !$env{'request.role.adv'});
                                      $possibles->{$syval} = 1;                                   next unless (($noenccheck) || ($bighash{'encrypted_'.$id} eq $env{'request.enc'}));
                                  }  
                                  if ($checkforblock) {                                   if ($checkforblock) {
                                      my @blockers = &has_comm_blocking('bre',$poss_syval,$file);                                       my @blockers = &has_comm_blocking('bre',$poss_syval,$file,'',$noenccheck);
                                      unless (@blockers > 0) {                                       if (@blockers > 0) {
                                            $syval = '';
                                        } else {
                                          $syval = $poss_syval;                                           $syval = $poss_syval;
                                          $realpossible++;                                           $realpossible++;
                                      }                                       }
Line 13367  sub symbread { Line 13442  sub symbread {
                                      $syval = $poss_syval;                                       $syval = $poss_syval;
                                      $realpossible++;                                       $realpossible++;
                                  }                                   }
                                    if ($syval) {
                                        if (ref($possibles) eq 'HASH') {
                                            $possibles->{$syval} = 1;
                                        }
                                    }
                              }                               }
  }   }
                      }                       }
Removed from v.1.1421  
changed lines
  Added in v.1.1429

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