Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1230 and 1.1262

version 1.1230, 2013/07/09 00:17:27 version 1.1262, 2014/06/13 03:33:55
Line 78  use Image::Magick; Line 78  use Image::Magick;
   
 use Encode;  use Encode;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
             %managerstab);              %managerstab);
   
Line 356  sub get_remote_globals { Line 356  sub get_remote_globals {
 }  }
   
 sub remote_devalidate_cache {  sub remote_devalidate_cache {
     my ($lonhost,$name,$id) = @_;      my ($lonhost,$cachekeys) = @_;
     my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost);      my $items;
       return unless (ref($cachekeys) eq 'ARRAY');
       my $cachestr = join('&',@{$cachekeys});
       my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost);
     return $response;      return $response;
 }  }
   
Line 603  sub transfer_profile_to_env { Line 606  sub transfer_profile_to_env {
   
 # ---------------------------------------------------- Check for valid session   # ---------------------------------------------------- Check for valid session 
 sub check_for_valid_session {  sub check_for_valid_session {
     my ($r,$name) = @_;      my ($r,$name,$userhashref) = @_;
     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     if ($name eq '') {      if ($name eq '') {
         $name = 'lonID';          $name = 'lonID';
Line 634  sub check_for_valid_session { Line 637  sub check_for_valid_session {
  || !defined($disk_env{'user.domain'})) {   || !defined($disk_env{'user.domain'})) {
  return undef;   return undef;
     }      }
     if (($r->user() eq '') && ($apache >= 2.4)) {  
         if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) {      if (ref($userhashref) eq 'HASH') {
             $r->user($disk_env{'user.name'});          $userhashref->{'name'} = $disk_env{'user.name'};
         } else {          $userhashref->{'domain'} = $disk_env{'user.domain'};
             $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});  
         }  
     }      }
   
     return $handle;      return $handle;
 }  }
   
Line 674  sub appenv { Line 676  sub appenv {
     if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {      if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
                 $refused = 1;                  $refused = 1;
                 if (ref($roles) eq 'ARRAY') {                  if (ref($roles) eq 'ARRAY') {
                     my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);                      my ($type,$role) = ($key =~ m{^user\.(role|priv)\.(.+?)\./});
                     if (grep(/^\Q$role\E$/,@{$roles})) {                      if (grep(/^\Q$role\E$/,@{$roles})) {
                         $refused = 0;                          $refused = 0;
                     }                      }
Line 888  sub spareserver { Line 890  sub spareserver {
 }  }
   
 sub compare_server_load {  sub compare_server_load {
     my ($try_server, $spare_server, $lowest_load) = @_;      my ($try_server, $spare_server, $lowest_load, $required) = @_;
   
       if ($required) {
           my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/);
           my $remoterev = &get_server_loncaparev(undef,$try_server);
           my ($major,$minor) = ($remoterev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
           if (($major eq '' && $minor eq '') ||
               (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) {
               return ($spare_server,$lowest_load);
           }
       }
   
     my $loadans     = &reply('load',    $try_server);      my $loadans     = &reply('load',    $try_server);
     my $userloadans = &reply('userload',$try_server);      my $userloadans = &reply('userload',$try_server);
Line 949  sub has_user_session { Line 961  sub has_user_session {
 # --------- determine least loaded server in a user's domain which allows login  # --------- determine least loaded server in a user's domain which allows login
   
 sub choose_server {  sub choose_server {
     my ($udom,$checkloginvia) = @_;      my ($udom,$checkloginvia,$required,$skiploadbal) = @_;
     my %domconfhash = &Apache::loncommon::get_domainconf($udom);      my %domconfhash = &Apache::loncommon::get_domainconf($udom);
     my %servers = &get_servers($udom);      my %servers = &get_servers($udom);
     my $lowest_load = 30000;      my $lowest_load = 30000;
     my ($login_host,$hostname,$portal_path,$isredirect);      my ($login_host,$hostname,$portal_path,$isredirect,$balancers);
       if ($skiploadbal) {
           ($balancers,my $cached)=&is_cached_new('loadbalancing',$udom);
           unless (defined($cached)) {
               my $cachetime = 60*60*24;
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
               if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
                   $balancers = &do_cache_new('loadbalancing',$udom,$domconfig{'loadbalancing'},
                                              $cachetime);
               }
           }
       }
     foreach my $lonhost (keys(%servers)) {      foreach my $lonhost (keys(%servers)) {
           if ($skiploadbal) {
               if (ref($balancers) eq 'HASH') {
                   next if (exists($balancers->{$lonhost}));
               }
           }   
         my $loginvia;          my $loginvia;
         if ($checkloginvia) {          if ($checkloginvia) {
             $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};              $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
             if ($loginvia) {              if ($loginvia) {
                 my ($server,$path) = split(/:/,$loginvia);                  my ($server,$path) = split(/:/,$loginvia);
                 ($login_host, $lowest_load) =                  ($login_host, $lowest_load) =
                     &compare_server_load($server, $login_host, $lowest_load);                      &compare_server_load($server, $login_host, $lowest_load, $required);
                 if ($login_host eq $server) {                  if ($login_host eq $server) {
                     $portal_path = $path;                      $portal_path = $path;
                     $isredirect = 1;                      $isredirect = 1;
                 }                  }
             } else {              } else {
                 ($login_host, $lowest_load) =                  ($login_host, $lowest_load) =
                     &compare_server_load($lonhost, $login_host, $lowest_load);                      &compare_server_load($lonhost, $login_host, $lowest_load, $required);
                 if ($login_host eq $lonhost) {                  if ($login_host eq $lonhost) {
                     $portal_path = '';                      $portal_path = '';
                     $isredirect = '';                       $isredirect = ''; 
Line 976  sub choose_server { Line 1005  sub choose_server {
             }              }
         } else {          } else {
             ($login_host, $lowest_load) =              ($login_host, $lowest_load) =
                 &compare_server_load($lonhost, $login_host, $lowest_load);                  &compare_server_load($lonhost, $login_host, $lowest_load, $required);
         }          }
     }      }
     if ($login_host ne '') {      if ($login_host ne '') {
Line 1323  sub check_loadbalancing { Line 1352  sub check_loadbalancing {
             }              }
         }          }
     } elsif (($homeintdom) && ($udom ne $serverhomedom)) {      } elsif (($homeintdom) && ($udom ne $serverhomedom)) {
         my ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);          ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
         unless (defined($cached)) {          unless (defined($cached)) {
             my %domconfig =              my %domconfig =
                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);                  &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
Line 1578  sub idput { Line 1607  sub idput {
     }      }
 }  }
   
   # ---------------------------------------- Delete unwanted IDs from ids.db file 
   
   sub iddel {
       my ($udom,$idshashref,$uhome)=@_;
       my %result=();
       unless (ref($idshashref) eq 'HASH') {
           return %result;
       }
       my %servers=();
       while (my ($id,$uname) = each(%{$idshashref})) {
           my $uhom;
           if ($uhome) {
               $uhom = $uhome;
           } else {
               $uhom=&homeserver($uname,$udom);
           }
           if ($uhom ne 'no_host') {
               if ($servers{$uhom}) {
                   $servers{$uhom}.='&'.&escape($id);
               } else {
                   $servers{$uhom}=&escape($id);
               }
           }
       }
       foreach my $server (keys(%servers)) {
           $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
       }
       return %result;
   }
   
 # ------------------------------dump from db file owned by domainconfig user  # ------------------------------dump from db file owned by domainconfig user
 sub dump_dom {  sub dump_dom {
     my ($namespace, $udom, $regexp) = @_;      my ($namespace, $udom, $regexp) = @_;
Line 1703  sub retrieve_inst_usertypes { Line 1762  sub retrieve_inst_usertypes {
     my %domdefs = &Apache::lonnet::get_domain_defaults($udom);      my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
     if ((ref($domdefs{'inststatustypes'}) eq 'HASH') &&       if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && 
         (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {          (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
         %returnhash = %{$domdefs{'inststatustypes'}};          return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});
         @order = @{$domdefs{'inststatusorder'}};  
     } else {      } else {
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
             my $uhome=&domain($udom,'primary');              my $uhome=&domain($udom,'primary');
             my $rep=&reply("inst_usertypes:$udom",$uhome);              my $rep=&reply("inst_usertypes:$udom",$uhome);
             if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {              if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
                 &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");                  &logthis("retrieve_inst_usertypes failed - $rep returned from $uhome in domain: $udom");
                 return (\%returnhash,\@order);                  return (\%returnhash,\@order);
             }              }
             my ($hashitems,$orderitems) = split(/:/,$rep);               my ($hashitems,$orderitems) = split(/:/,$rep); 
Line 1726  sub retrieve_inst_usertypes { Line 1784  sub retrieve_inst_usertypes {
                 push(@order,&unescape($item));                  push(@order,&unescape($item));
             }              }
         } else {          } else {
             &logthis("get_dom failed - no primary domain server for $udom");              &logthis("retrieve_inst_usertypes failed - no primary domain server for $udom");
         }          }
           return (\%returnhash,\@order);
     }      }
     return (\%returnhash,\@order);  
 }  }
   
 sub is_domainimage {  sub is_domainimage {
Line 1954  sub inst_userrules { Line 2012  sub inst_userrules {
 # ------------- Get Authentication, Language and User Tools Defaults for Domain  # ------------- Get Authentication, Language and User Tools Defaults for Domain
   
 sub get_domain_defaults {  sub get_domain_defaults {
     my ($domain) = @_;      my ($domain,$ignore_cache) = @_;
       return if (($domain eq '') || ($domain eq 'public'));
     my $cachetime = 60*60*24;      my $cachetime = 60*60*24;
     my ($result,$cached)=&is_cached_new('domdefaults',$domain);      unless ($ignore_cache) {
     if (defined($cached)) {          my ($result,$cached)=&is_cached_new('domdefaults',$domain);
         if (ref($result) eq 'HASH') {          if (defined($cached)) {
             return %{$result};              if (ref($result) eq 'HASH') {
                   return %{$result};
               }
         }          }
     }      }
     my %domdefaults;      my %domdefaults;
Line 1967  sub get_domain_defaults { Line 2028  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'],$domain);                                    'requestauthor','selfenrollment',
                                     'coursecategories'],$domain);
       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'}; 
         $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};          $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
Line 1997  sub get_domain_defaults { Line 2060  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'requestcourses'}) eq 'HASH') {      if (ref($domconfig{'requestcourses'}) eq 'HASH') {
         foreach my $item ('official','unofficial','community') {          foreach my $item ('official','unofficial','community','textbook') {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
Line 2005  sub get_domain_defaults { Line 2068  sub get_domain_defaults {
         $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};          $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
     }      }
     if (ref($domconfig{'inststatus'}) eq 'HASH') {      if (ref($domconfig{'inststatus'}) eq 'HASH') {
         foreach my $item ('inststatustypes','inststatusorder') {          foreach my $item ('inststatustypes','inststatusorder','inststatusguest') {
             $domdefaults{$item} = $domconfig{'inststatus'}{$item};              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
         }          }
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};          $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
         if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {          foreach my $type (@coursetypes) {
             $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};              if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
             $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};                  unless ($type eq 'community') {
         }                      $domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type};
         if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {                  }
             $domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'};              }
             $domdefaults{'unofficialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'unofficial'};              if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
             $domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'};                             $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
               }
         }          }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 2029  sub get_domain_defaults { Line 2093  sub get_domain_defaults {
             $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};              $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
         }          }
     }      }
       if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
           if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
               my @settings = ('types','registered','enroll_dates','access_dates','section',
                               'approval','limit');
               foreach my $type (@coursetypes) {
                   if (ref($domconfig{'selfenrollment'}{'admin'}{$type}) eq 'HASH') {
                       my @mgrdc = ();
                       foreach my $item (@settings) {
                           if ($domconfig{'selfenrollment'}{'admin'}{$type}{$item} eq '0') {
                               push(@mgrdc,$item);
                           }
                       }
                       if (@mgrdc) {
                           $domdefaults{$type.'selfenrolladmdc'} = join(',',@mgrdc);
                       }
                   }
               }
           }
           if (ref($domconfig{'selfenrollment'}{'default'}) eq 'HASH') {
               foreach my $type (@coursetypes) {
                   if (ref($domconfig{'selfenrollment'}{'default'}{$type}) eq 'HASH') {
                       foreach my $item (keys(%{$domconfig{'selfenrollment'}{'default'}{$type}})) {
                           $domdefaults{$type.'selfenroll'.$item} = $domconfig{'selfenrollment'}{'default'}{$type}{$item};
                       }
                   }
               }
           }
       }
       if (ref($domconfig{'coursecategories'}) eq 'HASH') {
           $domdefaults{'catauth'} = 'std';
           $domdefaults{'catunauth'} = 'std';
           if ($domconfig{'coursecategories'}{'auth'}) { 
               $domdefaults{'catauth'} = $domconfig{'coursecategories'}{'auth'};
           }
           if ($domconfig{'coursecategories'}{'unauth'}) {
               $domdefaults{'catunauth'} = $domconfig{'coursecategories'}{'unauth'};
           }
       }
     &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
     return %domdefaults;      return %domdefaults;
 }  }
Line 2822  sub can_edit_resource { Line 2924  sub can_edit_resource {
                     $cfile =~ s{^http://}{};                      $cfile =~ s{^http://}{};
                     $cfile = '/adm/wrapper/ext/'.$cfile;                      $cfile = '/adm/wrapper/ext/'.$cfile;
                 }                  }
               } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                   if ($env{'form.forceedit'}) {
                       $forceview = 1;
                   } else {
                       $forceedit = 1;
                   }
                   $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");
             }              }
         }          }
         if ($uploaded || $incourse) {          if ($uploaded || $incourse) {
Line 3459  sub extract_embedded_items { Line 3568  sub extract_embedded_items {
                     }                      }
                 }                  }
     }      }
               if (lc($tagname) eq 'iframe') {
                   my $src = $attr->{'src'} ;
                   if (($src ne '') && ($src !~ m{^(/|https?://)})) {
                       &add_filetype($allfiles,$src,'src');
                   } elsif ($src =~ m{^/}) {
                       if ($env{'request.course.id'}) {
                           my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
                           my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                           my $url = &hreflocation('',$fullpath);
                           if ($url =~ m{^/uploaded/$cdom/$cnum/docs/(\w+/\d+)/}) {
                               my $relpath = $1;
                               if ($src =~ m{^/uploaded/$cdom/$cnum/docs/\Q$relpath\E/(.+)$}) {
                                   &add_filetype($allfiles,$1,'src');
                               }
                           }
                       }
                   }
               }
             if ($t->[4] =~ m{/>$}) {              if ($t->[4] =~ m{/>$}) {
                 pop(@state);                    pop(@state);
             }              }
  } elsif ($t->[0] eq 'E') {   } elsif ($t->[0] eq 'E') {
     my ($tagname) = ($t->[1]);      my ($tagname) = ($t->[1]);
Line 4117  sub courseiddump { Line 4244  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
         $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
         $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
         $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner)=@_;          $cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,
           $hasuniquecode)=@_;
     my $as_hash = 1;      my $as_hash = 1;
     my %returnhash;      my %returnhash;
     if (!$domfilter) { $domfilter=''; }      if (!$domfilter) { $domfilter=''; }
Line 4140  sub courseiddump { Line 4268  sub courseiddump {
                                 &escape($catfilter), $showhidden, $caller,                                   &escape($catfilter), $showhidden, $caller, 
                                 &escape($cloner), &escape($cc_clone), $cloneonly,                                   &escape($cloner), &escape($cc_clone), $cloneonly, 
                                 &escape($createdbefore), &escape($createdafter),                                   &escape($createdbefore), &escape($createdafter), 
                                 &escape($creationcontext), $domcloner)));                                  &escape($creationcontext), $domcloner, $hasuniquecode)));
                 } else {                  } else {
                     $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.                      $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
                              $sincefilter.':'.&escape($descfilter).':'.                               $sincefilter.':'.&escape($descfilter).':'.
Line 4151  sub courseiddump { Line 4279  sub courseiddump {
                              $showhidden.':'.$caller.':'.&escape($cloner).':'.                               $showhidden.':'.$caller.':'.&escape($cloner).':'.
                              &escape($cc_clone).':'.$cloneonly.':'.                               &escape($cc_clone).':'.$cloneonly.':'.
                              &escape($createdbefore).':'.&escape($createdafter).':'.                               &escape($createdbefore).':'.&escape($createdafter).':'.
                              &escape($creationcontext).':'.$domcloner,                               &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode,
                              $tryserver);                               $tryserver);
                 }                  }
                                             
