[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.146.2.9 and 1.1172.2.152

version 1.1172.2.146.2.9, 2023/01/21 00:14:13 version 1.1172.2.152, 2024/12/29 14:47:27
Line 127  our @EXPORT = qw(%env); Line 127  our @EXPORT = qw(%env);
  $logid ++;   $logid ++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
         my $ip = &get_requestor_ip();          my $ip = &get_requestor_ip();  
         my $logentry = {          my $logentry = {
                          $id => {                           $id => {
                                   'exe_uname' => $env{'user.name'},                                    'exe_uname' => $env{'user.name'},
Line 221  sub get_server_distarch { Line 221  sub get_server_distarch {
             }              }
         }          }
         my $rep = &reply('serverdistarch',$lonhost);          my $rep = &reply('serverdistarch',$lonhost);
         unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||          unless ($rep eq 'unknown_cmd' || $rep eq 'no_such_host' ||
                 $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||                  $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
                 $rep eq '') {                  $rep eq '') {
             return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);              return &do_cache_new('serverdistarch',$lonhost,$rep,$cachetime);
Line 1905  sub dump_dom { Line 1905  sub dump_dom {
 # ------------------------------------------ get items from domain db files     # ------------------------------------------ get items from domain db files   
   
 sub get_dom {  sub get_dom {
     my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_;      my ($namespace,$storearr,$udom,$uhome)=@_;
     return if ($udom eq 'public');      return if ($udom eq 'public');
     my $items='';      my $items='';
     foreach my $item (@$storearr) {      foreach my $item (@$storearr) {
Line 1932  sub get_dom { Line 1932  sub get_dom {
         if (grep { $_ eq $uhome } &current_machine_ids()) {          if (grep { $_ eq $uhome } &current_machine_ids()) {
             # domain information is hosted on this machine              # domain information is hosted on this machine
             $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");              $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
         } else {          } else {        
             if ($encrypt) {              $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
                 $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);  
             } else {  
                 $rep=&reply("getdom:$udom:$namespace:$items",$uhome);  
             }  
         }          }
         my %returnhash;          my %returnhash;
         if ($rep eq '' || $rep =~ /^error: 2 /) {          if ($rep eq '' || $rep =~ /^error: 2 /) {
Line 1961  sub get_dom { Line 1957  sub get_dom {
 # -------------------------------------------- put items in domain db files   # -------------------------------------------- put items in domain db files 
   
 sub put_dom {  sub put_dom {
     my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_;      my ($namespace,$storehash,$udom,$uhome)=@_;
     if (!$udom) {      if (!$udom) {
         $udom=$env{'user.domain'};          $udom=$env{'user.domain'};
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
Line 1982  sub put_dom { Line 1978  sub put_dom {
             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
         }          }
         $items=~s/\&$//;          $items=~s/\&$//;
         if ($encrypt) {          return &reply("putdom:$udom:$namespace:$items",$uhome);
             return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);  
         } else {  
             return &reply("putdom:$udom:$namespace:$items",$uhome);  
         }  
     } else {      } else {
         &logthis("put_dom failed - no homeserver and/or domain");          &logthis("put_dom failed - no homeserver and/or domain");
     }      }
Line 2020  sub del_dom { Line 2012  sub del_dom {
     }      }
 }  }
   
 sub store_dom {  
     my ($storehash,$id,$namespace,$dom,$home,$encrypt) = @_;  
     $$storehash{'ip'}=&get_requestor_ip();  
     $$storehash{'host'}=$perlvar{'lonHostID'};  
     my $namevalue='';  
     foreach my $key (keys(%{$storehash})) {  
         $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';  
     }  
     $namevalue=~s/\&$//;  
     if (grep { $_ eq $home } current_machine_ids()) {  
         return LONCAPA::Lond::store_dom("storedom:$dom:$namespace:$id:$namevalue");  
     } else {  
         if ($namespace eq 'private') {  
             return 'refused';  
         } elsif ($encrypt) {  
             return reply("encrypt:storedom:$dom:$namespace:$id:$namevalue",$home);  
         } else {  
             return reply("storedom:$dom:$namespace:$id:$namevalue",$home);  
         }  
     }  
 }  
   
 sub restore_dom {  
     my ($id,$namespace,$dom,$home,$encrypt) = @_;  
     my $answer;  
     if (grep { $_ eq $home } current_machine_ids()) {  
         $answer = LONCAPA::Lond::restore_dom("restoredom:$dom:$namespace:$id");  
     } elsif ($namespace ne 'private') {  
         if ($encrypt) {  
             $answer=&reply("encrypt:restoredom:$dom:$namespace:$id",$home);  
         } else {  
             $answer=&reply("restoredom:$dom:$namespace:$id",$home);  
         }  
     }  
     my %returnhash=();  
     unless (($answer eq '') || ($answer eq 'con_lost') || ($answer eq 'refused') ||  
             ($answer eq 'unknown_cmd') || ($answer eq 'rejected')) {  
         foreach my $line (split(/\&/,$answer)) {  
             my ($name,$value)=split(/\=/,$line);  
             $returnhash{&unescape($name)}=&thaw_unescape($value);  
         }  
         my $version;  
         for ($version=1;$version<=$returnhash{'version'};$version++) {  
             foreach my $item (split(/\:/,$returnhash{$version.':keys'})) {  
                 $returnhash{$item}=$returnhash{$version.':'.$item};  
             }  
         }  
     }  
     return %returnhash;  
 }  
   
 # ----------------------------------construct domainconfig user for a domain   # ----------------------------------construct domainconfig user for a domain 
 sub get_domainconfiguser {  sub get_domainconfiguser {
     my ($udom) = @_;      my ($udom) = @_;
Line 2349  sub inst_rulecheck { Line 2290  sub inst_rulecheck {
                     $response=&unescape(&reply('instidrulecheck:'.&escape($udom).                      $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
                                               ':'.&escape($id).':'.$rulestr,                                                ':'.&escape($id).':'.$rulestr,
                                               $homeserver));                                                $homeserver));
                 } elsif ($item eq 'unamemap') {  
                     $response=&unescape(&reply('instunamemapcheck:'.  
                                                &escape($udom).':'.&escape($uname).  
                                               ':'.$rulestr,$homeserver));  
                 } elsif ($item eq 'selfcreate') {                  } elsif ($item eq 'selfcreate') {
                     $response=&unescape(&reply('instselfcreatecheck:'.                      $response=&unescape(&reply('instselfcreatecheck:'.
                                                &escape($udom).':'.&escape($uname).                                                 &escape($udom).':'.&escape($uname).
                                               ':'.$rulestr,$homeserver));                                                ':'.$rulestr,$homeserver));
                   } elsif ($item eq 'unamemap') {
                       $response=&unescape(&reply('instunamemapcheck:'.
                                                  &escape($udom).':'.&escape($uname).
                                                 ':'.$rulestr,$homeserver));
                 }                  }
                 if ($response ne 'refused') {                  if ($response ne 'refused') {
                     my @pairs=split(/\&/,$response);                      my @pairs=split(/\&/,$response);
Line 2435  sub get_domain_defaults { Line 2376  sub get_domain_defaults {
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','selfenrollment',
                                   'coursecategories','autoenroll',                                    'coursecategories','autoenroll',
                                   'helpsettings','wafproxy','ltisec'],$domain);                                    'helpsettings','wafproxy'],$domain);
     my @coursetypes = ('official','unofficial','community','textbook');      my @coursetypes = ('official','unofficial','community','textbook');
     if (ref($domconfig{'defaults'}) eq 'HASH') {      if (ref($domconfig{'defaults'}) eq 'HASH') {
         $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'};           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
Line 2518  sub get_domain_defaults { Line 2459  sub get_domain_defaults {
         if ($domconfig{'coursedefaults'}{'texengine'}) {          if ($domconfig{'coursedefaults'}{'texengine'}) {
             $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};              $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
         }          }
         if (exists($domconfig{'coursedefaults'}{'ltiauth'})) {  
             $domdefaults{'crsltiauth'} = $domconfig{'coursedefaults'}{'ltiauth'};  
         }  
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
         if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
Line 2591  sub get_domain_defaults { Line 2529  sub get_domain_defaults {
             }              }
         }          }
     }      }
     if (ref($domconfig{'ltisec'}) eq 'HASH') {  
         if (ref($domconfig{'ltisec'}{'encrypt'}) eq 'HASH') {  
             $domdefaults{'linkprotenc_crs'} = $domconfig{'ltisec'}{'encrypt'}{'crs'};  
             $domdefaults{'linkprotenc_dom'} = $domconfig{'ltisec'}{'encrypt'}{'dom'};  
             $domdefaults{'ltienc_consumers'} = $domconfig{'ltisec'}{'encrypt'}{'consumers'};  
         }  
         if (ref($domconfig{'ltisec'}{'private'}) eq 'HASH') {  
             if (ref($domconfig{'ltisec'}{'private'}{'keys'}) eq 'ARRAY') {  
                 $domdefaults{'privhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};  
             }  
         }  
     }  
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
 }  }
Line 2639  sub get_dom_instcats { Line 2565  sub get_dom_instcats {
             if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,              if (&auto_instcode_format($caller,$dom,\%coursecodes,\%codes,
                                       \@codetitles,\%cat_titles,\%cat_order) eq 'ok') {                                        \@codetitles,\%cat_titles,\%cat_order) eq 'ok') {
                 $instcats = {                  $instcats = {
                                   totcodes => $totcodes,
                                 codes => \%codes,                                  codes => \%codes,
                                 codetitles => \@codetitles,                                  codetitles => \@codetitles,
                                 cat_titles => \%cat_titles,                                  cat_titles => \%cat_titles,
Line 2689  sub get_passwdconf { Line 2616  sub get_passwdconf {
     return %passwdconf;      return %passwdconf;
 }  }
   
 sub course_portal_url {  
     my ($cnum,$cdom,$r) = @_;  
     my $chome = &homeserver($cnum,$cdom);  
     my $hostname = &hostname($chome);  
     my $protocol = $protocol{$chome};  
     $protocol = 'http' if ($protocol ne 'https');  
     my %domdefaults = &get_domain_defaults($cdom);  
     my $firsturl;  
     if ($domdefaults{'portal_def'}) {  
         $firsturl = $domdefaults{'portal_def'};  
     } else {  
         my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);  
         $hostname = $alias if ($alias ne '');  
         $firsturl = $protocol.'://'.$hostname;  
     }  
     return $firsturl;  
 }  
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 3552  sub can_edit_resource { Line 3461  sub can_edit_resource {
                     return;                      return;
                 }                  }
             } elsif (!$crsedit) {              } elsif (!$crsedit) {
                   if ($env{'request.role'} =~ m{^st\./$cdom/$cnum}) {
 #  #
 # No edit allowed where CC has switched to student role.  # No edit allowed where CC has switched to student role.
 #  #
                 return;                      return;
                   } elsif (($resurl !~ m{^/res/$match_domain/$match_username/}) ||
                            ($resurl =~ m{^/res/lib/templates/})) {
                       return;
                   }
             }              }
         }          }
     }      }
Line 3613  sub can_edit_resource { Line 3527  sub can_edit_resource {
                             $cfile =  '/adm/wrapper'.$resurl;                              $cfile =  '/adm/wrapper'.$resurl;
                         }                          }
                     }                      }
                 } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {  
                     $incourse = 1;  
                     if ($env{'form.forceedit'}) {  
                         $forceview = 1;  
                     } else {  
                         $forceedit = 1;  
                     }  
                     $cfile = $resurl;  
                 } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {                  } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 3645  sub can_edit_resource { Line 3551  sub can_edit_resource {
                     $forceedit = 1;                      $forceedit = 1;
                 }                  }
                 $cfile = $resurl;                  $cfile = $resurl;
             } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {  
                 $incourse = 1;  
                 if ($env{'form.forceedit'}) {  
                     $forceview = 1;  
                 } else {  
                     $forceedit = 1;  
                 }  
                 $cfile = $resurl;  
             } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {              } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
                 $incourse = 1;                  $incourse = 1;
                 $forceview = 1;                  $forceview = 1;
Line 3662  sub can_edit_resource { Line 3560  sub can_edit_resource {
                     $cfile = &clutter($res);                      $cfile = &clutter($res);
                 } else {                  } else {
                     $cfile = $env{'form.suppurl'};                      $cfile = $env{'form.suppurl'};
                     my $escfile = &unescape($cfile);                      $cfile =~ s{^http://}{};
                     if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {                      $cfile = '/adm/wrapper/ext/'.$cfile;
                         $cfile = '/adm/wrapper'.$escfile;  
                     } else {  
                         $escfile =~ s{^http://}{};  
                         $cfile = &escape("/adm/wrapper/ext/$escfile");  
                     }  
                 }                  }
             } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {              } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                 if ($env{'form.forceedit'}) {                  if ($env{'form.forceedit'}) {
Line 5569  sub courselastaccess { Line 5462  sub courselastaccess {
 sub extract_lastaccess {  sub extract_lastaccess {
     my ($returnhash,$rep) = @_;      my ($returnhash,$rep) = @_;
     if (ref($returnhash) eq 'HASH') {      if (ref($returnhash) eq 'HASH') {
         unless ($rep eq 'unknown_command' || $rep eq 'no_such_host' ||           unless ($rep eq 'unknown_cmd' || $rep eq 'no_such_host' || 
                 $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||                  $rep eq 'con_lost' || $rep eq 'rejected' || $rep eq 'refused' ||
                  $rep eq '') {                   $rep eq '') {
             my @pairs=split(/\&/,$rep);              my @pairs=split(/\&/,$rep);
Line 5673  my %cachedtimes=(); Line 5566  my %cachedtimes=();
 my $cachedtime='';  my $cachedtime='';
   
 sub load_all_first_access {  sub load_all_first_access {
     my ($uname,$udom,$ignorecache)=@_;      my ($uname,$udom)=@_;
     if (($cachedkey eq $uname.':'.$udom) &&      if (($cachedkey eq $uname.':'.$udom) &&
         (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&          (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
         (!$ignorecache)) {  
         return;          return;
     }      }
     $cachedtime=time;      $cachedtime=time;
Line 5685  sub load_all_first_access { Line 5577  sub load_all_first_access {
 }  }
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb,$argmap,$ignorecache)=@_;      my ($type,$argsymb,$argmap)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
Line 5697  sub get_first_access { Line 5589  sub get_first_access {
     } else {      } else {
  $res=$symb;   $res=$symb;
     }      }
     &load_all_first_access($uname,$udom,$ignorecache);      &load_all_first_access($uname,$udom);
     return $cachedtimes{"$courseid\0$res"};      return $cachedtimes{"$courseid\0$res"};
 }  }
   
Line 6677  sub course_adhocrole_privs { Line 6569  sub course_adhocrole_privs {
             $full{$priv} = $restrict;              $full{$priv} = $restrict;
         }          }
         foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {          foreach my $item (split(/,/,$overrides{"internal.adhocpriv.$rolename"})) {
             next if ($item eq '');               next if ($item eq '');
             my ($rule,$rest) = split(/=/,$item);               my ($rule,$rest) = split(/=/,$item);
             next unless (($rule eq 'off') || ($rule eq 'on'));               next unless (($rule eq 'off') || ($rule eq 'on'));
             foreach my $priv (split(/:/,$rest)) {               foreach my $priv (split(/:/,$rest)) {
                 if ($priv ne '') {                   if ($priv ne '') {
                     if ($rule eq 'off') {                       if ($rule eq 'off') {
                         $possremove{$priv} = 1;                           $possremove{$priv} = 1;
                     } else {                       } else {
                         $possadd{$priv} = 1;                           $possadd{$priv} = 1;
                     }                       }
                 }                   }
             }               }
         }           }
         foreach my $priv (sort(keys(%full))) {           foreach my $priv (sort(keys(%full))) {
             if (exists($currprivs{$priv})) {               if (exists($currprivs{$priv})) {
                 unless (exists($possremove{$priv})) {                   unless (exists($possremove{$priv})) {
                     $storeprivs{$priv} = $currprivs{$priv};                       $storeprivs{$priv} = $currprivs{$priv};
                 }                   }
             } elsif (exists($possadd{$priv})) {               } elsif (exists($possadd{$priv})) {
                 $storeprivs{$priv} = $full{$priv};                   $storeprivs{$priv} = $full{$priv};
             }               }
         }           }
         $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));           $coursepriv = ':'.join(':',map { $_.'&'.$storeprivs{$_}; } sort(keys(%storeprivs)));
     }       }
     return $coursepriv;       return $coursepriv;
 }  }
   
 sub group_roleprivs {  sub group_roleprivs {
Line 6965  sub set_adhoc_privileges { Line 6857  sub set_adhoc_privileges {
     my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);      my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash);
     &appenv(\%userroles,[$role,'cm']);      &appenv(\%userroles,[$role,'cm']);
     &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);      &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec);
     unless (($caller eq 'constructaccess' && $env{'request.course.id'}) ||      unless ($caller eq 'constructaccess' && $env{'request.course.id'}) {
             ($caller eq 'tiny')) {  
         &appenv( {'request.role'        => $spec,          &appenv( {'request.role'        => $spec,
                   'request.role.domain' => $dcdom,                    'request.role.domain' => $dcdom,
                   'request.course.sec'  => $sec,                     'request.course.sec'  => $sec, 
Line 7041  sub unserialize { Line 6932  sub unserialize {
 # see Lond::dump_with_regexp  # see Lond::dump_with_regexp
 # if $escapedkeys hash keys won't get unescaped.  # if $escapedkeys hash keys won't get unescaped.
 sub dump {  sub dump {
     my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_;      my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;
     if (!$udomain) { $udomain=$env{'user.domain'}; }      if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
Line 7057  sub dump { Line 6948  sub dump {
                     $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
         return %{&unserialize($reply, $escapedkeys)};          return %{&unserialize($reply, $escapedkeys)};
     }      }
     my $rep;      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
     if ($encrypt) {  
         $rep=&reply("encrypt:edump:$udomain:$uname:$namespace:$regexp:$range",$uhome);  
     } else {  
         $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);  
     }  
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
     if (!($rep =~ /^error/ )) {      if (!($rep =~ /^error/ )) {
Line 7208  sub inc { Line 7094  sub inc {
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
    my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_;     my ($namespace,$storehash,$udomain,$uname)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
Line 7217  sub put { Line 7103  sub put {
        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';         $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    if ($encrypt) {     return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
        return &reply("encrypt:put:$udomain:$uname:$namespace:$items",$uhome);  
    } else {  
        return &reply("put:$udomain:$uname:$namespace:$items",$uhome);  
    }  
 }  }
   
 # ------------------------------------------------------------ newput interface  # ------------------------------------------------------------ newput interface
Line 7758  sub usertools_access { Line 7640  sub usertools_access {
                       blog      => 1,                        blog      => 1,
                       webdav    => 1,                        webdav    => 1,
                       portfolio => 1,                        portfolio => 1,
                       timezone  => 1,  
                  );                   );
     }      }
     return if (!defined($tools{$tool}));      return if (!defined($tools{$tool}));
Line 8044  sub customaccess { Line 7925  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_;      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;
     $uri=&declutter($uri);      $uri=&declutter($uri);
   
     if ($priv eq 'evb') {      if ($priv eq 'evb') {
 # Evade communication block restrictions for specified role in a course or domain  # Evade communication block restrictions for specified role in a course
         if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {          if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
             return $1;              return $1;
         } else {          } else {
Line 8061  sub allowed { Line 7942  sub allowed {
   
     if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }      if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
     if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme|ext\.tool)$}))       if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|viewclasslist|aboutme)$})) 
  || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))    || (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) )) 
  && ($priv eq 'bre')) {   && ($priv eq 'bre')) {
  return 'F';   return 'F';
Line 8109  sub allowed { Line 7990  sub allowed {
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
         my $copyright;          my $copyright=&metadata($uri,'copyright');
         unless ($uri =~ /ext\.tool/) {  
             $copyright=&metadata($uri,'copyright');  
         }  
  if (($copyright eq 'public') && (!$env{'request.course.id'})) {    if (($copyright eq 'public') && (!$env{'request.course.id'})) { 
            return 'F';              return 'F'; 
         }          }
Line 8269  sub allowed { Line 8147  sub allowed {
             if ($env{'user.priv.'.$env{'request.role'}.'./'}              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                 my $value = $1;                  my $value = $1;
                 my $deeplinkblock;                  if ($noblockcheck) {
                 unless ($nodeeplinkcheck) {  
                     $deeplinkblock = &deeplink_check($priv,$symb,$uri);  
                 }  
                 if ($deeplinkblock) {  
                     $thisallowed='D';  
                 } elsif ($noblockcheck) {  
                     $thisallowed.=$value;                      $thisallowed.=$value;
                 } else {                  } else {
                     my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);                      my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
Line 8295  sub allowed { Line 8167  sub allowed {
                     $refuri=&declutter($refuri);                      $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);                      my ($match) = &is_on_map($refuri);
                     if ($match) {                      if ($match) {
                         my $deeplinkblock;                          if ($noblockcheck) {
                         unless ($nodeeplinkcheck) {  
                             $deeplinkblock = &deeplink_check($priv,$symb,$refuri);  
                         }  
                         if ($deeplinkblock) {  
                             $thisallowed='D';  
                         } elsif ($noblockcheck) {  
                             $thisallowed='F';                              $thisallowed='F';
                         } else {                          } else {
                             my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);                              my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
Line 8374  sub allowed { Line 8240  sub allowed {
                =~/\Q$priv\E\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                my $value = $1;                 my $value = $1;
                if ($priv eq 'bre') {                 if ($priv eq 'bre') {
                    my $deeplinkblock;                     if ($noblockcheck) {
                    unless ($nodeeplinkcheck) {  
                        $deeplinkblock = &deeplink_check($priv,$symb,$uri);  
                    }  
                    if ($deeplinkblock) {  
                        $thisallowed = 'D';  
                    } elsif ($noblockcheck) {  
                        $thisallowed.=$value;                         $thisallowed.=$value;
                    } else {                     } else {
                        my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);                         my @blockers = &has_comm_blocking($priv,$symb,$uri,$ignorecache);
Line 8422  sub allowed { Line 8282  sub allowed {
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   my $value = $1;                    my $value = $1;
                   if ($priv eq 'bre') {                    if ($priv eq 'bre') {
                       my $deeplinkblock;                        if ($noblockcheck) {
                       unless ($nodeeplinkcheck) {  
                           $deeplinkblock = &deeplink_check($priv,$symb,$refuri);  
                       }  
                       if ($deeplinkblock) {  
                           $thisallowed = 'D';  
                       } elsif ($noblockcheck) {  
                           $thisallowed.=$value;                            $thisallowed.=$value;
                       } else {                        } else {
                           my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);                            my @blockers = &has_comm_blocking($priv,'',$refuri,'',1);
Line 8608  sub allowed { Line 8462  sub allowed {
        }         }
    }     }
   
 # Restricted for deeplinked session?  
   
     if ($env{'request.deeplink.login'}) {  
         if ($env{'acc.deeplinkout'} && !$nodeeplinkout) {  
             if (!$symb) { $symb=&symbread($uri,1); }  
             if (($symb) && ($env{'acc.deeplinkout'}=~/\&\Q$symb\E\&/)) {  
                 return '';  
             }  
         }  
     }  
   
 # Restricted by state or randomout?  # Restricted by state or randomout?
   
    if ($thisallowed=~/X/) {     if ($thisallowed=~/X/) {
Line 8639  sub allowed { Line 8482  sub allowed {
  return 'A';   return 'A';
     } elsif ($thisallowed eq 'B') {      } elsif ($thisallowed eq 'B') {
         return 'B';          return 'B';
     } elsif ($thisallowed eq 'D') {  
         return 'D';  
     }      }
    return 'F';     return 'F';
 }  }
Line 8822  sub get_commblock_resources { Line 8663  sub get_commblock_resources {
                             }                              }
                         }                          }
                     }                      }
                     if ($interval[0] =~ /^(\d+)/) {                      if ($interval[0] =~ /^\d+$/) {
                         my $timelimit = $1;  
                         my $first_access;                          my $first_access;
                         if ($type eq 'resource') {                          if ($type eq 'resource') {
                             $first_access=&get_first_access($interval[1],$item);                              $first_access=&get_first_access($interval[1],$item);
Line 8833  sub get_commblock_resources { Line 8673  sub get_commblock_resources {
                             $first_access=&get_first_access($interval[1]);                              $first_access=&get_first_access($interval[1]);
                         }                          }
                         if ($first_access) {                          if ($first_access) {
                             my $timesup = $first_access+$timelimit;                              my $timesup = $first_access+$interval[0];
                             if ($timesup > $now) {                              if ($timesup > $now) {
                                 my $activeblock;                                  my $activeblock;
                                 if ($type eq 'resource') {                                  if ($type eq 'resource') {
Line 8958  sub has_comm_blocking { Line 8798  sub has_comm_blocking {
 }  }
 }  }
   
 sub deeplink_check {  
     my ($priv,$symb,$uri) = @_;  
     return unless ($env{'request.course.id'});  
     return unless ($priv eq 'bre');  
     return if ($env{'request.state'} eq 'construct');  
     return if ($env{'request.role.adv'});  
     my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};  
     my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};  
     my (%possibles,@symbs);  
     if (!$symb) {  
         $symb = &symbread($uri,1,1,1,\%possibles);  
     }  
     if ($symb) {  
         @symbs = ($symb);  
     } elsif (keys(%possibles)) {  
         @symbs = keys(%possibles);  
     }  
   
     my ($deeplink_symb,$allow);  
     if ($env{'request.deeplink.login'}) {  
         $deeplink_symb = &Apache::loncommon::deeplink_login_symb($cnum,$cdom);  
     }  
     foreach my $symb (@symbs) {  
         last if ($allow);  
         my $deeplink = &EXT("resource.0.deeplink",$symb);  
         if ($deeplink eq '') {  
             $allow = 1;  
         } else {  
             my ($state,$others,$listed,$scope,$protect) = split(/,/,$deeplink);  
             if ($state ne 'only') {  
                 $allow = 1;  
             } else {  
                 my $check_deeplink_entry;  
                 if ($protect ne 'none') {  
                     my ($acctype,$item) = split(/:/,$protect);  
                     if (($acctype eq 'ltic') && ($env{'user.linkprotector'})) {  
                         if (grep(/^\Q$item\Ec$/,split(/,/,$env{'user.linkprotector'}))) {  
                             $check_deeplink_entry = 1  
                         }  
                     } elsif (($acctype eq 'ltid') && ($env{'user.linkprotector'})) {  
                         if (grep(/^\Q$item\Ed$/,split(/,/,$env{'user.linkprotector'}))) {  
                             $check_deeplink_entry = 1;  
                         }  
                     } elsif (($acctype eq 'key') && ($env{'user.deeplinkkey'})) {  
                         if (grep(/^\Q$item\E$/,split(/,/,$env{'user.deeplinkkey'}))) {  
                             $check_deeplink_entry = 1;  
                         }  
                     }  
                 }  
                 if (($protect eq 'none') || ($check_deeplink_entry)) {  
                     if ($scope eq 'res') {  
                         if ($symb eq $deeplink_symb) {  
                             $allow = 1;  
                         }  
                     } elsif (($scope eq 'map') || ($scope eq 'rec')) {  
                         my ($map_from_symb,$map_from_login);  
                         $map_from_symb = &deversion((&decode_symb($symb))[0]);  
                         if ($deeplink_symb =~ /\.(page|sequence)$/) {  
                             $map_from_login = &deversion((&decode_symb($deeplink_symb))[2]);  
                         } else {  
                             $map_from_login = &deversion((&decode_symb($deeplink_symb))[0]);  
                         }  
                         if (($map_from_symb) && ($map_from_login)) {  
                             if ($map_from_symb eq $map_from_login) {  
                                 $allow = 1;  
                             } elsif ($scope eq 'rec') {  
                                 my @recurseup = &get_map_hierarchy($map_from_symb,$env{'request.course.id'});  
                                 if (grep(/^\Q$map_from_login\E$/,@recurseup)) {  
                                     $allow = 1;  
                                 }  
                             }  
                         }  
                     }  
                 }  
             }  
         }  
     }  
     return if ($allow);  
     return 1;  
 }  
   
 # -------------------------------- Deversion and split uri into path an filename  # -------------------------------- Deversion and split uri into path an filename
   
 #  #
Line 9744  sub auto_instsec_reformat { Line 9503  sub auto_instsec_reformat {
             my $info = &freeze_escape($instsecref);              my $info = &freeze_escape($instsecref);
             my $response=&reply('autoinstsecreformat:'.$cdom.':'.              my $response=&reply('autoinstsecreformat:'.$cdom.':'.
                                 $action.':'.$info,$server);                                  $action.':'.$info,$server);
             next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/);              next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_cmd)/);
             my @items = split(/&/,$response);              my @items = split(/&/,$response);
             foreach my $item (@items) {              foreach my $item (@items) {
                 my ($key,$value) = split(/=/,$item);                  my ($key,$value) = split(/=/,$item);
Line 9825  sub auto_export_grades { Line 9584  sub auto_export_grades {
             my $grades = &freeze_escape($gradesref);              my $grades = &freeze_escape($gradesref);
             my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.              my $response=&reply('encrypt:autoexportgrades:'.$cdom.':'.$cnum.':'.
                                 $info.':'.$grades,$homeserver);                                  $info.':'.$grades,$homeserver);
             unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/) {              unless ($response =~ /(con_lost|error|no_such_host|refused|unknown_cmd)/) {
                 my @items = split(/&/,$response);                  my @items = split(/&/,$response);
                 foreach my $item (@items) {                  foreach my $item (@items) {
                     my ($key,$value) = split('=',$item);                      my ($key,$value) = split('=',$item);
Line 10743  sub writecoursepref { Line 10502  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,$callercontext)=@_;          $course_owner,$crstype,$cnum,$context,$category)=@_;
     $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) {
             my $reload;              if (&usertools_access($ownername,$ownerdom,$category,undef,
             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 11790  sub resdata { Line 11544  sub resdata {
     return undef;      return undef;
 }  }
   
 sub get_domain_lti {  sub get_numsuppfiles {
     my ($cdom,$context) = @_;      my ($cnum,$cdom,$ignorecache)=@_;
     my ($name,$cachename,%lti);  
     if ($context eq 'consumer') {  
         $name = 'ltitools';  
     } elsif ($context eq 'provider') {  
         $name = 'lti';  
     } elsif ($context eq 'linkprot') {  
         $name = 'ltisec';  
     } else {  
         return %lti;  
     }  
   
     if ($context eq 'linkprot') {  
         $cachename = $context;  
     } else {  
         $cachename = $name;  
     }  
   
     my ($result,$cached)=&is_cached_new($cachename,$cdom);  
     if (defined($cached)) {  
         if (ref($result) eq 'HASH') {  
             %lti = %{$result};  
         }  
     } else {  
         my %domconfig = &get_dom('configuration',[$name],$cdom);  
         if (ref($domconfig{$name}) eq 'HASH') {  
             if ($context eq 'linkprot') {  
                 if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') {  
                     %lti = %{$domconfig{$name}{'linkprot'}};  
                 }  
             } else {  
                 %lti = %{$domconfig{$name}};  
             }  
             if (($context eq 'consumer') && (keys(%lti))) {  
                 my %encdomconfig = &get_dom('encconfig',[$name],$cdom,undef,1);  
                 if (ref($encdomconfig{$name}) eq 'HASH') {  
                     foreach my $id (keys(%lti)) {  
                         if (ref($encdomconfig{$name}{$id}) eq 'HASH') {  
                             foreach my $item ('key','secret') {  
                                 $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};  
                             }  
                         }  
                     }  
                 }  
             }  
         }  
         my $cachetime = 24*60*60;  
         &do_cache_new($cachename,$cdom,\%lti,$cachetime);  
     }  
     return %lti;  
 }  
   
 sub get_course_lti {  
     my ($cnum,$cdom) = @_;  
     my $hashid=$cdom.'_'.$cnum;  
     my %courselti;  
     my ($result,$cached)=&is_cached_new('courselti',$hashid);  
     if (defined($cached)) {  
         if (ref($result) eq 'HASH') {  
             %courselti = %{$result};  
         }  
     } else {  
         %courselti = &dump('lti',$cdom,$cnum,undef,undef,undef,1);  
         my $cachetime = 24*60*60;  
         &do_cache_new('courselti',$hashid,\%courselti,$cachetime);  
     }  
     return %courselti;  
 }  
   
 sub courselti_itemid {  
     my ($cnum,$cdom,$url,$method,$params,$context) = @_;  
     my ($chome,$itemid);  
     $chome = &homeserver($cnum,$cdom);  
     return if ($chome eq 'no_host');  
     if (ref($params) eq 'HASH') {  
         my $items = &freeze_escape($params);  
         my $rep;  
         if (grep { $_ eq $chome } current_machine_ids()) {  
             $rep = LONCAPA::Lond::crslti_itemid($cdom,$cnum,$url,$method,$params,$perlvar{'lonVersion'});  
         } else {  
             my $escurl = &escape($url);  
             my $escmethod = &escape($method);  
             my $items = &freeze_escape($params);  
             $rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$chome);  
         }  
         unless (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||  
                 ($rep eq 'unknown_cmd')) {  
             $itemid = $rep;  
         }  
     }  
     return $itemid;  
 }  
   
 sub domainlti_itemid {  
     my ($cdom,$url,$method,$params,$context) = @_;  
     my ($primary_id,$itemid);  
     $primary_id = &domain($cdom,'primary');  
     return if ($primary_id eq '');  
     if (ref($params) eq 'HASH') {  
         my $items = &freeze_escape($params);  
         my $rep;  
         if (grep { $_ eq $primary_id } current_machine_ids()) {  
             $rep = LONCAPA::Lond::domlti_itemid($cdom,$context,$url,$method,$params,$perlvar{'lonVersion'});  
         } else {  
             my $cnum = '';  
             my $escurl = &escape($url);  
             my $escmethod = &escape($method);  
             my $items = &freeze_escape($params);  
             $rep = &reply("encrypt:lti:$cdom:$cnum:$context:$escurl:$escmethod:$items",$primary_id);  
         }  
         unless (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||  
                 ($rep eq 'unknown_cmd')) {  
             $itemid = $rep;  
         }  
     }  
     return $itemid;  
 }  
   
 sub count_supptools {  
     my ($cnum,$cdom,$ignorecache,$reload)=@_;  
     my $hashid=$cnum.':'.$cdom;      my $hashid=$cnum.':'.$cdom;
     my ($numexttools,$cached);      my ($suppcount,$cached);
     unless ($ignorecache) {      unless ($ignorecache) {
         ($numexttools,$cached) = &is_cached_new('supptools',$hashid);          ($suppcount,$cached) = &is_cached_new('suppcount',$hashid);
     }      }
     unless (defined($cached)) {      unless (defined($cached)) {
         my $chome=&homeserver($cnum,$cdom);          my $chome=&homeserver($cnum,$cdom);
         $numexttools = 0;  
         unless ($chome eq 'no_host') {          unless ($chome eq 'no_host') {
             my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);              ($suppcount,my $errors) = (0,0);
             if (ref($supplemental) eq 'HASH') {              my $suppmap = 'supplemental.sequence';
                 if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {              ($suppcount,$errors) =
                     foreach my $key (keys(%{$supplemental->{'ids'}})) {                  &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
                         if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {  
                             $numexttools ++;  
                         }  
                     }  
                 }  
             }  
         }          }
         &do_cache_new('supptools',$hashid,$numexttools,600);          &do_cache_new('suppcount',$hashid,$suppcount,600);
     }      }
     return $numexttools;      return $suppcount;
 }  
   
 sub has_unhidden_suppfiles {  
     my ($cnum,$cdom,$ignorecache,$possdel)=@_;  
     my $hashid=$cnum.':'.$cdom;  
     my ($showsupp,$cached);  
     unless ($ignorecache) {  
         ($showsupp,$cached) = &is_cached_new('showsupp',$hashid);  
     }  
     unless (defined($cached)) {  
         my $chome=&homeserver($cnum,$cdom);  
         unless ($chome eq 'no_host') {  
             my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$ignorecache,$possdel);  
             if (ref($supplemental) eq 'HASH') {  
                 if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {  
                     foreach my $key (keys(%{$supplemental->{'ids'}})) {  
                         next if ($key =~ /\.sequence$/);  
                         if (ref($supplemental->{'ids'}->{$key}) eq 'ARRAY') {  
                             foreach my $id (@{$supplemental->{'ids'}->{$key}}) {  
                                 unless ($supplemental->{'hidden'}->{$id}) {  
                                     $showsupp = 1;  
                                     last;  
                                 }  
                             }  
                         }  
                         last if ($showsupp);  
                     }  
                 }  
             }  
         }  
         &do_cache_new('showsupp',$hashid,$showsupp,600);  
     }  
     return $showsupp;  
 }  }
   
 #  #
 # EXT resource caching routines  # EXT resource caching routines
 #  #
   
 {  
 # Cache (5 seconds) of map hierarchy for speedup of navmaps display  
 #  
 # The course for which we cache  
 my $cachedmapkey='';  
 # The cached recursive maps for this course  
 my %cachedmaps=();  
 # When this was last done  
 my $cachedmaptime='';  
   
 sub clear_EXT_cache_status {  sub clear_EXT_cache_status {
     &delenv('cache.EXT.');      &delenv('cache.EXT.');
 }  }
Line 12296  sub EXT { Line 11881  sub EXT {
  if ($space eq 'name') {   if ($space eq 'name') {
     return $ENV{'SERVER_NAME'};      return $ENV{'SERVER_NAME'};
         }          }
     } elsif ($realm eq 'client') {  
         if ($space eq 'remote_addr') {  
             return &get_requestor_ip();  
         }  
     }      }
     return '';      return '';
 }  }
Line 12333  sub check_group_parms { Line 11914  sub check_group_parms {
     return $coursereply;      return $coursereply;
 }  }
   
 sub get_map_hierarchy {  
     my ($mapname,$courseid) = @_;  
     my @recurseup = ();  
     if ($mapname) {  
         if (($cachedmapkey eq $courseid) &&  
             (abs($cachedmaptime-time)<5)) {  
             if (ref($cachedmaps{$mapname}) eq 'ARRAY') {  
                 return @{$cachedmaps{$mapname}};  
             }  
         }  
         my $navmap = Apache::lonnavmaps::navmap->new();  
         if (ref($navmap)) {  
             @recurseup = $navmap->recurseup_maps($mapname);  
             undef($navmap);  
             $cachedmaps{$mapname} = \@recurseup;  
             $cachedmaptime=time;  
             $cachedmapkey=$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().
     my ($courseid,@groups) = @_;      my ($courseid,@groups) = @_;
     @groups = sort(@groups);      @groups = sort(@groups);
Line 12442  sub metadata { Line 11999  sub metadata {
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|ext\.tool)$})) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
Line 12978  sub get_coursechange { Line 12535  sub get_coursechange {
 }  }
   
 sub devalidate_coursechange_cache {  sub devalidate_coursechange_cache {
     my ($cdom,$cnum)=@_;      my ($cnum,$cdom)=@_;
     my $hashid=$cdom.'_'.$cnum;      my $hashid=$cnum.':'.$cdom;
     &devalidate_cache_new('crschange',$hashid);      &devalidate_cache_new('crschange',$hashid);
 }  }
   
 sub get_suppchange {  
     my ($cdom,$cnum) = @_;  
     if ($cdom eq '' || $cnum eq '') {  
         return unless ($env{'request.course.id'});  
         $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};  
         $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};  
     }  
     my $hashid=$cdom.'_'.$cnum;  
     my ($change,$cached)=&is_cached_new('suppchange',$hashid);  
     if ((defined($cached)) && ($change ne '')) {  
         return $change;  
     } else {  
         my %crshash = &get('environment',['internal.supplementalchange'],$cdom,$cnum);  
         if ($crshash{'internal.supplementalchange'} eq '') {  
             $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};  
             if ($change eq '') {  
                 %crshash = &get('environment',['internal.created'],$cdom,$cnum);  
                 $change = $crshash{'internal.created'};  
             }  
         } else {  
             $change = $crshash{'internal.supplementalchange'};  
         }  
         my $cachetime = 600;  
         &do_cache_new('suppchange',$hashid,$change,$cachetime);  
     }  
     return $change;  
 }  
   
 sub devalidate_suppchange_cache {  
     my ($cdom,$cnum)=@_;  
     my $hashid=$cdom.'_'.$cnum;  
     &devalidate_cache_new('suppchange',$hashid);  
 }  
   
 sub update_supp_caches {  
     my ($cdom,$cnum) = @_;  
     my %servers = &internet_dom_servers($cdom);  
     my @ids=&current_machine_ids();  
     foreach my $server (keys(%servers)) {  
         next if (grep(/^\Q$server\E$/,@ids));  
         my $hashid=$cnum.':'.$cdom;  
         my $cachekey = &escape('showsupp').':'.&escape($hashid);  
         &remote_devalidate_cache($server,[$cachekey]);  
     }  
     &has_unhidden_suppfiles($cnum,$cdom,1,1);  
     &count_supptools($cnum,$cdom,1);  
     my $now = time;  
     if ($env{'request.course.id'} eq $cdom.'_'.$cnum) {  
         &Apache::lonnet::appenv({'request.course.suppupdated' => $now});  
     }  
     &put('environment',{'internal.supplementalchange' => $now},  
          $cdom,$cnum);  
     &Apache::lonnet::appenv(  
         {'course.'.$cdom.'_'.$cnum.'.internal.supplementalchange' => $now});  
     &do_cache_new('suppchange',$cdom.'_'.$cnum,$now,600);  
 }  
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 14401  sub clutter { Line 13901  sub clutter {
 # &logthis("Got a blank emb style");  # &logthis("Got a blank emb style");
     }      }
  }   }
     } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {  
         $thisfn='/adm/wrapper'.$thisfn;  
     }      }
     return $thisfn;      return $thisfn;
 }  }
Line 15474  prevents recursive calls to &allowed. Line 14972  prevents recursive calls to &allowed.
  2: browse allowed   2: browse allowed
  A: passphrase authentication needed   A: passphrase authentication needed
  B: access temporarily blocked because of a blocking event in a course.   B: access temporarily blocked because of a blocking event in a course.
  D: access blocked because access is required via session initiated via deep-link  
   
 =item *  =item *
   
Line 15767  data base, returning a hash that is keye Line 15264  data base, returning a hash that is keye
 values that are the resource value.  I believe that the timestamps and  values that are the resource value.  I believe that the timestamps and
 versions are also returned.  versions are also returned.
   
   get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's
   supplemental content area. This routine caches the number of files for
   10 minutes.
   
 =back  =back
   
 =head2 Course Modification  =head2 Course Modification
Removed from v.1.1172.2.146.2.9  
changed lines
  Added in v.1.1172.2.152

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