[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.1531 and 1.1538

version 1.1531, 2024/12/25 06:07:01 version 1.1538, 2025/04/02 23:44:03
Line 3019  sub get_domain_defaults { Line 3019  sub get_domain_defaults {
                 last if ($domdefaults{'userapprovals'});                  last if ($domdefaults{'userapprovals'});
             }              }
         }          }
           if (ref($domconfig{'privacy'}{'othdom'}) eq 'HASH') {
               $domdefaults{'privacyothdom'} = $domconfig{'privacy'}{'othdom'};
           }
     }      }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
Line 3731  sub ssi_body { Line 3734  sub ssi_body {
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
     $output=~s/^.*?\<body[^\>]*\>//si;      $output=~s/^.*?\<body[^\>]*\>//si;
     $output=~s/\<\/body\s*\>.*?$//si;      $output=~s/\<\/body\s*\>.*?$//si;
       $output=~s{\Q<div class="LC_landmark" role="main">\E}{<div>}gs;
     if (wantarray) {      if (wantarray) {
         return ($output, $response);          return ($output, $response);
     } else {      } else {
Line 6749  sub store { Line 6753  sub store {
 # -------------------------------------------------------------- Critical Store  # -------------------------------------------------------------- Critical Store
   
 sub cstore {  sub cstore {
     my ($storehash,$symb,$namespace,$domain,$stuname,$laststore,$ip,$nolog) = @_;      my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
     my $home='';      my $home='';
   
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
Line 6774  sub cstore { Line 6778  sub cstore {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     if ($ip ne '') {      $$storehash{'ip'} = &get_requestor_ip();
         $$storehash{'ip'} = $ip;  
     } else {  
         $$storehash{'ip'} = &get_requestor_ip();  
     }  
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
Line 6786  sub cstore { Line 6786  sub cstore {
         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';          $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
     }      }
     $namevalue=~s/\&$//;      $namevalue=~s/\&$//;
     unless ($nolog) {      &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
         &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);  
     }  
     return critical      return critical
                 ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");                  ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
 }  }
Line 7530  sub set_adhoc_privileges { Line 7528  sub set_adhoc_privileges {
         if (&allowed('adv') eq 'F') { $tadv=1; }          if (&allowed('adv') eq 'F') { $tadv=1; }
         &appenv({'request.role.adv'    => $tadv});          &appenv({'request.role.adv'    => $tadv});
     }      }
       if ($role eq 'ca') {
           my @ca_settings = ('authoreditors','coauthorlist');
           my %info = &userenvironment($dcdom,$pickedcourse,@ca_settings);
           foreach my $item (@ca_settings) {
               if (exists($info{$item})) {
                   my $name = $item;
                   if ($item eq 'authoreditors') {
                       $name = 'editors';
                       unless ($info{'authoreditors'}) {
                           my %domdefs = &get_domain_defaults($dcdom);
                           if ($domdefs{$name} ne '') {
                               $info{'authoreditors'} = $domdefs{$name};
                           } else {
                               $info{'authoreditors'} = 'edit,xml';
                           }
                       }
                   }
                   &appenv({"environment.internal.$name./$dcdom/$pickedcourse" => $info{$item}});
               }
           }
       }
 }  }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
Line 11690  sub is_course { Line 11709  sub is_course {
 }  }
   
 sub store_userdata {  sub store_userdata {
     my ($storehash,$datakey,$namespace,$udom,$uname) = @_;      my ($storehash,$datakey,$namespace,$udom,$uname,$ip) = @_;
     my $result;      my $result;
     if ($datakey ne '') {      if ($datakey ne '') {
         if (ref($storehash) eq 'HASH') {          if (ref($storehash) eq 'HASH') {
Line 11702  sub store_userdata { Line 11721  sub store_userdata {
             if (($uhome eq '') || ($uhome eq 'no_host')) {              if (($uhome eq '') || ($uhome eq 'no_host')) {
                 $result = 'error: no_host';                  $result = 'error: no_host';
             } else {              } else {
                 $storehash->{'ip'} = &get_requestor_ip();                  if ($ip ne '') {
                       $storehash->{'ip'} = $ip;
                   } else {
                       $storehash->{'ip'} = &get_requestor_ip();
                   }
                 $storehash->{'host'} = $perlvar{'lonHostID'};                  $storehash->{'host'} = $perlvar{'lonHostID'};
   
                 my $namevalue='';                  my $namevalue='';
Line 12557  sub stat_file { Line 12580  sub stat_file {
 # $relpath - Current path (relative to top level).  # $relpath - Current path (relative to top level).
 # $dirhashref - reference to hash to populate with URLs of directories (Required)  # $dirhashref - reference to hash to populate with URLs of directories (Required)
 # $filehashref - reference to hash to populate with URLs of files (Optional)  # $filehashref - reference to hash to populate with URLs of files (Optional)
   # $getlastmod - if true, will set value for each key in innerhash in $filehashref
   #               to last modification time of file; value set to 1 otherwise.
 #  #
 # Returns: nothing  # Returns: nothing
 #  #
Line 12569  sub stat_file { Line 12594  sub stat_file {
 #  #
   
 sub recursedirs {  sub recursedirs {
     my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$relpath,$dirhashref,$filehashref) = @_;      my ($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,
           $relpath,$dirhashref,$filehashref,$getlastmod) = @_;
     return unless (ref($dirhashref) eq 'HASH');      return unless (ref($dirhashref) eq 'HASH');
     my $docroot = $perlvar{'lonDocRoot'};      my $docroot = $perlvar{'lonDocRoot'};
     my $currpath = $docroot.$toppath;      my $currpath = $docroot.$toppath;
Line 12577  sub recursedirs { Line 12603  sub recursedirs {
         $currpath .= "/$relpath";          $currpath .= "/$relpath";
     }      }
     my ($savefile,$checkinc,$checkexc);      my ($savefile,$checkinc,$checkexc);
     if (ref($filehashref)) {      if (ref($filehashref) eq 'HASH') {
         $savefile = 1;          $savefile = 1;
     }      }
     if (ref($include) eq 'HASH') {      if (ref($include) eq 'HASH') {
Line 12600  sub recursedirs { Line 12626  sub recursedirs {
                     }                      }
                     $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;                      $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
                     if ($recurse) {                      if ($recurse) {
                         &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);                          &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,
                                        $toppath,$newpath,$dirhashref,$filehashref,$getlastmod);
                     }                      }
                 } elsif (($savefile) || ($relpath eq '')) {                  } elsif (($savefile) || ($relpath eq '')) {
                     next if ($nonemptydir && $filecount);                      next if ($nonemptydir && $filecount);
Line 12617  sub recursedirs { Line 12644  sub recursedirs {
                         $dirhashref->{'/'} = 1;                          $dirhashref->{'/'} = 1;
                     }                      }
                     if ($savefile) {                      if ($savefile) {
                           my $value;
                           if ($getlastmod) {
                               ($value) = (stat("$currpath/$item"))[9];
                           } else {
                               $value = 1;
                           }
                         if ($relpath eq '') {                          if ($relpath eq '') {
                             $filehashref->{'/'}{$item} = 1;                              $filehashref->{'/'}{$item} = $value
                         } else {                          } else {
                             $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;                              $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = $value;
                         }                          }
                     }                      }
                     $filecount ++;                      $filecount ++;
Line 12629  sub recursedirs { Line 12662  sub recursedirs {
             closedir($dirh);              closedir($dirh);
         }          }
     } else {      } else {
         my ($dirlistref,$listerror) =          my $url = $toppath;
             &dirlist($toppath.$relpath);          if ($relpath ne '') {
               $url = $toppath.'/'.$relpath;
           }
           my ($dirlistref,$listerror) = &dirlist($url);
         my @dir_lines;          my @dir_lines;
         my $dirptr=16384;          my $dirptr=16384;
         if (ref($dirlistref) eq 'ARRAY') {          if (ref($dirlistref) eq 'ARRAY') {
Line 12654  sub recursedirs { Line 12690  sub recursedirs {
                     }                      }
                     $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;                      $dirhashref->{&Apache::lonlocal::js_escape($newpath)} = 1;
                     if ($recurse) {                      if ($recurse) {
                         &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,$toppath,$newpath,$dirhashref,$filehashref);                          &recursedirs($is_home,$recurse,$include,$exclude,$nonemptydir,$addtopdir,
                                        $toppath,$newpath,$dirhashref,$filehashref,$getlastmod);
                     }                      }
                 } elsif (($savefile) || ($relpath eq '')) {                  } elsif (($savefile) || ($relpath eq '')) {
                     next if ($nonemptydir && $filecount);                      next if ($nonemptydir && $filecount);
                     if ($checkinc || $checkexc) {                      if ($checkinc || $checkexc) {
                         my $extension;                          my ($extension) = ($item =~ /\.(\w+)$/);
                         if ($checkinc) {                          if ($checkinc) {
                             next unless ($extension && $include->{$extension});                              next unless ($extension && $include->{$extension});
                         }                          }
Line 12671  sub recursedirs { Line 12708  sub recursedirs {
                         $dirhashref->{'/'} = 1;                          $dirhashref->{'/'} = 1;
                     }                      }
                     if ($savefile) {                      if ($savefile) {
                           my $value;
                           if ($getlastmod) {
                               $value = $mtime;
                           } else {
                               $value = 1;
                           }
                         if ($relpath eq '') {                          if ($relpath eq '') {
                             $filehashref->{'/'}{$item} = 1;                              $filehashref->{'/'}{$item} = $value;
                         } else {                          } else {
                             $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = 1;                              $filehashref->{&Apache::lonlocal::js_escape($relpath)}{$item} = $value;
                         }                          }
                     }                      }
                     $filecount ++;                       $filecount ++; 
Line 12701  sub priv_exclude { Line 12744  sub priv_exclude {
            };             };
 }  }
   
   sub res_exclude {
       return {
                meta => 1,
                subscription => 1,
                rights => 1,
              };
   }
   
 # -------------------------------------------------------- Value of a Condition  # -------------------------------------------------------- Value of a Condition
   
 # gets the value of a specific preevaluated condition  # gets the value of a specific preevaluated condition
Line 13165  my %cachedmaps=(); Line 13216  my %cachedmaps=();
 # When this was last done  # When this was last done
 my $cachedmaptime='';  my $cachedmaptime='';
   
   # Cache (5 seconds) of mapsymb hierarchy for speedup of reservations display
   #
   # The course for which we cache
   my $cachedmapsymbkey='';
   # The cached recursive map symbs for this course
   my %cachedmapsymbs=();
   # When this was last done
   my $cachedmapsymbtime='';
   
 sub clear_EXT_cache_status {  sub clear_EXT_cache_status {
     &delenv('cache.EXT.');      &delenv('cache.EXT.');
 }  }
Line 13356  sub EXT { Line 13416  sub EXT {
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
   # --------------------------------------------- Special handling for encrypturl
   
               if ($spacequalifierrest eq '0.encrypturl') {
                   unless ($recursed) {
                       my ($map_from_symb,@mapsymbs);
                       if ($symbparm =~ /\.(page|sequence)$/) {
                           push(@mapsymbs,$symbparm);
                           $map_from_symb = &deversion((&decode_symb($symbparm))[2]);
                       } else {
                           $map_from_symb = &deversion((&decode_symb($symbparm))[0]);
                       }
                       if (($map_from_symb ne '') && ($map_from_symb !~ /default\.sequence$/)) {
                           my @parents = &get_mapsymb_hierarchy($map_from_symb,$courseid);
                           if (@parents) {
                               push(@mapsymbs,@parents);
                           }
                       }
                       if (@mapsymbs) {
                           my $earlyout;
                           my %parmhash=();
                           if (tie(%parmhash,'GDBM_File',
                                   $env{'request.course.fn'}.'_parms.db',
                                   &GDBM_READER(),0640)) {
                               foreach my $mapsymb (@mapsymbs) {
                                   if ((exists($parmhash{$mapsymb.'.'.$spacequalifierrest})) &&
                                       (lc($parmhash{$mapsymb.'.'.$spacequalifierrest}) eq 'yes')) {
                                       $earlyout = $parmhash{$mapsymb.'.'.$spacequalifierrest};
                                       last;
                                   }
                               }
                               untie(%parmhash);
                           }
                           if ($earlyout) { return &get_reply([$earlyout,'map']); }
                       }
                   }
               }
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
     my $symbp=$symbparm;      my $symbp=$symbparm;
     $mapp=&deversion((&decode_symb($symbp))[0]);      $mapp=&deversion((&decode_symb($symbp))[0]);
Line 13559  sub get_map_hierarchy { Line 13656  sub get_map_hierarchy {
     return @recurseup;      return @recurseup;
 }  }
   
   sub get_mapsymb_hierarchy {
       my ($mapname,$courseid) = @_;
       my @recurseup;
       if ($mapname) {
           if (($cachedmapsymbkey eq $courseid) &&
               (abs($cachedmapsymbtime-time)<5)) {
               if (ref($cachedmapsymbs{$mapname}) eq 'ARRAY') {
                   return @{$cachedmapsymbs{$mapname}};
               }
           }
           my $navmap = Apache::lonnavmaps::navmap->new();
           if (ref($navmap)) {
               my $getsymb = 1;
               my $inclusive = 1;
               @recurseup = $navmap->recurseup_maps($mapname,$getsymb,$inclusive);
               undef($navmap);
               $cachedmapsymbs{$mapname} = \@recurseup;
               $cachedmapsymbtime=time;
               $cachedmapsymbkey=$courseid;
           }
       }
       return @recurseup;
   }
   
 }  }
   
 sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().  sub sort_course_groups { # Sort groups based on defined rankings. Default is sort().
Line 15066  sub whichuser { Line 15187  sub whichuser {
     $courseid=$tmp_courseid;      $courseid=$tmp_courseid;
     ($domain)=&get_env_multiple('form.grade_domain');      ($domain)=&get_env_multiple('form.grade_domain');
     ($name)=&get_env_multiple('form.grade_username');      ($name)=&get_env_multiple('form.grade_username');
               if ($name eq 'public' && $domain eq 'public') {
                   $publicuser = 1;
               }
     return ($symb,$courseid,$domain,$name,$publicuser);      return ($symb,$courseid,$domain,$name,$publicuser);
  }   }
     }      }
Line 15082  sub whichuser { Line 15206  sub whichuser {
     $env{'form.username'}.=time.rand(10000000);      $env{'form.username'}.=time.rand(10000000);
  }   }
  $name.=$env{'form.username'};   $name.=$env{'form.username'};
           $publicuser = 1;
     }      }
     return ($symb,$courseid,$domain,$name,$publicuser);      return ($symb,$courseid,$domain,$name,$publicuser);
   
Line 15170  sub repcopy_userfile { Line 15295  sub repcopy_userfile {
     return 'ok';      return 'ok';
 }  }
   
   sub repcopy_crsprivfile {
       my ($src,$dest) = @_;
       my $result;
       if ($src =~ m{^/priv/($match_domain)/($match_courseid)/(.+)$}) {
           my ($cdom,$cnum,$filepath) = ($1,$2,$3);
           $filepath =~ s/\.{2,}//g;
           my $chome = &homeserver($cnum,$cdom);
           unless ($chome eq 'no_host') {
               my @ids=&current_machine_ids();
               unless (grep(/^\Q$chome\E$/,@ids)) {
                   if (&is_course($cdom,$cnum)) {
                       my $londocroot = $perlvar{'lonDocRoot'};
                       if ($dest =~ m{^\Q$londocroot/priv/\E$match_domain/$match_username/.*\Q$filepath\E$}) {
                           my $cmd = 'crsfilefrompriv:'.&escape($filepath).':'.&escape($cnum).':'.&escape($cdom);
                           $result = &reply($cmd,$chome);
                           unless (($result eq 'unknown_cmd') || ($result =~ /^error:/)) {
                               my $url = &unescape($result);
                               if ($url =~ m{^https?://[^/]+\Q/userfiles/$cdom/$cnum/priv/$filepath\E$}) {
                                   my $request=new HTTP::Request('GET',$url);
                                   my $response=&LONCAPA::LWPReq::makerequest($chome,$request,'',\%perlvar,1200,1);
                                   if ($response->is_error()) {
                                       $result = 'error: '.$response->status_line;
                                   } else {
                                       if (open(my $fh,'>',$dest)) {
                                           print $fh $response->content;
                                           close($fh);
                                           $result = 'ok';
                                       } else {
                                           $result = 'error: nowrite';
                                       }
                                   }
                               } else {
                                   $result = 'error: invalidurl';
                               }
                           }
                       }
                   }
               }
           }
       }
       return $result;
   }
   
 sub tokenwrapper {  sub tokenwrapper {
     my $uri=shift;      my $uri=shift;
     $uri=~s|^https?\://([^/]+)||;      $uri=~s|^https?\://([^/]+)||;
Removed from v.1.1531  
changed lines
  Added in v.1.1538

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