Line 5151  sub set_arearole { Line 5279  sub set_arearole {
 sub custom_roleprivs {  sub custom_roleprivs {
     my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;      my ($allroles,$trole,$tdomain,$trest,$spec,$area) = @_;
     my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);      my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
     my $homsvr=homeserver($rauthor,$rdomain);      my $homsvr = &homeserver($rauthor,$rdomain);
     if (&hostname($homsvr) ne '') {      if (&hostname($homsvr) ne '') {
         my ($rdummy,$roledef)=          my ($rdummy,$roledef)=
             &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);              &get('roles',["rolesdef_$rrole"],$rdomain,$rauthor);
Line 5272  sub set_userprivs { Line 5400  sub set_userprivs {
   
 sub role_status {  sub role_status {
     my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;      my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
     my @pwhere = ();  
     if (exists($env{$rolekey}) && $env{$rolekey} ne '') {      if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
         (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);          my ($one,$two) = split(m{\./},$rolekey,2);
           (undef,undef,$$role) = split(/\./,$one,3);
         unless (!defined($$role) || $$role eq '') {          unless (!defined($$role) || $$role eq '') {
             $$where=join('.',@pwhere);              $$where = '/'.$two;
             $$trolecode=$$role.'.'.$$where;              $$trolecode=$$role.'.'.$$where;
             ($$tstart,$$tend)=split(/\./,$env{$rolekey});              ($$tstart,$$tend)=split(/\./,$env{$rolekey});
             $$tstatus='is';              $$tstatus='is';
Line 5482  sub unserialize { Line 5610  sub unserialize {
     return {} if $rep =~ /^error/;      return {} if $rep =~ /^error/;
   
     my %returnhash=();      my %returnhash=();
  foreach my $item (split /\&/, $rep) {   foreach my $item (split(/\&/,$rep)) {
     my ($key, $value) = split(/=/, $item, 2);      my ($key, $value) = split(/=/, $item, 2);
     $key = unescape($key) unless $escapedkeys;      $key = unescape($key) unless $escapedkeys;
     next if $key =~ /^error: 2 /;      next if $key =~ /^error: 2 /;
     $returnhash{$key} = Apache::lonnet::thaw_unescape($value);      $returnhash{$key} = &thaw_unescape($value);
  }   }
     #return %returnhash;      #return %returnhash;
     return \%returnhash;      return \%returnhash;
Line 6147  sub usertools_access { Line 6275  sub usertools_access {
                       official   => 1,                        official   => 1,
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                         textbook   => 1,
                  );                   );
     } elsif ($context eq 'requestauthor') {      } elsif ($context eq 'requestauthor') {
         %tools = (          %tools = (
Line 6162  sub usertools_access { Line 6291  sub usertools_access {
     }      }
     return if (!defined($tools{$tool}));      return if (!defined($tools{$tool}));
   
     if ((!defined($udom)) || (!defined($uname))) {      if (($udom eq '') || ($uname eq '')) {
         $udom = $env{'user.domain'};          $udom = $env{'user.domain'};
         $uname = $env{'user.name'};          $uname = $env{'user.name'};
     }      }
Line 6672  sub allowed { Line 6801  sub allowed {
  && &is_portfolio_url($uri)) {   && &is_portfolio_url($uri)) {
  $thisallowed = &portfolio_access($uri);   $thisallowed = &portfolio_access($uri);
     }      }
       
 # 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 7253  sub definerole { Line 7382  sub definerole {
 # ---------------- Make a metadata query against the network of library servers  # ---------------- Make a metadata query against the network of library servers
   
 sub metadata_query {  sub metadata_query {
     my ($query,$custom,$customshow,$server_array)=@_;      my ($query,$custom,$customshow,$server_array,$domains_hash)=@_;
     my %rhash;      my %rhash;
     my %libserv = &all_library();      my %libserv = &all_library();
     my @server_list = (defined($server_array) ? @$server_array      my @server_list = (defined($server_array) ? @$server_array
                                               : keys(%libserv) );                                                : keys(%libserv) );
     for my $server (@server_list) {      for my $server (@server_list) {
           my $domains = ''; 
           if (ref($domains_hash) eq 'HASH') {
               $domains = $domains_hash->{$server}; 
           }
  unless ($custom or $customshow) {   unless ($custom or $customshow) {
     my $reply=&reply("querysend:".&escape($query),$server);      my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
     $rhash{$server}=$reply;      $rhash{$server}=$reply;
  }   }
  else {   else {
     my $reply=&reply("querysend:".&escape($query).':'.      my $reply=&reply("querysend:".&escape($query).':'.
      &escape($custom).':'.&escape($customshow),       &escape($custom).':'.&escape($customshow).':'.&escape($domains),
      $server);       $server);
     $rhash{$server}=$reply;      $rhash{$server}=$reply;
  }   }
Line 7754  sub auto_courserequest_checks { Line 7887  sub auto_courserequest_checks {
 }  }
   
 sub auto_courserequest_validation {  sub auto_courserequest_validation {
     my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;      my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$custominfo) = @_;
     my ($homeserver,$response);      my ($homeserver,$response);
     if ($dom =~ /^$match_domain$/) {      if ($dom =~ /^$match_domain$/) {
         $homeserver = &domain($dom,'primary');          $homeserver = &domain($dom,'primary');
     }      }
     unless ($homeserver eq 'no_host') {        unless ($homeserver eq 'no_host') {
                     my $customdata;
           if (ref($custominfo) eq 'HASH') {
               $customdata = &freeze_escape($custominfo);
           }
         $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).          $response=&unescape(&reply('autocrsreqvalidation:'.$dom.':'.&escape($owner).
                                     ':'.&escape($crstype).':'.&escape($inststatuslist).                                      ':'.&escape($crstype).':'.&escape($inststatuslist).
                                     ':'.&escape($instcode).':'.&escape($instseclist),                                      ':'.&escape($instcode).':'.&escape($instseclist).':'.
                                     $homeserver));                                      $customdata,$homeserver));
     }      }
     return $response;      return $response;
 }  }
Line 7783  sub auto_validate_class_sec { Line 7919  sub auto_validate_class_sec {
     return $response;      return $response;
 }  }
   
   sub auto_crsreq_update {
       my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
           $code,$accessstart,$accessend,$inbound) = @_;
       my ($homeserver,%crsreqresponse);
       if ($cdom =~ /^$match_domain$/) {
           $homeserver = &domain($cdom,'primary');
       }
       unless (($homeserver eq 'no_host') || ($homeserver eq '')) {
           my $info;
           if (ref($inbound) eq 'HASH') {
               $info = &freeze_escape($inbound);
           }
           my $response=&reply('autocrsrequpdate:'.$cdom.':'.$cnum.':'.&escape($crstype).
                               ':'.&escape($action).':'.&escape($ownername).':'.
                               &escape($ownerdomain).':'.&escape($fullname).':'.
                               &escape($title).':'.&escape($code).':'.
                               &escape($accessstart).':'.&escape($accessend).':'.$info,
                               $homeserver);
           unless ($response =~ /(con_lost|error|no_such_host|refused)/) {
               my @items = split(/&/,$response);
               foreach my $item (@items) {
                   my ($key,$value) = split('=',$item);
                   $crsreqresponse{&unescape($key)} = &thaw_unescape($value);
               }
           }
       }
       return \%crsreqresponse;
   }
   
 # ------------------------------------------------------- Course Group routines  # ------------------------------------------------------- Course Group routines
   
 sub get_coursegroups {  sub get_coursegroups {
Line 8464  sub modifystudent { Line 8629  sub modifystudent {
          $desiredhome,$email,$inststatus);           $desiredhome,$email,$inststatus);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     # This will cause &modify_student_enrollment to get the uid from the      # This will cause &modify_student_enrollment to get the uid from the
     # students environment      # student's environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
                                         $gene,$usec,$end,$start,$type,$locktype,                                          $gene,$usec,$end,$start,$type,$locktype,
Line 9600  sub resdata { Line 9765  sub resdata {
     return undef;      return undef;
 }  }
   
   sub get_numsuppfiles {
       my ($cnum,$cdom,$ignorecache)=@_;
       my $hashid=$cnum.':'.$cdom;
       my ($suppcount,$cached);
       unless ($ignorecache) {
           ($suppcount,$cached) = &is_cached_new('suppcount',$hashid);
       }
       unless (defined($cached)) {
           my $chome=&homeserver($cnum,$cdom);
           unless ($chome eq 'no_host') {
               ($suppcount,my $errors) = (0,0);
               my $suppmap = 'supplemental.sequence';
               ($suppcount,$errors) = 
                   &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
           }
           &do_cache_new('suppcount',$hashid,$suppcount,600);
       }
       return $suppcount;
   }
   
 #  #
 # EXT resource caching routines  # EXT resource caching routines
 #  #
Line 9743  sub EXT { Line 9928  sub EXT {
     if (!$symbparm) { $symbparm=&symbread(); }      if (!$symbparm) { $symbparm=&symbread(); }
  }   }
   
  if ($space eq 'title') {          if ($qualifier eq '') {
     if (!$symbparm) { $symbparm = $env{'request.filename'}; }      if ($space eq 'title') {
     return &gettitle($symbparm);          if (!$symbparm) { $symbparm = $env{'request.filename'}; }
  }          return &gettitle($symbparm);
       }
   
  if ($space eq 'map') {      if ($space eq 'map') {
     my ($map) = &decode_symb($symbparm);          my ($map) = &decode_symb($symbparm);
     return &symbread($map);          return &symbread($map);
  }      }
  if ($space eq 'filename') {              if ($space eq 'maptitle') {
     if ($symbparm) {                  my ($map) = &decode_symb($symbparm);
  return &clutter((&decode_symb($symbparm))[2]);                  return &gettitle($map);
               }
       if ($space eq 'filename') {
           if ($symbparm) {
       return &clutter((&decode_symb($symbparm))[2]);
           }
           return &hreflocation('',$env{'request.filename'});
     }      }
     return &hreflocation('',$env{'request.filename'});  
  }              if ((defined($courseid)) && ($courseid eq $env{'request.course.id'}) && $symbparm) {
                   if ($space eq 'visibleparts') {
                       my $navmap = Apache::lonnavmaps::navmap->new();
                       my $item;
                       if (ref($navmap)) {
                           my $res = $navmap->getBySymb($symbparm);
                           my $parts = $res->parts();
                           if (ref($parts) eq 'ARRAY') {
                               $item = join(',',@{$parts});
                           }
                           undef($navmap);
                       }
                       return $item;
                   }
               }
           }
   
  my ($section, $group, @groups);   my ($section, $group, @groups);
  my ($courselevelm,$courselevel);   my ($courselevelm,$courselevel);
Line 10016  sub metadata { Line 10223  sub metadata {
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
     if (($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/)       if (($uri =~ /^priv/ || $uri=~m{^home/httpd/html/priv}) 
  && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {   && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  return undef;   return undef;
     }      }
Line 11074  sub rndseed_CODE_64bit5 { Line 11281  sub rndseed_CODE_64bit5 {
 sub setup_random_from_rndseed {  sub setup_random_from_rndseed {
     my ($rndseed)=@_;      my ($rndseed)=@_;
     if ($rndseed =~/([,:])/) {      if ($rndseed =~/([,:])/) {
  my ($num1,$num2)=split(/[,:]/,$rndseed);          my ($num1,$num2) = map { abs($_); } (split(/[,:]/,$rndseed));
  &Math::Random::random_set_seed(abs($num1),abs($num2));          if ((!$num1) || (!$num2) || ($num1 > 2147483562) || ($num2 > 2147483398)) {
               &Math::Random::random_set_seed_from_phrase($rndseed);
           } else {
               &Math::Random::random_set_seed($num1,$num2);
           }
     } else {      } else {
  &Math::Random::random_set_seed_from_phrase($rndseed);   &Math::Random::random_set_seed_from_phrase($rndseed);
     }      }
Line 11466  sub default_login_domain { Line 11677  sub default_login_domain {
 sub declutter {  sub declutter {
     my $thisfn=shift;      my $thisfn=shift;
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;      unless ($thisfn=~m{^/home/httpd/html/priv/}) {
           $thisfn=~s{^/home/httpd/html}{};
       }
     $thisfn=~s/^\///;      $thisfn=~s/^\///;
     $thisfn=~s|^adm/wrapper/||;      $thisfn=~s|^adm/wrapper/||;
     $thisfn=~s|^adm/coursedocs/showdoc/||;      $thisfn=~s|^adm/coursedocs/showdoc/||;
Line 11625  sub parse_dns_checksums_tab { Line 11838  sub parse_dns_checksums_tab {
     my (%chksum,%revnum);      my (%chksum,%revnum);
     if (ref($lines) eq 'ARRAY') {      if (ref($lines) eq 'ARRAY') {
         chomp(@{$lines});          chomp(@{$lines});
         my $versions = shift(@{$lines});          my $version = shift(@{$lines});
         my %supported;          if ($version eq $release) {  
         if ($versions =~ /^VERSIONS\:([\w\.\,]+)$/) {  
             my $releaseslist = $1;  
             if ($releaseslist =~ /,/) {  
                 map { $supported{$_} = 1; } split(/,/,$releaseslist);  
             } elsif ($releaseslist) {  
                 $supported{$releaseslist} = 1;  
             }  
         }  
         if ($supported{$release}) {    
             my $matchthis = 0;  
             foreach my $line (@{$lines}) {              foreach my $line (@{$lines}) {
                 if ($line =~ /^(\d[\w\.]+)$/) {                  my ($file,$version,$shasum) = split(/,/,$line);
                     if ($matchthis) {                  $chksum{$file} = $shasum;
                         last;                  $revnum{$file} = $version;
                     } elsif ($1 eq $release) {  
                         $matchthis = 1;  
                     }  
                 } elsif ($matchthis) {  
                     my ($file,$version,$shasum) = split(/,/,$line);  
                     $chksum{$file} = $shasum;  
                     $revnum{$file} = $version;  
                 }  
             }              }
             if (ref($hashref) eq 'HASH') {              if (ref($hashref) eq 'HASH') {
                 %{$hashref} = (                  %{$hashref} = (
Line 11662  sub parse_dns_checksums_tab { Line 11857  sub parse_dns_checksums_tab {
 }  }
   
 sub fetch_dns_checksums {  sub fetch_dns_checksums {
     my %checksums;       my %checksums;
     &get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1,      my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
       my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});
       my ($release,$timestamp) = split(/\-/,$loncaparev);
       &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
              \%checksums);               \%checksums);
     return \%checksums;      return \%checksums;
 }  }
Line 12041  sub fetch_dns_checksums { Line 12239  sub fetch_dns_checksums {
 }  }
   
 sub all_loncaparevs {  sub all_loncaparevs {
     return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10);      return qw(1.1 1.2 1.3 2.0 2.1 2.2 2.3 2.4 2.5 2.6 2.7 2.8 2.9 2.10 2.11);
 }  }
   
 # ---------------------------------------------------------- Read loncaparev table  # ---------------------------------------------------------- Read loncaparev table
Line 12219  $readit=1; Line 12417  $readit=1;
  if ($test != 0) { $_64bit=1; } else { $_64bit=0; }   if ($test != 0) { $_64bit=1; } else { $_64bit=0; }
  &logthis(" Detected 64bit platform ($_64bit)");   &logthis(" Detected 64bit platform ($_64bit)");
     }      }
   
     {  
         eval {  
             ($apache) =  
                 (Apache2::ServerUtil::get_server_version() =~ m{Apache/(\d+\.\d+)});  
         };  
         if ($@) {  
            $apache = 1.3;  
         }  
     }  
   
 }  }
 }  }
   
Line 12638  or when Autoupdate.pl is run by cron in Line 12825  or when Autoupdate.pl is run by cron in
 modifystudent  modifystudent
   
 modify a student's enrollment and identification information.  modify a student's enrollment and identification information.
 The course id is resolved based on the current users environment.    The course id is resolved based on the current user's environment.  
 This means the envoking user must be a course coordinator or otherwise  This means the invoking user must be a course coordinator or otherwise
 associated with a course.  associated with a course.
   
 This call is essentially a wrapper for lonnet::modifyuser and  This call is essentially a wrapper for lonnet::modifyuser and
Line 12699  Inputs: Line 12886  Inputs:
   
 modify_student_enrollment  modify_student_enrollment
   
 Change a students enrollment status in a class.  The environment variable  Change a student's enrollment status in a class.  The environment variable
 'role.request.course' must be defined for this function to proceed.  'role.request.course' must be defined for this function to proceed.
   
 Inputs:  Inputs:
   
 =over 4  =over 4
   
 =item $udom, students domain  =item $udom, student's domain
   
 =item $uname, students name  =item $uname, student's name
   
 =item $uid, students user id  =item $uid, student's user id
   
 =item $first, students first name  =item $first, student's first name
   
 =item $middle  =item $middle
   
Line 12794  If defined, the supplied username is use Line 12981  If defined, the supplied username is use
 resdata($name,$domain,$type,@which) : request for current parameter  resdata($name,$domain,$type,@which) : request for current parameter
 setting for a specific $type, where $type is either 'course' or 'user',  setting for a specific $type, where $type is either 'course' or 'user',
 @what should be a list of parameters to ask about. This routine caches  @what should be a list of parameters to ask about. This routine caches
 answers for 5 minutes.  answers for 10 minutes.
   
 =item *  =item *
   
Line 12803  data base, returning a hash that is keye Line 12990  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 13148  server ($udom and $uhome are optional) Line 13339  server ($udom and $uhome are optional)
   
 =item *   =item * 
   
 get_domain_defaults($target_domain) : returns hash with defaults for  get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults 
 authentication and language in the domain. Keys are: auth_def, auth_arg_def,  for: authentication, language, quotas, timezone, date locale, and portal URL in
 lang_def; corresponsing values are authentication type (internal, krb4, krb5,  the target domain.
 or localauth), initial password or a kerberos realm, language (e.g., en-us).  
 Values are retrieved from cache (if current), or from domain's configuration.db  May also include additional key => value pairs for the following groups:
 (if available), or lastly from values in lonTabs/dns_domain,tab,   
 or lonTabs/domain.tab.   =over
   
   =item
   disk quotas (MB allocated by default to portfolios and authoring spaces).
   
   =over
   
   =item defaultquota, authorquota
   
   =back
   
   =item
   tools (availability of aboutme page, blog, webDAV access for authoring spaces,
   portfolio for users).
   
   =over
   
   =item
   aboutme, blog, webdav, portfolio
   
   =back
   
   =item
   requestcourses: ability to request courses, and how requests are processed.
   
   =over
   
   =item
   official, unofficial, community, textbook
   
   =back
   
   =item
   inststatus: types of institutional affiliation, and order in which they are displayed.
   
   =over
   
   =item
   inststatustypes, inststatusorder, inststatusguest
   
   =back
   
   =item
   coursedefaults: can PDF forms can be created, default credits for courses, default quotas (MB)
   for course's uploaded content.
   
   =over
   
   =item
   canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, 
   communityquota, textbookquota
   
   =back
   
   =item
   usersessions: set options for hosting of your users in other domains, and hosting of users from other domains
   on your servers.
   
   =over
   
   =item 
   remotesessions, hostedsessions
   
   =back
   
   =back
   
   In cases where a domain coordinator has never used the "Set Domain Configuration"
   utility to create a configuration.db file on a domain's primary library server 
   only the following domain defaults: auth_def, auth_arg_def, lang_def
   -- corresponding values are authentication type (internal, krb4, krb5,
   or localauth), initial password or a kerberos realm, language (e.g., en-us) -- 
   will be available. Values are retrieved from cache (if current), unless the
   optional $ignore_cache arg is true, or from domain's configuration.db (if available),
   or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.
   
   Typical usage:
   
 %domdefaults = &get_auth_defaults($target_domain);  %domdefaults = &get_domain_defaults($target_domain);
   
 =back  =back
   
Line 13381  filelocation except for hrefs Line 13648  filelocation except for hrefs
   
 =item *  =item *
   
 declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)  declutter() : declutters URLs -- remove beginning slashes, 'res' etc.
   also removes beginning /home/httpd/html unless /priv/ follows it.
   
 =back  =back
   

Removed from v.1.1230  
changed lines
  Added in v.1.1262


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