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

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1172.2.118.2.14 and 1.1172.2.146.2.20

version 1.1172.2.118.2.14, 2021/01/04 13:41:25 version 1.1172.2.146.2.20, 2024/03/29 17:58:49
Line 95  use Cache::Memcached; Line 95  use Cache::Memcached;
 use Digest::MD5;  use Digest::MD5;
 use Math::Random;  use Math::Random;
 use File::MMagic;  use File::MMagic;
   use Net::CIDR;
   use Sys::Hostname::FQDN();
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata;  use LONCAPA::lonmetadata;
Line 363  sub remote_devalidate_cache { Line 365  sub remote_devalidate_cache {
     return &reply('devalidatecache:'.&escape($cachestr),$lonhost);      return &reply('devalidatecache:'.&escape($cachestr),$lonhost);
 }  }
   
   sub sign_lti {
       my ($cdom,$cnum,$crsdef,$type,$context,$url,$ltinum,$keynum,$paramsref,$inforef) = @_;
       my $chome;
       if (&domain($cdom) ne '') {
           if ($crsdef) {
               $chome = &homeserver($cnum,$cdom);
           } else {
               $chome = &domain($cdom,'primary');
           }
       }
       if ($cdom && $chome && ($chome ne 'no_host')) {
           if ((ref($paramsref) eq 'HASH') &&
               (ref($inforef) eq 'HASH')) {
               my $rep;
               if (grep { $_ eq $chome } &current_machine_ids()) {
                   # domain information is hosted on this machine
                   $rep =
                       &LONCAPA::Lond::sign_lti_payload($cdom,$cnum,$crsdef,$type,
                                                        $context,$url,$ltinum,$keynum,
                                                        $perlvar{'lonVersion'},
                                                        $paramsref,$inforef);
                   if (ref($rep) eq 'HASH') {
                       return ('ok',$rep);
                   }
               } else {
                   my ($escurl,$params,$info);
                   $escurl = &escape($url);
                   if (ref($paramsref) eq 'HASH') {
                       $params = &freeze_escape($paramsref);
                   }
                   if (ref($inforef) eq 'HASH') {
                       $info = &freeze_escape($inforef);
                   }
                   $rep=&reply("encrypt:signlti:$cdom:$cnum:$crsdef:$type:$context:$escurl:$ltinum:$keynum:$params:$info",$chome);
               }
               if (($rep eq '') || ($rep =~ /^con_lost|error|no_such_host|unknown_cmd/i)) {
                   return ();
               } elsif (($inforef->{'respfmt'} eq 'to_post_body') ||
                        ($inforef->{'respfmt'} eq 'to_authorization_header')) {
                   return ('ok',$rep);
               } else {
                   my %returnhash;
                   foreach my $item (split(/\&/,$rep)) {
                       my ($name,$value)=split(/\=/,$item);
                       $returnhash{&unescape($name)}=&thaw_unescape($value);
                   }
                   return('ok',\%returnhash);
               }
           } else {
               return ();
           }
       } else {
           return ();
           &logthis("sign_lti failed - no homeserver and/or domain ($cdom) ($chome)");
       }
   }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
Line 416  sub reply { Line 475  sub reply {
             my $subcmd = $1;              my $subcmd = $1;
             if (($subcmd eq 'auth') || ($subcmd eq 'passwd') ||              if (($subcmd eq 'auth') || ($subcmd eq 'passwd') ||
                 ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||                  ($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
                 ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades')) {                  ($subcmd eq 'putdom') || ($subcmd eq 'autoexportgrades') ||
                   ($subcmd eq 'put')) {
                 (undef,undef,my @rest) = split(/:/,$cmd);                  (undef,undef,my @rest) = split(/:/,$cmd);
                 if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) {                  if (($subcmd eq 'auth') || ($subcmd eq 'putdom')) {
                     splice(@rest,2,1,'Hidden');                      splice(@rest,2,1,'Hidden');
                 } elsif ($subcmd eq 'passwd') {                  } elsif ($subcmd eq 'passwd') {
                     splice(@rest,2,2,('Hidden','Hidden'));                      splice(@rest,2,2,('Hidden','Hidden'));
                 } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||                  } elsif (($subcmd eq 'changeuserauth') || ($subcmd eq 'makeuser') ||
                          ($subcmd eq 'autoexportgrades')) {                           ($subcmd eq 'autoexportgrades') || ($subcmd eq 'put')) {
                     splice(@rest,3,1,'Hidden');                      splice(@rest,3,1,'Hidden');
                 }                  }
                 $logged = join(':',('encrypt:'.$subcmd,@rest));                  $logged = join(':',('encrypt:'.$subcmd,@rest));
Line 689  sub check_for_valid_session { Line 749  sub check_for_valid_session {
     if (ref($userhashref) eq 'HASH') {      if (ref($userhashref) eq 'HASH') {
         $userhashref->{'name'} = $disk_env{'user.name'};          $userhashref->{'name'} = $disk_env{'user.name'};
         $userhashref->{'domain'} = $disk_env{'user.domain'};          $userhashref->{'domain'} = $disk_env{'user.domain'};
           if ($disk_env{'request.role'}) {
               $userhashref->{'role'} = $disk_env{'request.role'};
           }
           $userhashref->{'lti'} = $disk_env{'request.lti.login'};
           if ($userhashref->{'lti'}) {
               $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
               $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
           }
     }      }
     untie(%disk_env);      untie(%disk_env);
   
Line 917  sub userload { Line 985  sub userload {
 # ------------------------------ Find server with least workload from spare.tab  # ------------------------------ Find server with least workload from spare.tab
   
 sub spareserver {  sub spareserver {
     my ($loadpercent,$userloadpercent,$want_server_name,$udom) = @_;      my ($r,$loadpercent,$userloadpercent,$want_server_name,$udom) = @_;
     my $spare_server;      my $spare_server;
     if ($userloadpercent !~ /\d/) { $userloadpercent=0; }      if ($userloadpercent !~ /\d/) { $userloadpercent=0; }
     my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent       my $lowest_load=($loadpercent > $userloadpercent) ? $loadpercent 
Line 962  sub spareserver { Line 1030  sub spareserver {
                 if ($protocol{$spare_server} eq 'https') {                  if ($protocol{$spare_server} eq 'https') {
                     $protocol = $protocol{$spare_server};                      $protocol = $protocol{$spare_server};
                 }                  }
                   my $alias = &Apache::lonnet::use_proxy_alias($r,$spare_server);
                   $hostname = $alias if ($alias ne '');
         $spare_server = $protocol.'://'.$hostname;          $spare_server = $protocol.'://'.$hostname;
             }              }
         }          }
Line 1028  sub find_existing_session { Line 1098  sub find_existing_session {
     return;      return;
 }  }
   
   sub delusersession {
       my ($lonid,$udom,$uname) = @_;
       my $uprimary_id = &domain($udom,'primary');
       my $uintdom = &internet_dom($uprimary_id);
       my $intdom = &internet_dom($lonid);
       my $serverhomedom = &host_domain($lonid);
       if (($uintdom ne '') && ($uintdom eq $intdom)) {
           return &reply(join(':','delusersession',
                               map {&escape($_)} ($udom,$uname)),$lonid);
       }
       return;
   }
   
   
 # check if user's browser sent load balancer cookie and server still has session  # check if user's browser sent load balancer cookie and server still has session
 # and is not overloaded.  # and is not overloaded.
 sub check_for_balancer_cookie {  sub check_for_balancer_cookie {
Line 1247  sub changepass { Line 1331  sub changepass {
 sub queryauthenticate {  sub queryauthenticate {
     my ($uname,$udom)=@_;      my ($uname,$udom)=@_;
     my $uhome=&homeserver($uname,$udom);      my $uhome=&homeserver($uname,$udom);
     if (!$uhome) {      if ((!$uhome) || ($uhome eq 'no_host')) {
  &logthis("User $uname at $udom is unknown when looking for authentication mechanism");   &logthis("User $uname at $udom is unknown when looking for authentication mechanism");
  return 'no_host';   return 'no_host';
     }      }
Line 1296  sub authenticate { Line 1380  sub authenticate {
     }      }
     if ($answer eq 'non_authorized') {      if ($answer eq 'non_authorized') {
  &logthis("User $uname at $udom rejected by $uhome");   &logthis("User $uname at $udom rejected by $uhome");
  return 'no_host';    return 'no_host';
     }      }
     &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");      &logthis("User $uname at $udom threw error $answer when checking authentication mechanism");
     return 'no_host';      return 'no_host';
 }  }
   
   sub can_switchserver {
       my ($udom,$home) = @_;
       my ($canswitch,@intdoms);
       my $internet_names = &get_internet_names($home);
       if (ref($internet_names) eq 'ARRAY') {
           @intdoms = @{$internet_names};
       }
       my $uint_dom = &internet_dom(&domain($udom,'primary'));
       if ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
           $canswitch = 1;
       } else {
            my $serverhomeID = &get_server_homeID(&hostname($home));
            my $serverhomedom = &host_domain($serverhomeID);
            my %defdomdefaults = &get_domain_defaults($serverhomedom);
            my %udomdefaults = &get_domain_defaults($udom);
            my $remoterev = &get_server_loncaparev('',$home);
            $canswitch = &can_host_session($udom,$home,$remoterev,
                                           $udomdefaults{'remotesessions'},
                                           $defdomdefaults{'hostedsessions'});
       }
       return $canswitch;
   }
   
 sub can_host_session {  sub can_host_session {
     my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;      my ($udom,$lonhost,$remoterev,$remotesessions,$hostedsessions) = @_;
     my $canhost = 1;      my $canhost = 1;
Line 1376  sub spare_can_host { Line 1483  sub spare_can_host {
             $canhost = 0;              $canhost = 0;
         }          }
     }      }
       if ($canhost) {
           if (ref($defdomdefaults{'offloadoth'}) eq 'HASH') {
               if ($defdomdefaults{'offloadoth'}{$try_server}) {
                   unless (&shared_institution($udom,$try_server)) {
                       $canhost = 0;
                   }
               }
           }
       }
     if (($canhost) && ($uint_dom)) {      if (($canhost) && ($uint_dom)) {
         my @intdoms;          my @intdoms;
         my $internet_names = &get_internet_names($try_server);          my $internet_names = &get_internet_names($try_server);
Line 1866  sub dump_dom { Line 1982  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)=@_;      my ($namespace,$storearr,$udom,$uhome,$encrypt)=@_;
     return if ($udom eq 'public');      return if ($udom eq 'public');
     my $items='';      my $items='';
     foreach my $item (@$storearr) {      foreach my $item (@$storearr) {
Line 1890  sub get_dom { Line 2006  sub get_dom {
     }      }
     if ($udom && $uhome && ($uhome ne 'no_host')) {      if ($udom && $uhome && ($uhome ne 'no_host')) {
         my $rep;          my $rep;
         if ($namespace =~ /^enc/) {          if (grep { $_ eq $uhome } &current_machine_ids()) {
             $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);              # domain information is hosted on this machine
               $rep = &LONCAPA::Lond::get_dom("getdom:$udom:$namespace:$items");
         } else {          } else {
             $rep=&reply("getdom:$udom:$namespace:$items",$uhome);              if ($encrypt) {
                   $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 1917  sub get_dom { Line 2038  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)=@_;      my ($namespace,$storehash,$udom,$uhome,$encrypt)=@_;
     if (!$udom) {      if (!$udom) {
         $udom=$env{'user.domain'};          $udom=$env{'user.domain'};
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
Line 1938  sub put_dom { Line 2059  sub put_dom {
             $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';              $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
         }          }
         $items=~s/\&$//;          $items=~s/\&$//;
         if ($namespace =~ /^enc/) {          if ($encrypt) {
             return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);              return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
         } else {          } else {
             return &reply("putdom:$udom:$namespace:$items",$uhome);              return &reply("putdom:$udom:$namespace:$items",$uhome);
Line 1976  sub del_dom { Line 2097  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 2018  sub retrieve_inst_usertypes { Line 2190  sub retrieve_inst_usertypes {
   
 sub is_domainimage {  sub is_domainimage {
     my ($url) = @_;      my ($url) = @_;
     if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+[^/]-) {      if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo|login)/+[^/]-) {
         if (&domain($1) ne '') {          if (&domain($1) ne '') {
             return '1';              return '1';
         }          }
Line 2254  sub inst_rulecheck { Line 2426  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).
Line 2287  sub inst_userrules { Line 2463  sub inst_userrules {
             } elsif ($check eq 'email') {              } elsif ($check eq 'email') {
                 $response=&reply('instemailrules:'.&escape($udom),                  $response=&reply('instemailrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
               } elsif ($check eq 'unamemap') {
                   $response=&reply('unamemaprules:'.&escape($udom),
                                    $homeserver);
             } else {              } else {
                 $response=&reply('instuserrules:'.&escape($udom),                  $response=&reply('instuserrules:'.&escape($udom),
                                  $homeserver);                                   $homeserver);
Line 2331  sub get_domain_defaults { Line 2510  sub get_domain_defaults {
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor','authordefaults',
                                   'coursecategories','autoenroll',                                    'selfenrollment','coursecategories',
                                   'helpsettings'],$domain);                                    'autoenroll','helpsettings',
                                     'wafproxy','ltisec','toolsec',
                                     'domexttool','exttool'],$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 2342  sub get_domain_defaults { Line 2523  sub get_domain_defaults {
         $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};          $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
         $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};          $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
         $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};          $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
           $domdefaults{'portal_def_email'} = $domconfig{'defaults'}{'portal_def_email'};
           $domdefaults{'portal_def_web'} = $domconfig{'defaults'}{'portal_def_web'};
         $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};          $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'};
         $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};          $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'};
         $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};          $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'};
           $domdefaults{'unamemap_rule'} = $domconfig{'defaults'}{'unamemap_rule'};
     } else {      } else {
         $domdefaults{'lang_def'} = &domain($domain,'lang_def');          $domdefaults{'lang_def'} = &domain($domain,'lang_def');
         $domdefaults{'auth_def'} = &domain($domain,'auth_def');          $domdefaults{'auth_def'} = &domain($domain,'auth_def');
Line 2371  sub get_domain_defaults { Line 2555  sub get_domain_defaults {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
       if (ref($domconfig{'authordefaults'}) eq 'HASH') {
           foreach my $item ('nocodemirror','copyright','sourceavail','domcoordacc','editors') {
               if ($item eq 'editors') {
                   if (ref($domconfig{'authordefaults'}{'editors'}) eq 'ARRAY') {
                       $domdefaults{$item} = join(',',@{$domconfig{'authordefaults'}{'editors'}});
                   }
               } else {
                   $domdefaults{$item} = $domconfig{'authordefaults'}{$item};
               }
           }
       }
     if (ref($domconfig{'requestauthor'}) eq 'HASH') {      if (ref($domconfig{'requestauthor'}) eq 'HASH') {
         $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};          $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
     }      }
Line 2381  sub get_domain_defaults { Line 2576  sub get_domain_defaults {
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};          $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
           $domdefaults{'inline_chem'} = $domconfig{'coursedefaults'}{'inline_chem'};
         $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};          $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
         if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
             $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};              $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
Line 2394  sub get_domain_defaults { Line 2590  sub get_domain_defaults {
             if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {              if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
                 $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};                  $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
             }              }
               if (ref($domconfig{'coursedefaults'}{'coursequota'}) eq 'HASH') {
                   $domdefaults{$type.'coursequota'} = $domconfig{'coursedefaults'}{'coursequota'}{$type};
               }
             if ($domdefaults{'postsubmit'} eq 'on') {              if ($domdefaults{'postsubmit'} eq 'on') {
                 if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {                  if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
                     $domdefaults{$type.'postsubtimeout'} =                      $domdefaults{$type.'postsubtimeout'} =
                         $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};                          $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
                 }                  }
             }              }
               if (ref($domconfig{'coursedefaults'}{'domexttool'}) eq 'HASH') {
                   $domdefaults{$type.'domexttool'} = $domconfig{'coursedefaults'}{'domexttool'}{$type};
               } else {
                   $domdefaults{$type.'domexttool'} = 1;
               }
               if (ref($domconfig{'coursedefaults'}{'exttool'}) eq 'HASH') {
                   $domdefaults{$type.'exttool'} = $domconfig{'coursedefaults'}{'exttool'}{$type};
               } else {
                   $domdefaults{$type.'exttool'} = 0;
               }
         }          }
         if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
             if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {              if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
Line 2414  sub get_domain_defaults { Line 2623  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 2425  sub get_domain_defaults { Line 2637  sub get_domain_defaults {
         if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {
             $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};              $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};
         }          }
           if (ref($domconfig{'usersessions'}{'offloadoth'}) eq 'HASH') {
               $domdefaults{'offloadoth'} = $domconfig{'usersessions'}{'offloadoth'};
           }
     }      }
     if (ref($domconfig{'selfenrollment'}) eq 'HASH') {      if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
         if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {          if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
Line 2466  sub get_domain_defaults { Line 2681  sub get_domain_defaults {
     }      }
     if (ref($domconfig{'autoenroll'}) eq 'HASH') {      if (ref($domconfig{'autoenroll'}) eq 'HASH') {
         $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};          $domdefaults{'autofailsafe'} = $domconfig{'autoenroll'}{'autofailsafe'};
           $domdefaults{'failsafe'} = $domconfig{'autoenroll'}{'failsafe'};
     }      }
     if (ref($domconfig{'helpsettings'}) eq 'HASH') {      if (ref($domconfig{'helpsettings'}) eq 'HASH') {
         $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};          $domdefaults{'submitbugs'} = $domconfig{'helpsettings'}{'submitbugs'};
Line 2473  sub get_domain_defaults { Line 2689  sub get_domain_defaults {
             $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};              $domdefaults{'adhocroles'} = $domconfig{'helpsettings'}{'adhoc'};
         }          }
     }      }
       if (ref($domconfig{'wafproxy'}) eq 'HASH') {
           foreach my $item ('ipheader','trusted','vpnint','vpnext','sslopt') {
               if ($domconfig{'wafproxy'}{$item}) {
                   $domdefaults{'waf_'.$item} = $domconfig{'wafproxy'}{$item};
               }
           }
       }
       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{'ltiprivhosts'} = $domconfig{'ltisec'}{'private'}{'keys'};
               }
           }
           if (ref($domconfig{'ltisec'}{'suggested'}) eq 'HASH') {
               my %suggestions = %{$domconfig{'ltisec'}{'suggested'}};
               foreach my $item (keys(%{$domconfig{'ltisec'}{'suggested'}})) {
                   unless (ref($domconfig{'ltisec'}{'suggested'}{$item}) eq 'HASH') {
                       delete($suggestions{$item});
                   }
               }
               if (keys(%suggestions)) {
                   $domdefaults{'linkprotsuggested'} = \%suggestions;
               }
           }
       }
       if (ref($domconfig{'toolsec'}) eq 'HASH') {
           if (ref($domconfig{'toolsec'}{'encrypt'}) eq 'HASH') {
               $domdefaults{'toolenc_crs'} = $domconfig{'toolsec'}{'encrypt'}{'crs'};
               $domdefaults{'toolenc_dom'} = $domconfig{'toolsec'}{'encrypt'}{'dom'};
           }
           if (ref($domconfig{'toolsec'}{'private'}) eq 'HASH') {
               if (ref($domconfig{'toolsec'}{'private'}{'keys'}) eq 'ARRAY') {
                   $domdefaults{'toolprivhosts'} = $domconfig{'toolsec'}{'private'}{'keys'};
               }
           }
       }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
 }  }
Line 2509  sub get_dom_instcats { Line 2766  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 2560  sub get_passwdconf { Line 2818  sub get_passwdconf {
 }  }
   
 sub course_portal_url {  sub course_portal_url {
     my ($cnum,$cdom) = @_;      my ($cnum,$cdom,$r) = @_;
     my $chome = &homeserver($cnum,$cdom);      my $chome = &homeserver($cnum,$cdom);
     my $hostname = &hostname($chome);      my $hostname = &hostname($chome);
     my $protocol = $protocol{$chome};      my $protocol = $protocol{$chome};
Line 2570  sub course_portal_url { Line 2828  sub course_portal_url {
     if ($domdefaults{'portal_def'}) {      if ($domdefaults{'portal_def'}) {
         $firsturl = $domdefaults{'portal_def'};          $firsturl = $domdefaults{'portal_def'};
     } else {      } else {
           my $alias = &Apache::lonnet::use_proxy_alias($r,$chome);
           $hostname = $alias if ($alias ne '');
         $firsturl = $protocol.'://'.$hostname;          $firsturl = $protocol.'://'.$hostname;
     }      }
     return $firsturl;      return $firsturl;
 }  }
   
   sub url_prefix {
       my ($r,$dom,$home,$context) = @_;
       my $prefix;
       my %domdefs = &get_domain_defaults($dom);
       if ($domdefs{'portal_def'} && $domdefs{'portal_def_'.$context}) {
           if ($domdefs{'portal_def'} =~ m{^(https?://[^/]+)}) {
               $prefix = $1;
           }
       }
       if ($prefix eq '') {
           my $hostname = &hostname($home);
           my $protocol = $protocol{$home};
           $protocol = 'http' if ($protocol{$home} ne 'https');
           my $alias = &use_proxy_alias($r,$home);
           $hostname = $alias if ($alias ne '');
           $prefix = $protocol.'://'.$hostname;
       }
       return $prefix;
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 3159  sub ssi_body { Line 3439  sub ssi_body {
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
   
 sub absolute_url {  sub absolute_url {
     my ($host_name) = @_;      my ($host_name,$unalias,$keep_proto) = @_;
     my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');      my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
     if ($host_name eq '') {      if ($host_name eq '') {
  $host_name = $ENV{'SERVER_NAME'};   $host_name = $ENV{'SERVER_NAME'};
     }      }
       if ($unalias) {
           my $alias = &get_proxy_alias();
           if ($alias eq $host_name) {
               my $lonhost = $perlvar{'lonHostID'};
               my $hostname = &hostname($lonhost);
               my $lcproto;
               if (($keep_proto) || ($hostname eq '')) {
                   $lcproto = $protocol;
               } else {
                   $lcproto = $protocol{$lonhost};
                   $lcproto = 'http' if ($lcproto ne 'https');
                   $lcproto .= '://';
               }
               unless ($hostname eq '') {
                   return $lcproto.$hostname;
               }
           }
       } 
     return $protocol.$host_name;      return $protocol.$host_name;
 }  }
   
Line 3180  sub absolute_url { Line 3478  sub absolute_url {
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
     my ($request,$response);      my ($host,$request,$response);
       $host = &absolute_url('',1);
   
     $form{'no_update_last_known'}=1;      $form{'no_update_last_known'}=1;
     &Apache::lonenc::check_encrypt(\$fn);      &Apache::lonenc::check_encrypt(\$fn);
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',&absolute_url().$fn);        $request=new HTTP::Request('POST',$host.$fn);
       $request->content(join('&',map {        $request->content(join('&',map {
             my $name = escape($_);              my $name = escape($_);
             "$name=" . ( ref($form{$_}) eq 'ARRAY'              "$name=" . ( ref($form{$_}) eq 'ARRAY'
Line 3193  sub ssi { Line 3492  sub ssi {
             : &escape($form{$_}) );              : &escape($form{$_}) );
         } keys(%form)));          } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',&absolute_url().$fn);        $request=new HTTP::Request('GET',$host.$fn);
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
Line 3764  sub clean_filename { Line 4063  sub clean_filename {
 # Replace all .\d. sequences with _\d. so they no longer look like version  # Replace all .\d. sequences with _\d. so they no longer look like version
 # numbers  # numbers
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/g;
   # Replace three or more adjacent underscores with one for consistency
   # with loncfile::filename_check() so complete url can be extracted by
   # lonnet::decode_symb()
       $fname=~s/_{3,}/_/g;
     return $fname;      return $fname;
 }  }
   
Line 3809  sub resizeImage { Line 4112  sub resizeImage {
 # input: $formname - the contents of the file are in $env{"form.$formname"}  # input: $formname - the contents of the file are in $env{"form.$formname"}
 #                    the desired filename is in $env{"form.$formname.filename"}  #                    the desired filename is in $env{"form.$formname.filename"}
 #        $context - possible values: coursedoc, existingfile, overwrite,   #        $context - possible values: coursedoc, existingfile, overwrite, 
 #                                    canceloverwrite, scantron or ''.   #                                    canceloverwrite, scantron, toollogo or ''. 
 #                   if 'coursedoc': upload to the current course  #                   if 'coursedoc': upload to the current course
 #                   if 'existingfile': write file to tmp/overwrites directory   #                   if 'existingfile': write file to tmp/overwrites directory 
 #                   if 'canceloverwrite': delete file written to tmp/overwrites directory  #                   if 'canceloverwrite': delete file written to tmp/overwrites directory
Line 3821  sub resizeImage { Line 4124  sub resizeImage {
 #                          Section => 4, CODE => 5, FirstQuestion => 9 }).  #                          Section => 4, CODE => 5, FirstQuestion => 9 }).
 #        $allfiles - reference to hash for embedded objects  #        $allfiles - reference to hash for embedded objects
 #        $codebase - reference to hash for codebase of java objects  #        $codebase - reference to hash for codebase of java objects
 #        $desuname - username for permanent storage of uploaded file  #        $destuname - username for permanent storage of uploaded file
 #        $dsetudom - domain for permanaent storage of uploaded file  #        $destudom - domain for permanaent storage of uploaded file
 #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image   #        $thumbwidth - width (pixels) of thumbnail to make for uploaded image 
 #        $thumbheight - height (pixels) of thumbnail to make for uploaded image  #        $thumbheight - height (pixels) of thumbnail to make for uploaded image
 #        $resizewidth - width (pixels) to which to resize uploaded image  #        $resizewidth - width (pixels) to which to resize uploaded image
Line 4032  sub finishuserfileupload { Line 4335  sub finishuserfileupload {
     if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {      if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
         my $input = $filepath.'/'.$file;          my $input = $filepath.'/'.$file;
         my $output = $filepath.'/'.'tn-'.$file;          my $output = $filepath.'/'.'tn-'.$file;
           my $makethumb;
         my $thumbsize = $thumbwidth.'x'.$thumbheight;          my $thumbsize = $thumbwidth.'x'.$thumbheight;
         my @args = ('convert','-sample',$thumbsize,$input,$output);          if ($context eq 'toollogo') {
         system({$args[0]} @args);              my ($fullwidth,$fullheight) = &check_dimensions($input);
         if (-e $filepath.'/'.'tn-'.$file) {              if ($fullwidth ne '' && $fullheight ne '') {
             $fetchthumb  = 1;                   if ($fullwidth > $thumbwidth && $fullheight > $thumbheight) {
                       $makethumb = 1;
                   }
               }
           } else {
               $makethumb = 1;
           }
           if ($makethumb) {
               my @args = ('convert','-sample',$thumbsize,$input,$output);
               system({$args[0]} @args);
               if (-e $filepath.'/'.'tn-'.$file) {
                   $fetchthumb  = 1;
               }
         }          }
     }      }
     
Line 4268  sub embedded_dependency { Line 4584  sub embedded_dependency {
     return;      return;
 }  }
   
   sub check_dimensions {
       my ($inputfile) = @_;
       my ($fullwidth,$fullheight);
       if (($inputfile =~ m|^[/\w.\-]+$|) && (-e $inputfile)) {
           my $mm = new File::MMagic;
           my $mime_type = $mm->checktype_filename($inputfile);
           if ($mime_type =~ m{^image/}) {
               if (open(PIPE,"identify $inputfile 2>&1 |")) {
                   my $imageinfo = <PIPE>;
                   if (!close(PIPE)) {
                       &Apache::lonnet::logthis("Failed to close PIPE opened to retrieve image information for $inputfile");
                   }
                   chomp($imageinfo);
                   my ($fullsize) =
                       ($imageinfo =~ /^\Q$inputfile\E\s+\w+\s+(\d+x\d+)/);
                   if ($fullsize) {
                       ($fullwidth,$fullheight) = split(/x/,$fullsize);
                   }
               }
           }
       }
       return ($fullwidth,$fullheight);
   }
   
 sub bubblesheet_converter {  sub bubblesheet_converter {
     my ($cdom,$fullpath,$config,$format) = @_;      my ($cdom,$fullpath,$config,$format) = @_;
     if ((&domain($cdom) ne '') &&      if ((&domain($cdom) ne '') &&
Line 4321  sub bubblesheet_converter { Line 4661  sub bubblesheet_converter {
                     next if (($num == 1) && ($csvoptions{'hdr'} == 1));                      next if (($num == 1) && ($csvoptions{'hdr'} == 1));
                     $line =~ s{[\r\n]+$}{};                      $line =~ s{[\r\n]+$}{};
                     my %found;                      my %found;
                     my @values = split(/,/,$line);                      my @values = split(/,/,$line,-1);
                     my ($qstart,$record);                      my ($qstart,$record);
                     for (my $i=0; $i<@values; $i++) {                      for (my $i=0; $i<@values; $i++) {
                         if ((($qstart ne '') && ($i > $qstart)) ||                          if ((($qstart ne '') && ($i > $qstart)) ||
Line 4504  sub get_scantronformat_file { Line 4844  sub get_scantronformat_file {
                 close($fh);                  close($fh);
             }              }
         }          }
           chomp(@lines);
     }      }
     return @lines;      return @lines;
 }  }
Line 4625  sub flushcourselogs { Line 4966  sub flushcourselogs {
             if (! defined($dom) || $dom eq '' ||               if (! defined($dom) || $dom eq '' || 
                 ! defined($name) || $name eq '') {                  ! defined($name) || $name eq '') {
                 my $cid = $env{'request.course.id'};                  my $cid = $env{'request.course.id'};
   #
   # FIXME 11/29/2021
   # Typo in rev. 1.458 (2003/12/09)??
   # These should likely by $env{'course.'.$cid.'.domain'} and $env{'course.'.$cid.'.num'}
   #
   # While these remain as $env{'request.'.$cid.'.domain'} and $env{'request.'.$cid.'.num'}
   # $dom and $name will always be null, so the &inc() call will default to storing this data
   # in a nohist_accesscount.db file for the user rather than the course.
   #
   # That said there is a lot of noise in the data being stored.
   # So counts for prtspool/  and adm/ etc. are recorded.
   #
   # A review of which items ending '___count' are written to %accesshash should likely be
   # made before deciding whether to set these to 'course.' instead of 'request.'
   #
   # Under the current scheme each user receives a nohist_accesscount.db file listing
   # accesses for things which are not published resources, regardless of course, and
   # there is not a nohist_accesscount.db file in a course, which might log accesses from
   # anyone in the course for things which are not published resources.
   #
   # For an author, nohist_accesscount.db ends up having records for other items
   # mixed up with the legitimate access counts for the author's published resources.
   #
                 $dom  = $env{'request.'.$cid.'.domain'};                  $dom  = $env{'request.'.$cid.'.domain'};
                 $name = $env{'request.'.$cid.'.num'};                  $name = $env{'request.'.$cid.'.num'};
             }              }
Line 4836  sub courserolelog { Line 5200  sub courserolelog {
             $storehash{'group'} = $sec;              $storehash{'group'} = $sec;
         } else {          } else {
             $storehash{'section'} = $sec;              $storehash{'section'} = $sec;
               my ($curruserdomstr,$newuserdomstr);
               if (exists($env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'})) {
                   $curruserdomstr = $env{'course.'.$env{'request.course.id'}.'.internal.userdomains'};
               } else {
                   my %courseinfo = &coursedescription($cdom.'/'.$cnum);
                   $curruserdomstr = $courseinfo{'internal.userdomains'};
               }
               if ($curruserdomstr ne '') {
                   my @udoms = split(/,/,$curruserdomstr);
                   unless (grep(/^\Q$domain\E/,@udoms)) {
                       push(@udoms,$domain);
                       $newuserdomstr = join(',',sort(@udoms));
                   }
               } else {
                   $newuserdomstr = $domain;
               }
               if ($newuserdomstr ne '') {
                   my $putresult = &put('environment',{ 'internal.userdomains' => $newuserdomstr },
                                        $cdom,$cnum);
                   if ($putresult eq 'ok') {
                       unless (($selfenroll) || ($context eq 'selfenroll')) {
                           if (($context eq 'createcourse') || ($context eq 'requestcourses') ||
                               ($context eq 'automated') || ($context eq 'domain')) {
                               $env{'course.'.$cdom.'_'.$cnum.'.internal.userdomains'} = $newuserdomstr;
                           } elsif ($env{'request.course.id'} eq $cdom.'_'.$cnum) {
                               &appenv({'course.'.$cdom.'_'.$cnum.'.internal.userdomains' => $newuserdomstr});
                           }
                       }
                   }
               }
         }          }
         &write_log('course',$namespace,\%storehash,$delflag,$username,          &write_log('course',$namespace,\%storehash,$delflag,$username,
                    $domain,$cnum,$cdom);                     $domain,$cnum,$cdom);
Line 5907  sub tmpreset { Line 6301  sub tmpreset {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my $path=LONCAPA::tempdir();    my $path=LONCAPA::tempdir();
   my %hash;    my %hash;
Line 5944  sub tmpstore { Line 6338  sub tmpstore {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my $now=time;    my $now=time;
   my %hash;    my %hash;
Line 5988  sub tmprestore { Line 6382  sub tmprestore {
   if (!$domain) { $domain=$env{'user.domain'}; }    if (!$domain) { $domain=$env{'user.domain'}; }
   if (!$stuname) { $stuname=$env{'user.name'}; }    if (!$stuname) { $stuname=$env{'user.name'}; }
   if ($domain eq 'public' && $stuname eq 'public') {    if ($domain eq 'public' && $stuname eq 'public') {
       $stuname=$ENV{'REMOTE_ADDR'};        $stuname=&get_requestor_ip();
   }    }
   my %returnhash;    my %returnhash;
   $namespace=~s/\//\_/g;    $namespace=~s/\//\_/g;
Line 6044  sub store { Line 6438  sub store {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};      $$storehash{'ip'}=&get_requestor_ip();
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
Line 6080  sub cstore { Line 6474  sub cstore {
     }      }
     if (!$home) { $home=$env{'user.home'}; }      if (!$home) { $home=$env{'user.home'}; }
   
     $$storehash{'ip'}=$ENV{'REMOTE_ADDR'};      $$storehash{'ip'}=&get_requestor_ip();
     $$storehash{'host'}=$perlvar{'lonHostID'};      $$storehash{'host'}=$perlvar{'lonHostID'};
   
     my $namevalue='';      my $namevalue='';
Line 6344  sub rolesinit { Line 6738  sub rolesinit {
     my %firstaccess = &dump('firstaccesstimes', $domain, $username);      my %firstaccess = &dump('firstaccesstimes', $domain, $username);
     my %timerinterval = &dump('timerinterval', $domain, $username);      my %timerinterval = &dump('timerinterval', $domain, $username);
     my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,      my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
         %timerintchk, %timerintenv);          %timerintchk, %timerintenv,%coauthorenv);
   
     foreach my $key (keys(%firstaccess)) {      foreach my $key (keys(%firstaccess)) {
         my ($cid, $rest) = split(/\0/, $key);          my ($cid, $rest) = split(/\0/, $key);
Line 6358  sub rolesinit { Line 6752  sub rolesinit {
   
     my %allroles=();      my %allroles=();
     my %allgroups=();      my %allgroups=();
       my %gotcoauconfig=();
       my %domdefaults=();
   
     for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {      for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
         my $role = $rolesdump{$area};          my $role = $rolesdump{$area};
Line 6409  sub rolesinit { Line 6805  sub rolesinit {
         } else {          } else {
         # Normal role, defined in roles.tab          # Normal role, defined in roles.tab
             &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);              &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
               if (($trole eq 'ca') || ($trole eq 'aa')) {
                   (undef,my ($audom,$auname)) = split(/\//,$area);
                   unless ($gotcoauconfig{$area}) {
                       my @ca_settings = ('authoreditors');
                       my %info = &userenvironment($audom,$auname,@ca_settings);
                       $gotcoauconfig{$area} = 1;
                       foreach my $item (@ca_settings) {
                           if (exists($info{$item})) {
                               my $name = $item;
                               if ($item eq 'authoreditors') {
                                   $name = 'editors';
                                   unless ($info{'authoreditors'}) {
                                       my %domdefs;
                                       if (ref($domdefaults{$audom}) eq 'HASH') {
                                           %domdefs = %{$domdefaults{$audom}};
                                       } else {
                                           %domdefs = &get_domain_defaults($audom);
                                           $domdefaults{$audom} = \%domdefs;
                                       }
                                       if ($domdefs{$name} ne '') {
                                           $info{'authoreditors'} = $domdefs{$name};
                                       } else {
                                           $info{'authoreditors'} = 'edit,xml';
                                       }
                                   }
                               }
                               $coauthorenv{"environment.internal.$name.$area"} = $info{$item};
                           }
                       }
                   }
               }
         }          }
   
         my $cid = $tdomain.'_'.$trest;          my $cid = $tdomain.'_'.$trest;
Line 6437  sub rolesinit { Line 6864  sub rolesinit {
     $env{'user.adv'} = $userroles{'user.adv'};      $env{'user.adv'} = $userroles{'user.adv'};
     $env{'user.rar'} = $userroles{'user.rar'};      $env{'user.rar'} = $userroles{'user.rar'};
   
     return (\%userroles,\%firstaccenv,\%timerintenv);      return (\%userroles,\%firstaccenv,\%timerintenv,\%coauthorenv);
 }  }
   
 sub set_arearole {  sub set_arearole {
Line 6498  sub course_adhocrole_privs { Line 6925  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 6786  sub set_adhoc_privileges { Line 7213  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 6861  sub unserialize { Line 7289  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)=@_;      my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys,$encrypt)=@_;
     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 6877  sub dump { Line 7305  sub dump {
                     $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
         return %{&unserialize($reply, $escapedkeys)};          return %{&unserialize($reply, $escapedkeys)};
     }      }
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);      my $rep;
       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 6937  sub currentdump { Line 7370  sub currentdump {
    #     #
    my %returnhash=();     my %returnhash=();
    #     #
    if ($rep eq 'unknown_cmd') {     if ($rep eq "unknown_cmd") { 
        # an old lond will not know currentdump         # an old lond will not know currentdump
        # Do a dump and make it look like a currentdump         # Do a dump and make it look like a currentdump
        my @tmp = &dumpstore($courseid,$sdom,$sname,'.');         my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
Line 7023  sub inc { Line 7456  sub inc {
 # --------------------------------------------------------------- put interface  # --------------------------------------------------------------- put interface
   
 sub put {  sub put {
    my ($namespace,$storehash,$udomain,$uname)=@_;     my ($namespace,$storehash,$udomain,$uname,$encrypt)=@_;
    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 7032  sub put { Line 7465  sub put {
        $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';         $items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
    }     }
    $items=~s/\&$//;     $items=~s/\&$//;
    return &reply("put:$udomain:$uname:$namespace:$items",$uhome);     if ($encrypt) {
          return &reply("encrypt:put:$udomain:$uname:$namespace:$items",$uhome);
      } else {
          return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
      }
 }  }
   
 # ------------------------------------------------------------ newput interface  # ------------------------------------------------------------ newput interface
Line 7297  sub portfolio_access { Line 7734  sub portfolio_access {
     if ($result) {      if ($result) {
         my %setters;          my %setters;
         if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {          if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
             my ($startblock,$endblock) =              my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) =
                 &Apache::loncommon::blockcheck(\%setters,'port',$unum,$udom);                  &Apache::loncommon::blockcheck(\%setters,'port',$clientip,$unum,$udom);
             if ($startblock && $endblock) {              if (($startblock && $endblock) || ($by_ip))  {
                 return 'B';                  return 'B';
             }              }
         } else {          } else {
             my ($startblock,$endblock) =              my ($startblock,$endblock,$triggerblock,$by_ip,$blockdo) =
                 &Apache::loncommon::blockcheck(\%setters,'port');                  &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
             if ($startblock && $endblock) {              if (($startblock && $endblock) || ($by_ip)) {
                 return 'B';                  return 'B';
             }              }
         }          }
Line 7546  sub is_portfolio_file { Line 7983  sub is_portfolio_file {
     return;      return;
 }  }
   
   sub is_coursetool_logo {
       my ($uri) = @_;
       if ($env{'request.course.id'}) {
           my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
           if ($uri =~ m{^/*uploaded\Q$courseurl\E/toollogo/\d+/[^/]+$}) {
               return 1;
           }
       }
       return;
   }
   
 sub usertools_access {  sub usertools_access {
     my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;      my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
     my ($access,%tools);      my ($access,%tools);
Line 7558  sub usertools_access { Line 8006  sub usertools_access {
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                       textbook   => 1,                        textbook   => 1,
                         lti        => 1,
                  );                   );
     } elsif ($context eq 'requestauthor') {      } elsif ($context eq 'requestauthor') {
         %tools = (          %tools = (
                       requestauthor => 1,                        requestauthor => 1,
                  );                   );
       } elsif ($context eq 'authordefaults') {
           %tools = (
                         webdav    => 1,
                    );
     } else {      } else {
         %tools = (          %tools = (
                       aboutme   => 1,                        aboutme   => 1,
                       blog      => 1,                        blog      => 1,
                       webdav    => 1,  
                       portfolio => 1,                        portfolio => 1,
                         timezone  => 1,
                  );                   );
     }      }
     return if (!defined($tools{$tool}));      return if (!defined($tools{$tool}));
Line 7584  sub usertools_access { Line 8037  sub usertools_access {
                 return $env{'environment.canrequest.'.$tool};                  return $env{'environment.canrequest.'.$tool};
             } elsif ($context eq 'requestauthor') {              } elsif ($context eq 'requestauthor') {
                 return $env{'environment.canrequest.author'};                  return $env{'environment.canrequest.author'};
               } elsif ($context eq 'authordefaults') {
                   if ($tool eq 'webdav') {
                       return $env{'environment.availabletools.'.$tool};
                   }
             } else {              } else {
                 return $env{'environment.availabletools.'.$tool};                  return $env{'environment.availabletools.'.$tool};
             }              }
Line 7593  sub usertools_access { Line 8050  sub usertools_access {
     my ($toolstatus,$inststatus,$envkey);      my ($toolstatus,$inststatus,$envkey);
     if ($context eq 'requestauthor') {      if ($context eq 'requestauthor') {
         $envkey = $context;          $envkey = $context;
       } elsif ($context eq 'authordefaults') {
           if ($tool eq 'webdav') {
               $envkey = 'tools.'.$tool;
           }
     } else {      } else {
         $envkey = $context.'.'.$tool;          $envkey = $context.'.'.$tool;
     }      }
Line 7754  sub is_advanced_user { Line 8215  sub is_advanced_user {
 }  }
   
 sub check_can_request {  sub check_can_request {
     my ($dom,$can_request,$request_domains) = @_;      my ($dom,$can_request,$request_domains,$uname,$udom) = @_;
     my $canreq = 0;      my $canreq = 0;
       if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
           $uname = $env{'user.name'};
           $udom = $env{'user.domain'};
       }
     my ($types,$typename) = &Apache::loncommon::course_types();      my ($types,$typename) = &Apache::loncommon::course_types();
     my @options = ('approval','validate','autolimit');      my @options = ('approval','validate','autolimit');
     my $optregex = join('|',@options);      my $optregex = join('|',@options);
     if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {      if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
         foreach my $type (@{$types}) {          foreach my $type (@{$types}) {
             if (&usertools_access($env{'user.name'},              if (&usertools_access($uname,$udom,$type,undef,
                                   $env{'user.domain'},                                    'requestcourses')) {
                                   $type,undef,'requestcourses')) {  
                 $canreq ++;                  $canreq ++;
                 if (ref($request_domains) eq 'HASH') {                  if (ref($request_domains) eq 'HASH') {
                     push(@{$request_domains->{$type}},$env{'user.domain'});                      push(@{$request_domains->{$type}},$udom);
                 }                  }
                 if ($dom eq $env{'user.domain'}) {                  if ($dom eq $udom) {
                     $can_request->{$type} = 1;                      $can_request->{$type} = 1;
                 }                  }
             }              }
             if ($env{'environment.reqcrsotherdom.'.$type} ne '') {              if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
                   ($env{'environment.reqcrsotherdom.'.$type} ne '')) {
                 my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});                  my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
                 if (@curr > 0) {                  if (@curr > 0) {
                     foreach my $item (@curr) {                      foreach my $item (@curr) {
Line 7789  sub check_can_request { Line 8254  sub check_can_request {
                             }                              }
                         }                          }
                     }                      }
                     unless($dom eq $env{'user.domain'}) {                      unless ($dom eq $env{'user.domain'}) {
                         $canreq ++;                          $canreq ++;
                         if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {                          if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
                             $can_request->{$type} = 1;                              $can_request->{$type} = 1;
Line 7854  sub customaccess { Line 8319  sub customaccess {
 # ------------------------------------------------- Check for a user privilege  # ------------------------------------------------- Check for a user privilege
   
 sub allowed {  sub allowed {
     my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache)=@_;      my ($priv,$uri,$symb,$role,$clientip,$noblockcheck,$ignorecache,$nodeeplinkcheck,$nodeeplinkout)=@_;
     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  # Evade communication block restrictions for specified role in a course or domain
         if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {          if ($env{'user.priv.'.$role} =~/evb\&([^\:]*)/) {
             return $1;              return $1;
         } else {          } else {
Line 7882  sub allowed { Line 8347  sub allowed {
     if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&       if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) && 
  ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {   ($env{'user.domain'} eq $domain) && ('portfolio' eq $dir[0])) {
         my %setters;          my %setters;
         my ($startblock,$endblock) =           my ($startblock,$endblock,$triggerblock,$by_ip,$blockdom) = 
             &Apache::loncommon::blockcheck(\%setters,'port');              &Apache::loncommon::blockcheck(\%setters,'port',$clientip);
         if ($startblock && $endblock) {          if (($startblock && $endblock) || ($by_ip)) {
             return 'B';              return 'B';
         } else {          } else {
             return 'F';              return 'F';
Line 7919  sub allowed { Line 8384  sub allowed {
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
         my $copyright=&metadata($uri,'copyright');          my $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 7977  sub allowed { Line 8445  sub allowed {
                         my $adom = $1;                          my $adom = $1;
                         foreach my $key (keys(%env)) {                          foreach my $key (keys(%env)) {
                             if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {                              if ($key =~ m{^user\.role\.(ca|aa)/\Q$adom\E}) {
                                 my ($start,$end) = split('.',$env{$key});                                  my ($start,$end) = split(/\./,$env{$key});
                                 if (($now >= $start) && (!$end || $end < $now)) {                                  if (($now >= $start) && (!$end || $end > $now)) {
                                     $ownaccess = 1;                                      $ownaccess = 1;
                                     last;                                      last;
                                 }                                  }
Line 7990  sub allowed { Line 8458  sub allowed {
                         foreach my $role ('ca','aa') {                           foreach my $role ('ca','aa') { 
                             if ($env{"user.role.$role./$adom/$aname"}) {                              if ($env{"user.role.$role./$adom/$aname"}) {
                                 my ($start,$end) =                                  my ($start,$end) =
                                     split('.',$env{"user.role.$role./$adom/$aname"});                                      split(/\./,$env{"user.role.$role./$adom/$aname"});
                                 if (($now >= $start) && (!$end || $end < $now)) {                                  if (($now >= $start) && (!$end || $end > $now)) {
                                     $ownaccess = 1;                                      $ownaccess = 1;
                                     last;                                      last;
                                 }                                  }
Line 8076  sub allowed { Line 8544  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;
                 if ($noblockcheck) {                  my $deeplinkblock;
                   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 8096  sub allowed { Line 8570  sub allowed {
                     $refuri=&declutter($refuri);                      $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);                      my ($match) = &is_on_map($refuri);
                     if ($match) {                      if ($match) {
                         if ($noblockcheck) {                          my $deeplinkblock;
                           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 8118  sub allowed { Line 8598  sub allowed {
  && &is_portfolio_url($uri)) {   && &is_portfolio_url($uri)) {
  $thisallowed = &portfolio_access($uri,$clientip);   $thisallowed = &portfolio_access($uri,$clientip);
     }      }
       
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
  return 'F';   return 'F';
Line 8146  sub allowed { Line 8626  sub allowed {
   
     if ($env{'request.course.id'}) {      if ($env{'request.course.id'}) {
   
           if ($priv eq 'bre') {
               if (&is_coursetool_logo($uri)) {
                   return 'F';
               }
           }
   
 # If this is modifying password (internal auth) domains must match for user and user's role.  # If this is modifying password (internal auth) domains must match for user and user's role.
   
         if ($priv eq 'mip') {          if ($priv eq 'mip') {
Line 8169  sub allowed { Line 8655  sub allowed {
                =~/\Q$priv\E\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                my $value = $1;                 my $value = $1;
                if ($priv eq 'bre') {                 if ($priv eq 'bre') {
                    if ($noblockcheck) {                     my $deeplinkblock;
                      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 8211  sub allowed { Line 8703  sub allowed {
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   my $value = $1;                    my $value = $1;
                   if ($priv eq 'bre') {                    if ($priv eq 'bre') {
                       if ($noblockcheck) {                        my $deeplinkblock;
                         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 8256  sub allowed { Line 8754  sub allowed {
 #  #
   
 # Possibly locked functionality, check all courses  # Possibly locked functionality, check all courses
   # In roles.tab, L (unless locked) available for bre, pch, plc, pac and sma.
 # Locks might take effect only after 10 minutes cache expiration for other  # Locks might take effect only after 10 minutes cache expiration for other
 # courses, and 2 minutes for current course  # courses, and 2 minutes for current course, in which user has st or ta role
   # which is neither expired nor a future role (unless current course).
   
     my $envkey;      my ($needlockcheck,$now,$crsonly);
     if ($thisallowed=~/L/) {      if ($thisallowed=~/L/) {
         foreach $envkey (keys(%env)) {          $now = time;
           if ($priv eq 'bre') {
               if ($uri ne '') {
                   if ($orguri =~ m{^/+res/}) {
                       if ($uri =~ m{^lib/templates/}) {
                           if ($env{'request.course.id'}) {
                               $crsonly = 1;
                               $needlockcheck = 1;
                           }
                       } else {
                           $needlockcheck = 1;
                       }
                   } elsif ($env{'request.course.id'}) {
                       my ($crsdom,$crsnum) = split('_',$env{'request.course.id'});
                       if (($uri =~ m{^(adm|uploaded|public)/$crsdom/$crsnum/}) ||
                           ($uri =~ m{^adm/$match_domain/$match_username/\d+/(smppg|bulletinboard)$})) {
                           $crsonly = 1;
                       }
                       $needlockcheck = 1;
                   }
               }
           } elsif (($priv eq 'pch') || ($priv eq 'plc') || ($priv eq 'pac') || ($priv eq 'sma')) {
               $needlockcheck = 1;
           }
       }
       if ($needlockcheck) {
           foreach my $envkey (keys(%env)) {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;                 my $courseid=$2;
                my $roleid=$1.'.'.$2;                 my $roleid=$1.'.'.$2;
                $courseid=~s/^\///;                 $courseid=~s/^\///;
                  unless ($env{'request.role'} eq $roleid) {
                      my ($start,$end) = split(/\./,$env{$envkey});
                      next unless (($now >= $start) && (!$end || $end > $now));
                  }
                my $expiretime=600;                 my $expiretime=600;
                if ($env{'request.role'} eq $roleid) {                 if ($env{'request.role'} eq $roleid) {
   $expiretime=120;    $expiretime=120;
Line 8288  sub allowed { Line 8818  sub allowed {
                }                 }
                if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)                 if (($env{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,\Q$csec\E\,/)
                 || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {                  || ($env{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
    if ($env{'priv.'.$priv.'.lock.expire'}>time) {     if ($env{$prefix.'priv.'.$priv.'.lock.expire'}>time) {
                        &log($env{'user.domain'},$env{'user.name'},                         &log($env{'user.domain'},$env{'user.name'},
                             $env{'user.home'},                              $env{'user.home'},
                             'Locked by priv: '.$priv.' for '.$uri.' due to '.                              'Locked by priv: '.$priv.' for '.$uri.' due to '.
Line 8359  sub allowed { Line 8889  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 8379  sub allowed { Line 8920  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 8395  sub constructaccess { Line 8938  sub constructaccess {
     my ($ownername,$ownerdomain,$ownerhome);      my ($ownername,$ownerdomain,$ownerhome);
   
     ($ownerdomain,$ownername) =      ($ownerdomain,$ownername) =
         ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)(?:/|$)});          ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)(?:/|$)});
   
 # The URL does not really point to any authorspace, forget it  # The URL does not really point to any authorspace, forget it
     unless (($ownername) && ($ownerdomain)) { return ''; }      unless (($ownername) && ($ownerdomain)) { return ''; }
Line 8505  sub get_commblock_resources { Line 9048  sub get_commblock_resources {
     my ($blocks) = @_;      my ($blocks) = @_;
     my %blockers = ();      my %blockers = ();
     return %blockers unless ($env{'request.course.id'});      return %blockers unless ($env{'request.course.id'});
     return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);      my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
       if ($env{'request.course.sec'}) {
           $courseurl .= '/'.$env{'request.course.sec'};
       }
       return %blockers if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
     my %commblocks;      my %commblocks;
     if (ref($blocks) eq 'HASH') {      if (ref($blocks) eq 'HASH') {
         %commblocks = %{$blocks};          %commblocks = %{$blocks};
Line 8537  sub get_commblock_resources { Line 9084  sub get_commblock_resources {
             }              }
         } elsif ($block =~ /^firstaccess____(.+)$/) {          } elsif ($block =~ /^firstaccess____(.+)$/) {
             my $item = $1;              my $item = $1;
             my @to_test;  
             if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {              if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                 if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {                  if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                     my @interval;                      my (@interval,$mapname);
                     my $type = 'map';                      my $type = 'map';
                     if ($item eq 'course') {                      if ($item eq 'course') {
                         $type = 'course';                          $type = 'course';
Line 8549  sub get_commblock_resources { Line 9095  sub get_commblock_resources {
                         if ($item =~ /___\d+___/) {                          if ($item =~ /___\d+___/) {
                             $type = 'resource';                              $type = 'resource';
                             @interval=&EXT("resource.0.interval",$item);                              @interval=&EXT("resource.0.interval",$item);
                             if (ref($navmap)) {  
                                 my $res = $navmap->getBySymb($item);  
                                 push(@to_test,$res);  
                             }  
                         } else {                          } else {
                             my $mapsymb = &symbread($item,1);                              $mapname = &deversion($item);
                             if ($mapsymb) {                              if (ref($navmap)) {
                                 if (ref($navmap)) {                                  my $timelimit = $navmap->get_mapparam(undef,$mapname,'0.interval');
                                     my $mapres = $navmap->getBySymb($mapsymb);                                  @interval = ($timelimit,'map');
                                     if (ref($mapres)) {  
                                         my $first = $mapres->map_start();  
                                         my $finish = $mapres->map_finish();  
                                         my $it = $navmap->getIterator($first,$finish,undef,0,0);  
                                         if (ref($it)) {  
                                             my $res;  
                                             while ($res = $it->next(undef,1)) {  
                                                 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;  
                                                     }  
                                                 }  
                                             }  
                                         }  
                                     }  
                                 }  
                             }                              }
                         }                          }
                     }                      }
                     if ($interval[0] =~ /^(\d+)/) {                      if ($interval[0] =~ /^(\d+)/) {
                         my $timelimit = $1;                           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 8596  sub get_commblock_resources { Line 9117  sub get_commblock_resources {
                             my $timesup = $first_access+$timelimit;                              my $timesup = $first_access+$timelimit;
                             if ($timesup > $now) {                              if ($timesup > $now) {
                                 my $activeblock;                                  my $activeblock;
                                 foreach my $res (@to_test) {                                  if ($type eq 'resource') {
                                     if ($res->answerable()) {                                      if (ref($navmap)) {
                                         $activeblock = 1;                                          my $res = $navmap->getBySymb($item);
                                         last;                                          if ($res->answerable()) {
                                               $activeblock = 1;
                                           }
                                       }
                                   } elsif ($type eq 'map') {
                                       my $mapsymb = &symbread($mapname,1);
                                       if (($mapsymb) && (ref($navmap))) {
                                           my $mapres = $navmap->getBySymb($mapsymb);
                                           if (ref($mapres)) {
                                               my $first = $mapres->map_start();
                                               my $finish = $mapres->map_finish();
                                               my $it = $navmap->getIterator($first,$finish,undef,0,0);
                                               if (ref($it)) {
                                                   my $res;
                                                   while ($res = $it->next(undef,1)) {
                                                       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()) {
                                                               $activeblock = 1;
                                                               last;
                                                           }
                                                       }
                                                   }
                                               }
                                           }
                                     }                                      }
                                 }                                  }
                                 if ($activeblock) {                                  if ($activeblock) {
Line 8629  sub has_comm_blocking { Line 9177  sub has_comm_blocking {
     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{'request.state'} eq 'construct');      return if ($env{'request.state'} eq 'construct');
       my $courseurl = &courseid_to_courseurl($env{'request.course.id'});
       if ($env{'request.course.sec'}) {
           $courseurl .= '/'.$env{'request.course.sec'};
       }
       return if ($env{'user.priv.'.$env{'request.role'}.'.'.$courseurl} =~/evb\&([^\:]*)/);
     my %blockinfo;      my %blockinfo;
     if (ref($blocks) eq 'HASH') {      if (ref($blocks) eq 'HASH') {
         %blockinfo = &get_commblock_resources($blocks);          %blockinfo = &get_commblock_resources($blocks);
Line 8687  sub has_comm_blocking { Line 9239  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 9081  sub auto_validate_instcode { Line 9714  sub auto_validate_instcode {
     return ($outcome,$description,$defaultcredits);      return ($outcome,$description,$defaultcredits);
 }  }
   
   sub auto_validate_inst_crosslist {
       my ($cnum,$cdom,$instcode,$inst_xlist,$coowner) = @_;
       my ($homeserver,$response);
       if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
           $homeserver = &homeserver($cnum,$cdom);
       }
       if (!defined($homeserver)) {
           if ($cdom =~ /^$match_domain$/) {
               $homeserver = &domain($cdom,'primary');
           }
       }
       unless (($homeserver eq '') || ($homeserver eq 'no_host')) {
           $response=&reply('autovalidateinstcrosslist:'.$cdom.':'.
                            &escape($instcode).':'.&escape($inst_xlist).':'.
                            &escape($coowner),$homeserver);
       }
       return $response;
   }
   
 sub auto_create_password {  sub auto_create_password {
     my ($cnum,$cdom,$authparam,$udom) = @_;      my ($cnum,$cdom,$authparam,$udom) = @_;
     my ($homeserver,$response);      my ($homeserver,$response);
Line 9352  sub auto_validate_class_sec { Line 10004  sub auto_validate_class_sec {
     return $response;      return $response;
 }  }
   
   sub auto_instsec_reformat {
       my ($cdom,$action,$instsecref) = @_;
       return unless(($action eq 'clutter') || ($action eq 'declutter'));
       my @homeservers;
       if (defined(&domain($cdom,'primary'))) {
           push(@homeservers,&domain($cdom,'primary'));
       } else {
           my %servers = &get_servers($cdom,'library');
           foreach my $tryserver (keys(%servers)) {
               if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                   push(@homeservers,$tryserver);
               }
           }
       }
       my $response;
       my %reformatted = %{$instsecref};
       foreach my $server (@homeservers) {
           if (ref($instsecref) eq 'HASH') {
               my $info = &freeze_escape($instsecref);
               my $response=&reply('autoinstsecreformat:'.$cdom.':'.
                                   $action.':'.$info,$server);
               next if ($response =~ /(con_lost|error|no_such_host|refused|unknown_command)/);
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split(/=/,$item);
                   $reformatted{&unescape($key)} = &thaw_unescape($value);
               }
           }
       }
       return %reformatted;
   }
   
 sub auto_validate_instclasses {  sub auto_validate_instclasses {
     my ($cdom,$cnum,$owners,$classesref) = @_;      my ($cdom,$cnum,$owners,$classesref) = @_;
     my ($homeserver,%validations);      my ($homeserver,%validations);
Line 9756  sub assignrole { Line 10440  sub assignrole {
                             }                              }
                         }                          }
                     }                      }
                 } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {                  } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
                     $refused = '';                      if ($role eq 'st') {
                           $refused = '';
                       } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
                           $refused = '';
                       }
                 } elsif ($context eq 'requestcourses') {                  } elsif ($context eq 'requestcourses') {
                     my @possroles = ('st','ta','ep','in','cc','co');                      my @possroles = ('st','ta','ep','in','cc','co');
                     if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {                      if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
Line 9896  sub autoupdate_coowners { Line 10584  sub autoupdate_coowners {
         if ($domdesign{$cdom.'.autoassign.co-owners'}) {          if ($domdesign{$cdom.'.autoassign.co-owners'}) {
             my %coursehash = &coursedescription($cdom.'_'.$cnum);              my %coursehash = &coursedescription($cdom.'_'.$cnum);
             my $instcode = $coursehash{'internal.coursecode'};              my $instcode = $coursehash{'internal.coursecode'};
               my $xlists = $coursehash{'internal.crosslistings'};
             if ($instcode ne '') {              if ($instcode ne '') {
                 if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {                  if (($start && $start <= $now) && ($end == 0) || ($end > $now)) {
                     unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {                      unless ($coursehash{'internal.courseowner'} eq $uname.':'.$udom) {
                         my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);                          my ($delcoowners,@newcoowners,$putresult,$delresult,$coowners);
                         my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);                          my ($result,$desc) = &auto_validate_instcode($cnum,$cdom,$instcode,$uname.':'.$udom);
                           unless ($result eq 'valid') {
                               if ($xlists ne '') {
                                   foreach my $xlist (split(',',$xlists)) {
                                       my ($inst_crosslist,$lcsec) = split(':',$xlist);
                                       $result =
                                           &auto_validate_inst_crosslist($cnum,$cdom,$instcode,
                                                                         $inst_crosslist,$uname.':'.$udom);
                                       last if ($result eq 'valid');
                                   }
                               }
                           }
                         if ($result eq 'valid') {                          if ($result eq 'valid') {
                             if ($coursehash{'internal.co-owners'}) {                              if ($coursehash{'internal.co-owners'}) {
                                 foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {                                  foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
Line 9913  sub autoupdate_coowners { Line 10613  sub autoupdate_coowners {
                             } else {                              } else {
                                 push(@newcoowners,$uname.':'.$udom);                                  push(@newcoowners,$uname.':'.$udom);
                             }                              }
                         } else {                          } elsif ($coursehash{'internal.co-owners'}) {
                             if ($coursehash{'internal.co-owners'}) {                              foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {
                                 foreach my $coowner (split(',',$coursehash{'internal.co-owners'})) {                                  unless ($coowner eq $uname.':'.$udom) {
                                     unless ($coowner eq $uname.':'.$udom) {                                      push(@newcoowners,$coowner);
                                         push(@newcoowners,$coowner);  
                                     }  
                                 }  
                                 unless (@newcoowners > 0) {  
                                     $delcoowners = 1;  
                                     $coowners = '';  
                                 }                                  }
                             }                              }
                               unless (@newcoowners > 0) {
                                   $delcoowners = 1;
                                   $coowners = '';
                               }
                         }                          }
                         if (@newcoowners || $delcoowners) {                          if (@newcoowners || $delcoowners) {
                             &store_coowners($cdom,$cnum,$coursehash{'home'},                              &store_coowners($cdom,$cnum,$coursehash{'home'},
Line 10039  sub modifyuser { Line 10737  sub modifyuser {
     my $newuser;      my $newuser;
     if ($uhome eq 'no_host') {      if ($uhome eq 'no_host') {
         $newuser = 1;          $newuser = 1;
           unless (($umode && ($upass ne '')) || ($umode eq 'localauth') ||
                   ($umode eq 'lti')) {
               return 'error: more information needed to create new user';
           }
     }      }
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') &&       if (($uhome eq 'no_host') && 
  (($umode && $upass) || ($umode eq 'localauth'))) {   (($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) {
         my $unhome='';          my $unhome='';
         if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {           if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { 
             $unhome = $desiredhome;              $unhome = $desiredhome;
Line 11351  sub get_userresdata { Line 12053  sub get_userresdata {
 #  Parameters:  #  Parameters:
 #     $name      - Course/user name.  #     $name      - Course/user name.
 #     $domain    - Name of the domain the user/course is registered on.  #     $domain    - Name of the domain the user/course is registered on.
 #     $type      - Type of thing $name is (must be 'course' or 'user')  #     $type      - Type of thing $name is (must be 'course' or 'user'
 #     @which     - Array of names of resources desired.  #     @which     - Array of names of resources desired.
 #  Returns:  #  Returns:
 #     The value of the first reasource in @which that is found in the  #     The value of the first reasource in @which that is found in the
Line 11372  sub resdata { Line 12074  sub resdata {
     foreach my $item (@which) {      foreach my $item (@which) {
  if (defined($result->{$item->[0]})) {   if (defined($result->{$item->[0]})) {
     return [$result->{$item->[0]},$item->[1]];      return [$result->{$item->[0]},$item->[1]];
         }   }
     }      }
     return undef;      return undef;
 }  }
   
 sub get_domain_lti {  sub get_domain_lti {
     my ($cdom,$context) = @_;      my ($cdom,$context) = @_;
     my ($name,%lti);      my ($name,$cachename,%lti);
     if ($context eq 'consumer') {      if ($context eq 'consumer') {
         $name = 'ltitools';          $name = 'ltitools';
     } elsif ($context eq 'provider') {      } elsif ($context eq 'provider') {
         $name = 'lti';          $name = 'lti';
       } elsif ($context eq 'linkprot') {
           $name = 'ltisec';
     } else {      } else {
         return %lti;          return %lti;
     }      }
     my ($result,$cached)=&is_cached_new($name,$cdom);      if ($context eq 'linkprot') {
           $cachename = $context;
       } else {
           $cachename = $name;
       }
       my ($result,$cached)=&is_cached_new($cachename,$cdom);
     if (defined($cached)) {      if (defined($cached)) {
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             %lti = %{$result};              %lti = %{$result};
Line 11395  sub get_domain_lti { Line 12104  sub get_domain_lti {
     } else {      } else {
         my %domconfig = &get_dom('configuration',[$name],$cdom);          my %domconfig = &get_dom('configuration',[$name],$cdom);
         if (ref($domconfig{$name}) eq 'HASH') {          if (ref($domconfig{$name}) eq 'HASH') {
             %lti = %{$domconfig{$name}};              if ($context eq 'linkprot') {
             my %encdomconfig = &get_dom('encconfig',[$name],$cdom);                  if (ref($domconfig{$name}{'linkprot'}) eq 'HASH') {
             if (ref($encdomconfig{$name}) eq 'HASH') {                      %lti = %{$domconfig{$name}{'linkprot'}};
                 foreach my $id (keys(%lti)) {  
                     if (ref($encdomconfig{$name}{$id}) eq 'HASH') {  
                         foreach my $item ('key','secret') {  
                             $lti{$id}{$item} = $encdomconfig{$name}{$id}{$item};  
                         }  
                     }  
                 }                  }
               } else {
                   %lti = %{$domconfig{$name}};
             }              }
         }          }
         my $cachetime = 24*60*60;          my $cachetime = 24*60*60;
         &do_cache_new($name,$cdom,\%lti,$cachetime);          &do_cache_new($cachename,$cdom,\%lti,$cachetime);
     }      }
     return %lti;      return %lti;
 }  }
   
 sub get_numsuppfiles {  sub get_course_lti {
     my ($cnum,$cdom,$ignorecache)=@_;      my ($cnum,$cdom,$context) = @_;
       my ($name,$cachename,%lti);
       if ($context eq 'consumer') {
           $name = 'ltitools';
           $cachename = 'courseltitools';
       } elsif ($context eq 'provider') {
           $name = 'lti';
           $cachename = 'courselti';
       } else {
           return %lti;
       }
       my $hashid=$cdom.'_'.$cnum;
       my ($result,$cached)=&is_cached_new($cachename,$hashid);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               %lti = %{$result};
           }
       } else {
           %lti = &dump($name,$cdom,$cnum,undef,undef,undef,1);
           my $cachetime = 24*60*60;
           &do_cache_new($cachename,$hashid,\%lti,$cachetime);
       }
       return %lti;
   }
   
   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 $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 $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 get_ltitools_id {
       my ($context,$cdom,$cnum,$title) = @_;
       my ($lockhash,$tries,$gotlock,$id,$error);
   
       # get lock on ltitools db
       $lockhash = {
                      lock => $env{'user.name'}.
                              ':'.$env{'user.domain'},
                   };
       $tries = 0;
       if ($context eq 'domain') {
           $gotlock = &newput_dom('ltitools',$lockhash,$cdom);
       } else {
           $gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
       }
       while (($gotlock ne 'ok') && ($tries<10)) {
           $tries ++;
           sleep (0.1);
           if ($context eq 'domain') {
               $gotlock = &newput_dom('ltitools',$lockhash,$cdom);
           } else {
               $gotlock = &newput('ltitools',$lockhash,$cdom,$cnum);
           }
       }
       if ($gotlock eq 'ok') {
           my %currids;
           if ($context eq 'domain') {
               %currids = &dump_dom('ltitools',$cdom);
           } else {
               %currids = &dump('ltitools',$cdom,$cnum);
           }
           if ($currids{'lock'}) {
               delete($currids{'lock'});
               if (keys(%currids)) {
                   my @curr = sort { $a <=> $b } keys(%currids);
                   if ($curr[-1] =~ /^\d+$/) {
                       $id = 1 + $curr[-1];
                   }
               } else {
                   $id = 1;
               }
               if ($id) {
                   if ($context eq 'domain') {
                       unless (&newput_dom('ltitools',{ $id => $title },$cdom) eq 'ok') {
                           $error = 'nostore';
                       }
                   } else {
                       unless (&newput('ltitools',{ $id => $title },$cdom,$cnum) eq 'ok') {
                           $error = 'nostore';
                       }
                   }
               } else {
                   $error = 'nonumber';
               }
           }
           my $dellockoutcome;
           if ($context eq 'domain') {
               $dellockoutcome = &del_dom('ltitools',['lock'],$cdom);
           } else {
               $dellockoutcome = &del('ltitools',['lock'],$cdom,$cnum);
           }
       } else {
           $error = 'nolock';
       }
       return ($id,$error);
   }
   
   sub count_supptools {
       my ($cnum,$cdom,$ignorecache,$reload)=@_;
     my $hashid=$cnum.':'.$cdom;      my $hashid=$cnum.':'.$cdom;
     my ($suppcount,$cached);      my ($numexttools,$cached);
     unless ($ignorecache) {      unless ($ignorecache) {
         ($suppcount,$cached) = &is_cached_new('suppcount',$hashid);          ($numexttools,$cached) = &is_cached_new('supptools',$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') {
             ($suppcount,my $errors) = (0,0);              my ($supplemental) = &Apache::loncommon::get_supplemental($cnum,$cdom,$reload);
             my $suppmap = 'supplemental.sequence';              if (ref($supplemental) eq 'HASH') {
             ($suppcount,$errors) =                  if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) {
                 &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);                      foreach my $key (keys(%{$supplemental->{'ids'}})) {
                           if ($key =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) {
                               $numexttools ++;
                           }
                       }
                   }
               }
         }          }
         &do_cache_new('suppcount',$hashid,$suppcount,600);          &do_cache_new('supptools',$hashid,$numexttools,600);
     }      }
     return $suppcount;      return $numexttools;
   }
   
   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 11493  sub EXT { Line 12388  sub EXT {
     if ( (defined($Apache::lonhomework::parsing_a_problem)      if ( (defined($Apache::lonhomework::parsing_a_problem)
   || defined($Apache::lonhomework::parsing_a_task))    || defined($Apache::lonhomework::parsing_a_task))
  &&   &&
  ($symbparm eq &symbread()) ) {   ($symbparm eq &symbread()) ) {
  # if we are in the middle of processing the resource the   # if we are in the middle of processing the resource the
  # get the value we are planning on committing   # get the value we are planning on committing
                 if (defined($Apache::lonhomework::results{$qualifierrest})) {                  if (defined($Apache::lonhomework::results{$qualifierrest})) {
Line 11691  sub EXT { Line 12586  sub EXT {
  }   }
 # ------------------------------------------ fourth, look in resource metadata  # ------------------------------------------ fourth, look in resource metadata
   
  $spacequalifierrest=~s/\./\_/;          my $what = $spacequalifierrest;
  my $filename;          $what=~s/\./\_/;
           my $filename;
  if (!$symbparm) { $symbparm=&symbread(); }   if (!$symbparm) { $symbparm=&symbread(); }
  if ($symbparm) {   if ($symbparm) {
     $filename=(&decode_symb($symbparm))[2];      $filename=(&decode_symb($symbparm))[2];
  } else {   } else {
     $filename=$env{'request.filename'};      $filename=$env{'request.filename'};
  }   }
  my $metadata=&metadata($filename,$spacequalifierrest);          my $toolsymb;
           if (($filename =~ /ext\.tool$/) && ($what ne '0_gradable')) {
               $toolsymb = $symbparm;
           }
    my $metadata=&metadata($filename,$what,$toolsymb);
  if (defined($metadata)) { return &get_reply([$metadata,'resource']); }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
  $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);   $metadata=&metadata($filename,'parameter_'.$what,$toolsymb);
  if (defined($metadata)) { return &get_reply([$metadata,'resource']); }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
   
 # ---------------------------------------------- fourth, look in rest of course  # ----------------------------------------------- fifth, look in rest of course
  if ($symbparm && defined($courseid) &&    if ($symbparm && defined($courseid) && 
     $courseid eq $env{'request.course.id'}) {      $courseid eq $env{'request.course.id'}) {
     my $coursereply=&resdata($env{'course.'.$courseid.'.num'},      my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
Line 11725  sub EXT { Line 12625  sub EXT {
     if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }      if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
  }   }
  if ($recurse) { return undef; }   if ($recurse) { return undef; }
  my $pack_def=&packages_tab_default($filename,$varname);   my $pack_def=&packages_tab_default($filename,$varname,$toolsymb);
  if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }   if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
Line 11750  sub EXT { Line 12650  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 11783  sub check_group_parms { Line 12687  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 11790  sub sort_course_groups { # Sort groups b Line 12718  sub sort_course_groups { # Sort groups b
 }  }
   
 sub packages_tab_default {  sub packages_tab_default {
     my ($uri,$varname)=@_;      my ($uri,$varname,$toolsymb)=@_;
     my (undef,$part,$name)=split(/\./,$varname);      my (undef,$part,$name)=split(/\./,$varname);
   
     my (@extension,@specifics,$do_default);      my (@extension,@specifics,$do_default);
     foreach my $package (split(/,/,&metadata($uri,'packages'))) {      foreach my $package (split(/,/,&metadata($uri,'packages',$toolsymb))) {
  my ($pack_type,$pack_part)=split(/_/,$package,2);   my ($pack_type,$pack_part)=split(/_/,$package,2);
  if ($pack_type eq 'default') {   if ($pack_type eq 'default') {
     $do_default=1;      $do_default=1;
Line 11863  my %metaentry; Line 12791  my %metaentry;
 my %importedpartids;  my %importedpartids;
 my %importedrespids;  my %importedrespids;
 sub metadata {  sub metadata {
     my ($uri,$what,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
     # 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 '') || 
Line 11887  sub metadata { Line 12815  sub metadata {
  my ($result,$cached)=&is_cached_new('meta',$uri);   my ($result,$cached)=&is_cached_new('meta',$uri);
  if (defined($cached)) { return $result->{':'.$what}; }   if (defined($cached)) { return $result->{':'.$what}; }
     }      }
   
   #
   # If the uri is for an external tool the file from
   # which metadata should be retrieved depends on whether
   # the tool had been configured to be gradable (set in the Course
   # Editor or Resource Editor).
   #
   # If a valid symb has been included as the third arg in the call
   # to &metadata() that can be used to retrieve the value of
   # parameter_0_gradable set for the resource, and included in the
   # uploaded map containing the tool. The value is retrieved via
   # &EXT(), if a valid symb is available.  Otherwise the value of
   # gradable in the exttool_$marker.db file for the tool instance
   # is retrieved via &get().
   #
   # When lonuserstate::traceroute() calls lonnet::EXT() for
   # hiddenresource and encrypturl (during course initialization)
   # the map-level parameter for resource.0.gradable included in the
   # uploaded map containing the tool will not yet have been stored
   # in the user_course_parms.db file for the user's session, so in
   # this case fall back to retrieving gradable status from the
   # exttool_$marker.db file.
   #
   # In order to avoid an infinite loop, &metadata() will return
   # before a call to &EXT(), if the uri is for an external tool
   # and the $what for which metadata is being requested is
   # parameter_0_gradable or 0_gradable.
   #
   
       if ($uri =~ /ext\.tool$/) {
           if (($what eq 'parameter_0_gradable') || ($what eq '0_gradable')) {
               return;
           } else {
               my ($checked,$use_passback);
               if ($toolsymb ne '') {
                   (undef,undef,my $tooluri) = &decode_symb($toolsymb);
                   if (($tooluri eq $uri) && (&EXT('resource.0.gradable',$toolsymb))) {
                       $checked = 1;
                       if (&EXT('resource.0.gradable',$toolsymb) =~ /^yes$/i) {
                           $use_passback = 1;
                       }
                   }
               }
               unless ($checked) {
                   my ($ignore,$cdom,$cnum,$marker) = split(m{/},$uri);
                   $marker=~s/\D//g;
                   if ($marker) {
                       my %toolsettings=&get('exttool_'.$marker,['gradable'],$cdom,$cnum);
                       $use_passback = $toolsettings{'gradable'};
                   }
               }
               if ($use_passback) {
                   $filename = '/home/httpd/html/res/lib/templates/LTIpassback.tool';
               } else {
                   $filename = '/home/httpd/html/res/lib/templates/LTIstandard.tool';
               }
           }
       }
   
     {      {
 # Imported parts would go here  # Imported parts would go here
         my @origfiletagids=();          my @origfiletagids=();
Line 12060  sub metadata { Line 13047  sub metadata {
   
  if ($depthcount<20) {   if ($depthcount<20) {
     my $metadata =       my $metadata = 
  &metadata($uri,'keys', $location,$unikey,   &metadata($uri,'keys',$toolsymb,$location,$unikey,
   $depthcount+1);    $depthcount+1);
     foreach my $meta (split(',',$metadata)) {      foreach my $meta (split(',',$metadata)) {
  $metaentry{':'.$meta}=$metaentry{':'.$meta};   $metaentry{':'.$meta}=$metaentry{':'.$meta};
Line 12135  sub metadata { Line 13122  sub metadata {
  $dir=~s|[^/]*$||;   $dir=~s|[^/]*$||;
  $location=&filelocation($dir,$location);   $location=&filelocation($dir,$location);
  my $rights_metadata =   my $rights_metadata =
     &metadata($uri,'keys',$location,'_rights',      &metadata($uri,'keys',$toolsymb,$location,'_rights',
       $depthcount+1);        $depthcount+1);
  foreach my $rights (split(',',$rights_metadata)) {   foreach my $rights (split(',',$rights_metadata)) {
     #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};      #$metaentry{':'.$rights}=$metacache{$uri}->{':'.$rights};
Line 12404  sub get_coursechange { Line 13391  sub get_coursechange {
 }  }
   
 sub devalidate_coursechange_cache {  sub devalidate_coursechange_cache {
     my ($cnum,$cdom)=@_;      my ($cdom,$cnum)=@_;
     my $hashid=$cnum.':'.$cdom;      my $hashid=$cdom.'_'.$cnum;
     &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 12595  sub symbread { Line 13639  sub symbread {
     my %bighash;      my %bighash;
     my $syval='';      my $syval='';
     if (($env{'request.course.fn'}) && ($thisfn)) {      if (($env{'request.course.fn'}) && ($thisfn)) {
         my $targetfn = $thisfn;  
         if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {  
             $targetfn = 'adm/wrapper/'.$thisfn;  
         }  
  if ($targetfn =~ m|^adm/wrapper/(ext/.*)|) {  
     $targetfn=$1;  
  }  
         unless ($ignoresymbdb) {          unless ($ignoresymbdb) {
             if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',              if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                           &GDBM_READER(),0640)) {                            &GDBM_READER(),0640)) {
         $syval=$hash{$targetfn};          $syval=$hash{$thisfn};
                 untie(%hash);                  untie(%hash);
             }              }
             if ($syval && $checkforblock) {              if ($syval && $checkforblock) {
Line 13414  sub machine_ids { Line 14451  sub machine_ids {
   
 sub additional_machine_domains {  sub additional_machine_domains {
     my @domains;      my @domains;
     open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab");      if (-e "$perlvar{'lonTabDir'}/expected_domains.tab") {
     while( my $line = <$fh>) {          if (open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab")) {
         $line =~ s/\s//g;              while( my $line = <$fh>) {
         push(@domains,$line);                  chomp($line);
                   $line =~ s/\s//g;
                   push(@domains,$line);
               }
               close($fh);
           }
     }      }
     return @domains;      return @domains;
 }  }
Line 13436  sub default_login_domain { Line 14478  sub default_login_domain {
 }  }
   
 sub shared_institution {  sub shared_institution {
     my ($dom) = @_;      my ($dom,$lonhost) = @_;
       if ($lonhost eq '') {
           $lonhost = $perlvar{'lonHostID'};
       }
     my $same_intdom;      my $same_intdom;
     my $hostintdom = &internet_dom($perlvar{'lonHostID'});      my $hostintdom = &internet_dom($lonhost);
     if ($hostintdom ne '') {      if ($hostintdom ne '') {
         my %iphost = &get_iphost();          my %iphost = &get_iphost();
         my $primary_id = &domain($dom,'primary');          my $primary_id = &domain($dom,'primary');
Line 13495  sub uses_sts { Line 14540  sub uses_sts {
     return;      return;
 }  }
   
   sub waf_allssl {
       my ($host_name) = @_;
       my $alias = &get_proxy_alias();
       if ($host_name eq '') {
           $host_name = $ENV{'SERVER_NAME'};
       }
       if (($host_name ne '') && ($alias eq $host_name)) {
           my $serverhomedom = &host_domain($perlvar{'lonHostID'});
           my %defdomdefaults = &get_domain_defaults($serverhomedom);
           if ($defdomdefaults{'waf_sslopt'}) {
               return $defdomdefaults{'waf_sslopt'};
           }
       }
       return;
   }
   
 sub get_requestor_ip {  sub get_requestor_ip {
     my ($r,$nolookup,$noproxy) = @_;      my ($r,$nolookup,$noproxy) = @_;
     my $from_ip;      my $from_ip;
     if (ref($r)) {      if (ref($r)) {
         $from_ip = $r->get_remote_host($nolookup);          if ($r->can('useragent_ip')) {
               if ($noproxy && $r->can('client_ip')) {
                   $from_ip = $r->client_ip();
               } else {
                   $from_ip = $r->useragent_ip();
               }
           } elsif ($r->connection->can('remote_ip')) {
               $from_ip = $r->connection->remote_ip();
           } else {
               $from_ip = $r->get_remote_host($nolookup);
           }
     } else {      } else {
         $from_ip = $ENV{'REMOTE_ADDR'};          $from_ip = $ENV{'REMOTE_ADDR'};
     }      }
       return $from_ip if ($noproxy);
      # Who controls proxy settings for server
       my $dom_in_use = $Apache::lonnet::perlvar{'lonDefDomain'};
       my $proxyinfo = &get_proxy_settings($dom_in_use);
       if ((ref($proxyinfo) eq 'HASH') && ($from_ip)) {
           if ($proxyinfo->{'vpnint'}) {
               if (&ip_match($from_ip,$proxyinfo->{'vpnint'})) {
                   return $from_ip;
               }
           }
           if ($proxyinfo->{'trusted'}) {
               if (&ip_match($from_ip,$proxyinfo->{'trusted'})) {
                   my $ipheader = $proxyinfo->{'ipheader'};
                   my ($ip,$xfor);
                   if (ref($r)) {
                       if ($ipheader) {
                           $ip = $r->headers_in->{$ipheader};
                       }
                       $xfor = $r->headers_in->{'X-Forwarded-For'};
                   } else {
                       if ($ipheader) {
                           $ip = $ENV{'HTTP_'.uc($ipheader)};
                       }
                       $xfor = $ENV{'HTTP_X_FORWARDED_FOR'};
                   }
                   if (($ip eq '') && ($xfor ne '')) {
                       foreach my $poss_ip (reverse(split(/\s*,\s*/,$xfor))) {
                           unless (&ip_match($poss_ip,$proxyinfo->{'trusted'})) {
                               $ip = $poss_ip;
                               last;
                           }
                       }
                   }
                   if ($ip ne '') {
                       return $ip;
                   }
               }
           }
       }
     return $from_ip;      return $from_ip;
 }  }
   
   sub get_proxy_settings {
       my ($dom_in_use) = @_;
       my %domdefaults = &Apache::lonnet::get_domain_defaults($dom_in_use);
       my $proxyinfo = {
                          ipheader => $domdefaults{'waf_ipheader'},
                          trusted  => $domdefaults{'waf_trusted'},
                          vpnint   => $domdefaults{'waf_vpnint'},
                          vpnext   => $domdefaults{'waf_vpnext'},
                          sslopt   => $domdefaults{'waf_sslopt'},
                       };
       return $proxyinfo;
   }
   
   sub ip_match {
       my ($ip,$pattern_str) = @_;
       $ip=Net::CIDR::cidrvalidate($ip);
       if ($ip) {
           return Net::CIDR::cidrlookup($ip,split(/\s*,\s*/,$pattern_str));
       }
       return;
   }
   
   sub get_proxy_alias {
       my ($lonid) = @_;
       if ($lonid eq '') {
           $lonid = $perlvar{'lonHostID'};
       }
       if (!defined(&hostname($lonid))) {
           return;
       }
       if ($lonid ne '') {
           my ($alias,$cached) = &is_cached_new('proxyalias',$lonid);
           if ($cached) {
               return $alias;
           }
           my $dom = &Apache::lonnet::host_domain($lonid);
           if ($dom ne '') {
               my $cachetime = 60*60*24;
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
               if (ref($domconfig{'wafproxy'}) eq 'HASH') {
                   if (ref($domconfig{'wafproxy'}{'alias'}) eq 'HASH') {
                       $alias = $domconfig{'wafproxy'}{'alias'}{$lonid};
                   }
               }
               return &do_cache_new('proxyalias',$lonid,$alias,$cachetime);
           }
       }
       return;
   }
   
   sub use_proxy_alias {
       my ($r,$lonid) = @_;
       my $alias = &get_proxy_alias($lonid);
       if ($alias) {
           my $dom = &host_domain($lonid);
           if ($dom ne '') {
               my $proxyinfo = &get_proxy_settings($dom);
               my ($vpnint,$remote_ip);
               if (ref($proxyinfo) eq 'HASH') {
                   $vpnint = $proxyinfo->{'vpnint'};
                   if ($vpnint) {
                       $remote_ip = &get_requestor_ip($r,1,1);
                   }
               }
               unless ($vpnint && &ip_match($remote_ip,$vpnint)) {
                   return $alias;
               }
           }
       }
       return;
   }
   
   sub alias_sso {
       my ($lonid) = @_;
       if ($lonid eq '') {
           $lonid = $perlvar{'lonHostID'};
       }
       if (!defined(&hostname($lonid))) {
           return;
       }
       if ($lonid ne '') {
           my ($use_alias,$cached) = &is_cached_new('proxysaml',$lonid);
           if ($cached) {
               return $use_alias;
           }
           my $dom = &Apache::lonnet::host_domain($lonid);
           if ($dom ne '') {
               my $cachetime = 60*60*24;
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['wafproxy'],$dom);
               if (ref($domconfig{'wafproxy'}) eq 'HASH') {
                   if (ref($domconfig{'wafproxy'}{'saml'}) eq 'HASH') {
                       $use_alias = $domconfig{'wafproxy'}{'saml'}{$lonid};
                   }
               }
               return &do_cache_new('proxysaml',$lonid,$use_alias,$cachetime);
           }
       }
       return;
   }
   
   sub get_saml_landing {
       my ($lonid) = @_;
       if ($lonid eq '') {
           my $defdom = &default_login_domain();
           my @hosts = &current_machine_ids();
           if (@hosts > 1) {
               foreach my $hostid (@hosts) {
                   if (&host_domain($hostid) eq $defdom) {
                       $lonid = $hostid;
                       last;
                   }
               }
           } else {
               $lonid = $perlvar{'lonHostID'};
           }
           if ($lonid) {
               unless (&Apache::lonnet::host_domain($lonid) eq $defdom) {
                   return;
               }
           } else {
               return;
           }
       } elsif (!defined(&hostname($lonid))) {
           return;
       }
       my ($landing,$cached) = &is_cached_new('samllanding',$lonid);
       if ($cached) {
           return $landing;
       }
       my $dom = &Apache::lonnet::host_domain($lonid);
       if ($dom ne '') {
           my $cachetime = 60*60*24;
           my %domconfig =
               &Apache::lonnet::get_dom('configuration',['login'],$dom);
           if (ref($domconfig{'login'}) eq 'HASH') {
               if (ref($domconfig{'login'}{'saml'}) eq 'HASH') {
                   if (ref($domconfig{'login'}{'saml'}{$lonid}) eq 'HASH') {
                       $landing = 1;
                   }
               }
           }
           return &do_cache_new('samllanding',$lonid,$landing,$cachetime);
       }
       return;
   }
   
 # ------------------------------------------------------------- Declutters URLs  # ------------------------------------------------------------- Declutters URLs
   
 sub declutter {  sub declutter {
Line 13645  sub get_dns { Line 14903  sub get_dns {
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = sort { $b cmp $a } keys(%alldns);   my ($dns) = sort { $b cmp $a } keys(%alldns);
  my $ua=new LWP::UserAgent;          my @content;
         $ua->timeout(30);          if ($dns eq Sys::Hostname::FQDN::fqdn()) {
  my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");              my $command = (split('/',$url))[3];
  my $response=$ua->request($request);              my ($dir,$file) = &parse_getdns_url($command,$url);
         delete($alldns{$dns});              delete($alldns{$dns});
  next if ($response->is_error());              next if (($dir eq '') || ($file eq ''));
  my @content = split("\n",$response->content);              if (open(my $config,'<',"$dir/$file")) {
                   @content = <$config>;
                   close($config);
               }
           } else {
       my $ua=new LWP::UserAgent;
               $ua->timeout(30);
       my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
       my $response=$ua->request($request);
               delete($alldns{$dns});
       next if ($response->is_error());
       @content = split("\n",$response->content);
           }
         unless ($nocache) {          unless ($nocache) {
     &do_cache_new('dns',$url,\@content,30*24*60*60);      &do_cache_new('dns',$url,\@content,30*24*60*60);
         }          }
Line 13723  sub fetch_dns_checksums { Line 14993  sub fetch_dns_checksums {
     return \%checksums;      return \%checksums;
 }  }
   
   sub parse_getdns_url {
       my ($command,$url) = @_;
       my $dir = $perlvar{'lonTabDir'};
       my $file;
       if ($command eq 'hosts') {
           $file = 'dns_hosts.tab';
       } elsif ($command eq 'domain') {
           $file = 'dns_domain.tab';
       } elsif ($command eq 'checksums') {
           my $version = (split('/',$url))[4];
           $file = "dns_checksums/$version.tab",
       }
       return ($dir,$file);
   }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Line 14602  prevents recursive calls to &allowed. Line 15887  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 14894  data base, returning a hash that is keye Line 16180  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
Line 15065  condval($condidx) : value of condition i Line 16347  condval($condidx) : value of condition i
   
 =item *  =item *
   
 metadata($uri,$what,$liburi,$prefix,$depthcount) : request a  metadata($uri,$what,$toolsymb,$liburi,$prefix,$depthcount) : request a
 resource's metadata, $what should be either a specific key, or either  resource's metadata, $what should be either a specific key, or either
 'keys' (to get a list of possible keys) or 'packages' to get a list of  'keys' (to get a list of possible keys) or 'packages' to get a list of
 packages that this resource currently uses, the last 3 arguments are only used internally for recursive metadata.  packages that this resource currently uses, the last 3 arguments are
   only used internally for recursive metadata.
   
   the toolsymb is only used where the uri is for an external tool (for which
   the uri as well as the symb are guaranteed to be unique).
   
 this function automatically caches all requests  this function automatically caches all requests
   
Removed from v.1.1172.2.118.2.14  
changed lines
  Added in v.1.1172.2.146.2.20

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