[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.1200 and 1.1243

version 1.1200, 2012/11/29 03:23:52 version 1.1243, 2013/10/14 17:14:48
Line 78  use Image::Magick; Line 78  use Image::Magick;
   
 use Encode;  use Encode;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache
             $_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 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')) {
               $r->user($disk_env{'user.name'});
           } else {
               $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});
           }
       }
     return $handle;      return $handle;
 }  }
   
Line 1316  sub check_loadbalancing { Line 1326  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 1571  sub idput { Line 1581  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 1947  sub inst_userrules { Line 1987  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 1978  sub get_domain_defaults { Line 2021  sub get_domain_defaults {
             $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};              $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
         } else {          } else {
             $domdefaults{'defaultquota'} = $domconfig{'quotas'};              $domdefaults{'defaultquota'} = $domconfig{'quotas'};
         }           }
         my @usertools = ('aboutme','blog','webdav','portfolio');          my @usertools = ('aboutme','blog','webdav','portfolio');
         foreach my $item (@usertools) {          foreach my $item (@usertools) {
             if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {              if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
                 $domdefaults{$item} = $domconfig{'quotas'}{$item};                  $domdefaults{$item} = $domconfig{'quotas'}{$item};
             }              }
         }          }
           if (ref($domconfig{'quotas'}{'authorquota'}) eq 'HASH') {
               $domdefaults{'authorquota'} = $domconfig{'quotas'}{'authorquota'};
           }
     }      }
     if (ref($domconfig{'requestcourses'}) eq 'HASH') {      if (ref($domconfig{'requestcourses'}) eq 'HASH') {
         foreach my $item ('official','unofficial','community') {          foreach my $item ('official','unofficial','community') {
Line 2000  sub get_domain_defaults { Line 2046  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         foreach my $item ('canuse_pdfforms') {          $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
             $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};          if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
               $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};
               $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};
           }
           if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
               $domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'};
               $domdefaults{'unofficialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'unofficial'};
               $domdefaults{'communityquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'community'};           
         }          }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
Line 2012  sub get_domain_defaults { Line 2065  sub get_domain_defaults {
             $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};              $domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
         }          }
     }      }
     &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,      &do_cache_new('domdefaults',$domain,\%domdefaults,$cachetime);
                                   $cachetime);  
     return %domdefaults;      return %domdefaults;
 }  }
   
Line 2716  sub can_edit_resource { Line 2768  sub can_edit_resource {
                 return;                  return;
             }              }
         } else {          } else {
               if ($resurl =~ m{^/?adm/viewclasslist$}) {
                   unless (&Apache::lonnet::allowed('opa',$env{'request.course.id'})) {
                       return;
                   }
               } elsif (!$crsedit) {
 #  #
 # No edit allowed where CC has switched to student role.  # No edit allowed where CC has switched to student role.
 #  #
             unless ($crsedit) {  
                 return;                  return;
             }              }
         }          }
Line 2732  sub can_edit_resource { Line 2788  sub can_edit_resource {
                 $incourse = 1;                  $incourse = 1;
                 if ($file =~/\.(htm|html|css|js|txt)$/) {                  if ($file =~/\.(htm|html|css|js|txt)$/) {
                     $cfile = &hreflocation('',$file);                      $cfile = &hreflocation('',$file);
                     $forceedit = 1;                      if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                 }                  }
             } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) {              } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) {
                 $incourse = 1;                  $incourse = 1;
Line 2762  sub can_edit_resource { Line 2822  sub can_edit_resource {
                         $forceedit = 1;                          $forceedit = 1;
                     }                      }
                     $cfile = $resurl;                      $cfile = $resurl;
                   } elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
                       $incourse = 1;
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                       $cfile = ($resurl =~ m{^/} ? $resurl : "/$resurl");
                 }                  }
             } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {              } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem/smpedit') {
                 my $template = '/res/lib/templates/simpleproblem.problem';                  my $template = '/res/lib/templates/simpleproblem.problem';
Line 2790  sub can_edit_resource { Line 2858  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) {
             $home=&homeserver($cnum,$cdom);              $home=&homeserver($cnum,$cdom);
         } else {          } elsif ($file !~ m{/$}) {
             $file=~s{^(priv/$match_domain/$match_username)}{/$1};              $file=~s{^(priv/$match_domain/$match_username)}{/$1};
             $file=~s{^($match_domain/$match_username)}{/priv/$1};              $file=~s{^($match_domain/$match_username)}{/priv/$1};
             # Check that the user has permission to edit this resource              # Check that the user has permission to edit this resource
Line 2820  sub is_course_upload { Line 2895  sub is_course_upload {
     my ($file,$cnum,$cdom) = @_;      my ($file,$cnum,$cdom) = @_;
     my $uploadpath = &LONCAPA::propath($cdom,$cnum);      my $uploadpath = &LONCAPA::propath($cdom,$cnum);
     $uploadpath =~ s{^\/}{};      $uploadpath =~ s{^\/}{};
     if (($file =~ m{^\Q$uploadpath\E/userfiles/docs/}) ||      if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) ||
         ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/docs/})) {          ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) {
         return 1;          return 1;
     }      }
     return;      return;
Line 2831  sub in_course { Line 2906  sub in_course {
     my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_;      my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_;
     if ($hideprivileged) {      if ($hideprivileged) {
         my $skipuser;          my $skipuser;
         if (&privileged($uname,$udom)) {          my %coursehash = &coursedescription($cdom.'_'.$cnum);
           my @possdoms = ($cdom);  
           if ($coursehash{'checkforpriv'}) { 
               push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); 
           }
           if (&privileged($uname,$udom,\@possdoms)) {
             $skipuser = 1;              $skipuser = 1;
             my %coursehash = &coursedescription($cdom.'_'.$cnum);  
             if ($coursehash{'nothideprivileged'}) {              if ($coursehash{'nothideprivileged'}) {
                 foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {                  foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
                     my $user;                      my $user;
Line 3166  sub userfileupload { Line 3245  sub userfileupload {
  $codebase,$thumbwidth,$thumbheight,   $codebase,$thumbwidth,$thumbheight,
                                          $resizewidth,$resizeheight,$context,$mimetype);                                           $resizewidth,$resizeheight,$context,$mimetype);
         } else {          } else {
             $fname=$env{'form.folder'}.'/'.$fname;              if ($env{'form.folder'}) {
                   $fname=$env{'form.folder'}.'/'.$fname;
               }
             return &process_coursefile('uploaddoc',$docuname,$docudom,              return &process_coursefile('uploaddoc',$docuname,$docudom,
        $fname,$formname,$parser,         $fname,$formname,$parser,
        $allfiles,$codebase,$mimetype);         $allfiles,$codebase,$mimetype);
Line 3181  sub userfileupload { Line 3262  sub userfileupload {
     } else {      } else {
         my $docuname=$env{'user.name'};          my $docuname=$env{'user.name'};
         my $docudom=$env{'user.domain'};          my $docudom=$env{'user.domain'};
         if (exists($env{'form.group'})) {          if ((exists($env{'form.group'})) || ($context eq 'syllabus')) {
             $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};              $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
             $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};              $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
         }          }
Line 3331  sub extract_embedded_items { Line 3412  sub extract_embedded_items {
  &add_filetype($allfiles,$attr->{'src'},'src');   &add_filetype($allfiles,$attr->{'src'},'src');
     }      }
     if (lc($tagname) eq 'a') {      if (lc($tagname) eq 'a') {
  &add_filetype($allfiles,$attr->{'href'},'href');                  unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {
                       &add_filetype($allfiles,$attr->{'href'},'href');
                   }
     }      }
             if (lc($tagname) eq 'script') {              if (lc($tagname) eq 'script') {
                 my $src;                  my $src;
Line 3419  sub extract_embedded_items { Line 3502  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 3862  sub get_course_adv_roles { Line 3963  sub get_course_adv_roles {
             $nothide{$user}=1;              $nothide{$user}=1;
         }          }
     }      }
       my @possdoms = ($coursehash{'domain'});
       if ($coursehash{'checkforpriv'}) {
           push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
       }
     my %returnhash=();      my %returnhash=();
     my %dumphash=      my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
Line 3874  sub get_course_adv_roles { Line 3979  sub get_course_adv_roles {
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);          my ($role,$username,$domain,$section)=split(/\:/,$entry);
  if ($username eq '' || $domain eq '') { next; }   if ($username eq '' || $domain eq '') { next; }
         unless (ref($privileged{$domain}) eq 'HASH') {          if ((&privileged($username,$domain,\@possdoms)) &&
             my %dompersonnel =  
                 &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);  
             $privileged{$domain} = {};  
             foreach my $server (keys(%dompersonnel)) {  
                 if (ref($dompersonnel{$server}) eq 'HASH') {  
                     foreach my $user (keys(%{$dompersonnel{$server}})) {  
                         my ($trole,$uname,$udom) = split(/:/,$user);  
                         $privileged{$udom}{$uname} = 1;  
                     }  
                 }  
             }  
         }  
         if ((exists($privileged{$domain}{$username})) &&   
             (!$nothide{$username.':'.$domain})) { next; }              (!$nothide{$username.':'.$domain})) { next; }
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         if ($codes) {          if ($codes) {
Line 3918  sub get_my_roles { Line 4010  sub get_my_roles {
     if ($context eq 'userroles') {      if ($context eq 'userroles') {
         %dumphash = &dump('roles',$udom,$uname);          %dumphash = &dump('roles',$udom,$uname);
     } else {      } else {
         %dumphash=          %dumphash = &dump('nohist_userroles',$udom,$uname);
             &dump('nohist_userroles',$udom,$uname);  
         if ($hidepriv) {          if ($hidepriv) {
             my %coursehash=&coursedescription($udom.'_'.$uname);              my %coursehash=&coursedescription($udom.'_'.$uname);
             foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {              foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
Line 3987  sub get_my_roles { Line 4078  sub get_my_roles {
             }              }
         }          }
         if ($hidepriv) {          if ($hidepriv) {
               my @privroles = ('dc','su');
             if ($context eq 'userroles') {              if ($context eq 'userroles') {
                 if ((&privileged($username,$domain)) &&                  next if (grep(/^\Q$role\E$/,@privroles));
                     (!$nothide{$username.':'.$domain})) {  
                     next;  
                 }  
             } else {              } else {
                 unless (ref($privileged{$domain}) eq 'HASH') {                  my $possdoms = [$domain];
                     my %dompersonnel =                  if (ref($roledoms) eq 'ARRAY') {
                         &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);                     push(@{$possdoms},@{$roledoms}); 
                     $privileged{$domain} = {};  
                     if (keys(%dompersonnel)) {  
                         foreach my $server (keys(%dompersonnel)) {  
                             if (ref($dompersonnel{$server}) eq 'HASH') {  
                                 foreach my $user (keys(%{$dompersonnel{$server}})) {  
                                     my ($trole,$uname,$udom) = split(/:/,$user);  
                                     $privileged{$udom}{$uname} = $trole;  
                                 }  
                             }  
                         }  
                     }  
                 }                  }
                 if (exists($privileged{$domain}{$username})) {                  if (&privileged($username,$domain,$possdoms,\@privroles)) {
                     if (!$nothide{$username.':'.$domain}) {                      if (!$nothide{$username.':'.$domain}) {
                         next;                          next;
                     }                      }
Line 4243  sub get_domain_roles { Line 4321  sub get_domain_roles {
     }      }
     my $rolelist;      my $rolelist;
     if (ref($roles) eq 'ARRAY') {      if (ref($roles) eq 'ARRAY') {
         $rolelist = join(':',@{$roles});          $rolelist = join('&',@{$roles});
     }      }
     my %personnel = ();      my %personnel = ();
   
Line 4785  sub restore { Line 4863  sub restore {
     if ($stuname) { $home=&homeserver($stuname,$domain); }      if ($stuname) { $home=&homeserver($stuname,$domain); }
   
     if (!$symb) {      if (!$symb) {
       unless ($symb=escape(&symbread())) { return ''; }          return if ($namespace eq 'courserequests');
           unless ($symb=escape(&symbread())) { return ''; }
     } else {      } else {
       $symb=&escape(&symbclean($symb));          unless ($namespace eq 'courserequests') {
               $symb=&escape(&symbclean($symb));
           }
     }      }
     if (!$namespace) {       if (!$namespace) { 
        unless ($namespace=$env{'request.course.id'}) {          unless ($namespace=$env{'request.course.id'}) { 
Line 4922  sub update_released_required { Line 5003  sub update_released_required {
 # -------------------------------------------------See if a user is privileged  # -------------------------------------------------See if a user is privileged
   
 sub privileged {  sub privileged {
     my ($username,$domain)=@_;      my ($username,$domain,$possdomains,$possroles)=@_;
   
     my %rolesdump = &dump("roles", $domain, $username) or return 0;  
     my $now = time;      my $now = time;
       my $roles;
       if (ref($possroles) eq 'ARRAY') {
           $roles = $possroles; 
       } else {
           $roles = ['dc','su'];
       }
       if (ref($possdomains) eq 'ARRAY') {
           my %privileged = &privileged_by_domain($possdomains,$roles);
           foreach my $dom (@{$possdomains}) {
               if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) &&
                   (ref($privileged{$dom}) eq 'HASH')) {
                   foreach my $role (@{$roles}) {
                       if (ref($privileged{$dom}{$role}) eq 'HASH') {
                           if (exists($privileged{$dom}{$role}{$username.':'.$domain})) {
                               my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain});
                               return 1 unless (($end && $end < $now) ||
                                                ($start && $start > $now));
                           }
                       }
                   }
               }
           }
       } else {
           my %rolesdump = &dump("roles", $domain, $username) or return 0;
           my $now = time;
   
     for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {          for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
             my ($trole, $tend, $tstart) = split(/_/, $role);              my ($trole, $tend, $tstart) = split(/_/, $role);
             if (($trole eq 'dc') || ($trole eq 'su')) {              if (grep(/^\Q$trole\E$/,@{$roles})) {
                 return 1 unless ($tend && $tend < $now)                   return 1 unless ($tend && $tend < $now) 
                     or ($tstart && $tstart > $now);                          or ($tstart && $tstart > $now);
             }              }
  }          }
       }
     return 0;      return 0;
 }  }
   
   sub privileged_by_domain {
       my ($domains,$roles) = @_;
       my %privileged = ();
       my $cachetime = 60*60*24;
       my $now = time;
       unless ((ref($domains) eq 'ARRAY') && (ref($roles) eq 'ARRAY')) {
           return %privileged;
       }
       foreach my $dom (@{$domains}) {
           next if (ref($privileged{$dom}) eq 'HASH');
           my $needroles;
           foreach my $role (@{$roles}) {
               my ($result,$cached)=&is_cached_new('priv_'.$role,$dom);
               if (defined($cached)) {
                   if (ref($result) eq 'HASH') {
                       $privileged{$dom}{$role} = $result;
                   }
               } else {
                   $needroles = 1;
               }
           }
           if ($needroles) {
               my %dompersonnel = &get_domain_roles($dom,$roles);
               $privileged{$dom} = {};
               foreach my $server (keys(%dompersonnel)) {
                   if (ref($dompersonnel{$server}) eq 'HASH') {
                       foreach my $item (keys(%{$dompersonnel{$server}})) {
                           my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);
                           my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});
                           next if ($end && $end < $now);
                           $privileged{$dom}{$trole}{$uname.':'.$udom} = 
                               $dompersonnel{$server}{$item};
                       }
                   }
               }
               if (ref($privileged{$dom}) eq 'HASH') {
                   foreach my $role (@{$roles}) {
                       if (ref($privileged{$dom}{$role}) eq 'HASH') {
                           &do_cache_new('priv_'.$role,$dom,$privileged{$dom}{$role},$cachetime);
                       } else {
                           my %hash = ();
                           &do_cache_new('priv_'.$role,$dom,\%hash,$cachetime);
                       }
                   }
               }
           }
       }
       return %privileged;
   }
   
 # -------------------------------------------------------- Get user privileges  # -------------------------------------------------------- Get user privileges
   
 sub rolesinit {  sub rolesinit {
Line 5047  sub rolesinit { Line 5201  sub rolesinit {
 }  }
   
 sub set_arearole {  sub set_arearole {
     my ($trole,$area,$tstart,$tend,$domain,$username) = @_;      my ($trole,$area,$tstart,$tend,$domain,$username,$nolog) = @_;
       unless ($nolog) {
 # log the associated role with the area  # log the associated role with the area
     &userrolelog($trole,$username,$domain,$area,$tstart,$tend);          &userrolelog($trole,$username,$domain,$area,$tstart,$tend);
       }
     return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);      return ('user.role.'.$trole.'.'.$area => $tstart.'.'.$tend);
 }  }
   
Line 5318  sub set_adhoc_privileges { Line 5474  sub set_adhoc_privileges {
     my $area = '/'.$dcdom.'/'.$pickedcourse;      my $area = '/'.$dcdom.'/'.$pickedcourse;
     my $spec = $role.'.'.$area;      my $spec = $role.'.'.$area;
     my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},      my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
                                   $env{'user.name'});                                    $env{'user.name'},1);
     my %ccrole = ();      my %ccrole = ();
     &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);      &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
     my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);      my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
Line 5409  sub dump { Line 5565  sub dump {
     if (grep { $_ eq $uhome } current_machine_ids()) {      if (grep { $_ eq $uhome } current_machine_ids()) {
         # user is hosted on this machine          # user is hosted on this machine
         $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,          $reply = LONCAPA::Lond::dump_with_regexp(join(":", ($udomain,
                     $uname, $namespace, $regexp, $range)), $loncaparevs{$uhome});                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
         return %{unserialize($reply, $escapedkeys)};          return %{unserialize($reply, $escapedkeys)};
     }      }
     if ($regexp) {      if ($regexp) {
Line 6067  sub usertools_access { Line 6223  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 6877  sub constructaccess { Line 7033  sub constructaccess {
     if (($allowed eq 'F') || ($allowed eq 'U')) {      if (($allowed eq 'F') || ($allowed eq 'U')) {
 # Grant temporary access  # Grant temporary access
         my $then=$env{'user.login.time'};          my $then=$env{'user.login.time'};
         my $update==$env{'user.update.time'};          my $update=$env{'user.update.time'};
         if (!$update) { $update = $then; }          if (!$update) { $update = $then; }
         my $refresh=$env{'user.refresh.time'};          my $refresh=$env{'user.refresh.time'};
         if (!$refresh) { $refresh = $update; }          if (!$refresh) { $refresh = $update; }
Line 7158  sub definerole { Line 7314  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 7416  sub auto_validate_instcode { Line 7576  sub auto_validate_instcode {
     }      }
     $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.      $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
                         &escape($instcode).':'.&escape($owner),$homeserver));                          &escape($instcode).':'.&escape($owner),$homeserver));
     my ($outcome,$description) = map { &unescape($_); } split('&',$response,2);      my ($outcome,$description,$defaultcredits) = map { &unescape($_); } split('&',$response,3);
     return ($outcome,$description);      return ($outcome,$description,$defaultcredits);
 }  }
   
 sub auto_create_password {  sub auto_create_password {
Line 8357  sub modifyuser { Line 8517  sub modifyuser {
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
         $selfenroll,$context,$inststatus)=@_;          $selfenroll,$context,$inststatus,$credits)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 8369  sub modifystudent { Line 8529  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,$cid,$selfenroll,$context);                                          $gene,$usec,$end,$start,$type,$locktype,
                                           $cid,$selfenroll,$context,$credits);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,
           $locktype,$cid,$selfenroll,$context,$credits) = @_;
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
Line 8424  sub modify_student_enrollment { Line 8586  sub modify_student_enrollment {
     my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);      my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
     my $reply=cput('classlist',      my $reply=cput('classlist',
    {$user =>      {$user => 
  join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) },
    $cdom,$cnum);     $cdom,$cnum);
     if (($reply eq 'ok') || ($reply eq 'delayed')) {      if (($reply eq 'ok') || ($reply eq 'delayed')) {
         &devalidate_getsection_cache($udom,$uname,$cid);          &devalidate_getsection_cache($udom,$uname,$cid);
Line 8653  sub is_course { Line 8815  sub is_course {
     my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,      my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
         '.');          '.');
   
     return unless exists($courses{$cdom.'_'.$cnum});      return unless(exists($courses{$cdom.'_'.$cnum}));
     return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;      return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
 }  }
   
Line 8678  sub store_userdata { Line 8840  sub store_userdata {
                     $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';                      $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
                 }                  }
                 $namevalue=~s/\&$//;                  $namevalue=~s/\&$//;
                   unless ($namespace eq 'courserequests') {
                       $datakey = &escape($datakey);
                   }
                 $result =  &reply("store:$udom:$uname:$namespace:$datakey:".                  $result =  &reply("store:$udom:$uname:$namespace:$datakey:".
                                   $namevalue,$uhome);                                    $namevalue,$uhome);
             }              }
Line 9500  sub resdata { Line 9665  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 9528  sub EXT_cache_set { Line 9713  sub EXT_cache_set {
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
 sub EXT {  sub EXT {
   
     my ($varname,$symbparm,$udom,$uname,$usection,$recurse)=@_;      my ($varname,$symbparm,$udom,$uname,$usection,$recurse,$cid)=@_;
     unless ($varname) { return ''; }      unless ($varname) { return ''; }
     #get real user name/domain, courseid and symb      #get real user name/domain, courseid and symb
     my $courseid;      my $courseid;
Line 9643  sub EXT { Line 9828  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);
  if ($symbparm && defined($courseid) &&           if (($courseid eq '') && ($cid)) {
     $courseid eq $env{'request.course.id'}) {              $courseid = $cid;
           }
    if (($symbparm && $courseid) && 
       (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid)))  {
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
Line 9909  sub metadata { Line 10119  sub metadata {
     # if it is a non metadata possible uri return quickly      # if it is a non metadata possible uri return quickly
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  return undef;   return undef;
     }      }
Line 10287  sub gettitle { Line 10497  sub gettitle {
     return $title;      return $title;
 }  }
   
 sub getdocspath {  
     my ($symb) = @_;  
     my $path;  
     if ($symb) {  
         my ($mapurl,$id,$resurl) = &decode_symb($symb);  
         if ($resurl=~/\.(sequence|page)$/) {  
             $mapurl=$resurl;  
         } elsif ($resurl eq 'adm/navmaps') {  
             $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'};  
         }  
         my $mapresobj;  
         my $navmap = Apache::lonnavmaps::navmap->new();  
         if (ref($navmap)) {  
             $mapresobj = $navmap->getResourceByUrl($mapurl);  
         }  
         $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1};  
         my $type=$2;  
         if (ref($mapresobj)) {  
             my $pcslist = $mapresobj->map_hierarchy();  
             if ($pcslist ne '') {  
                 foreach my $pc (split(/,/,$pcslist)) {  
                     next if ($pc <= 1);  
                     my $res = $navmap->getByMapPc($pc);  
                     if (ref($res)) {  
                         my $thisurl = $res->src();  
                         $thisurl=~s{^.*/([^/]+)\.\w+$}{$1};  
                         my $thistitle = $res->title();  
                         $path .= '&'.  
                                  &Apache::lonhtmlcommon::entity_encode($thisurl).'&'.  
                                  &Apache::lonhtmlcommon::entity_encode($thistitle).  
                                  ':'.$res->randompick().  
                                  ':'.$res->randomout().  
                                  ':'.$res->encrypted().  
                                  ':'.$res->randomorder();  
                     }  
                 }  
             }  
             $path =~ s/^\&//;  
             my $maptitle = $mapresobj->title();  
             if ($mapurl eq 'default') {  
                 $maptitle = 'Main Course Documents';  
             }  
             $path .= ($path ne '')? '&' : ''.  
                     &Apache::lonhtmlcommon::entity_encode($mapurl).'&'.  
                     &Apache::lonhtmlcommon::entity_encode($maptitle).  
                     ':'.$mapresobj->randompick().  
                     ':'.$mapresobj->randomout().  
                     ':'.$mapresobj->encrypted().  
                     ':'.$mapresobj->randomorder();  
         } else {  
             my $maptitle = &gettitle($mapurl);  
             if ($mapurl eq 'default') {  
                 $maptitle = 'Main Course Documents';  
             }  
             $path = &Apache::lonhtmlcommon::entity_encode($mapurl).'&'.  
                     &Apache::lonhtmlcommon::entity_encode($maptitle).'::::';  
         }  
         unless ($mapurl eq 'default') {  
             $path = 'default&'.  
                     &Apache::lonhtmlcommon::entity_encode('Main Course Documents').  
                     '::::&'.$path;  
         }  
     }  
     return $path;  
 }  
   
 sub get_slot {  sub get_slot {
     my ($which,$cnum,$cdom)=@_;      my ($which,$cnum,$cdom)=@_;
     if (!$cnum || !$cdom) {      if (!$cnum || !$cdom) {
Line 10406  sub get_course_slots { Line 10550  sub get_course_slots {
         my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);          my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);
         my ($tmp) = keys(%slots);          my ($tmp) = keys(%slots);
         if ($tmp !~ /^(con_lost|error|no_such_host)/i) {          if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
             &Apache::lonnet::do_cache_new('allslots',$hashid,\%slots,600);              &do_cache_new('allslots',$hashid,\%slots,600);
             return %slots;              return %slots;
         }          }
     }      }
Line 10500  sub symbverify { Line 10644  sub symbverify {
   
     if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
                             &GDBM_READER(),0640)) {                              &GDBM_READER(),0640)) {
           my $noclutter;
         if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {          if (($thisurl =~ m{^/adm/wrapper/ext/}) || ($thisurl =~ m{^ext/})) {
             $thisurl =~ s/\?.+$//;              $thisurl =~ s/\?.+$//;
               if ($map =~ m{^uploaded/.+\.page$}) {
                   $thisurl =~ s{^(/adm/wrapper|)/ext/}{http://};
                   $thisurl =~ s{^\Qhttp://https://\E}{https://};
                   $noclutter = 1;
               }
           }
           my $ids;
           if ($noclutter) {
               $ids=$bighash{'ids_'.$thisurl};
           } else {
               $ids=$bighash{'ids_'.&clutter($thisurl)};
         }          }
         my $ids=$bighash{'ids_'.&clutter($thisurl)};  
         unless ($ids) {          unless ($ids) {
             my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;                my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;  
             $ids=$bighash{$idkey};              $ids=$bighash{$idkey};
         }          }
         if ($ids) {          if ($ids) {
 # ------------------------------------------------------------------- Has ID(s)  # ------------------------------------------------------------------- Has ID(s)
               if ($thisfn =~ m{^/adm/wrapper/ext/}) {
                   $symb =~ s/\?.+$//;
               }
     foreach my $id (split(/\,/,$ids)) {      foreach my $id (split(/\,/,$ids)) {
        my ($mapid,$resid)=split(/\./,$id);         my ($mapid,$resid)=split(/\./,$id);
                if ($thisfn =~ m{^/adm/wrapper/ext/}) {  
                    $symb =~ s/\?.+$//;  
                }  
                if (                 if (
   &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)    &symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
    eq $symb) {     eq $symb) {
Line 10525  sub symbverify { Line 10680  sub symbverify {
        ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||         ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
                        ($thisurl eq '/adm/navmaps')) {                         ($thisurl eq '/adm/navmaps')) {
        $okay=1;         $okay=1;
                          last;
    }     }
        }         }
    }     }
Line 10600  sub deversion { Line 10756  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
     my $cache_str='request.symbread.cached.'.$thisfn;      my $cache_str;
     if (defined($env{$cache_str})) {      if ($thisfn ne '') {
         if (($thisfn) || ($env{$cache_str} ne '')) {          $cache_str='request.symbread.cached.'.$thisfn;
           if ($env{$cache_str} ne '') {
             return $env{$cache_str};              return $env{$cache_str};
         }          }
     }      } else {
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {  
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
     return $env{$cache_str}=&symbclean($env{'request.symb'});      return $env{$cache_str}=&symbclean($env{'request.symb'});
  }   }
Line 11522  sub goodbye { Line 11678  sub goodbye {
 }  }
   
 sub get_dns {  sub get_dns {
     my ($url,$func,$ignore_cache) = @_;      my ($url,$func,$ignore_cache,$nocache,$hashref) = @_;
     if (!$ignore_cache) {      if (!$ignore_cache) {
  my ($content,$cached)=   my ($content,$cached)=
     &Apache::lonnet::is_cached_new('dns',$url);      &Apache::lonnet::is_cached_new('dns',$url);
  if ($cached) {   if ($cached) {
     &$func($content);      &$func($content,$hashref);
     return;      return;
  }   }
     }      }
Line 11552  sub get_dns { Line 11708  sub get_dns {
         delete($alldns{$dns});          delete($alldns{$dns});
  next if ($response->is_error());   next if ($response->is_error());
  my @content = split("\n",$response->content);   my @content = split("\n",$response->content);
  &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);   unless ($nocache) {
  &$func(\@content);      &do_cache_new('dns',$url,\@content,30*24*60*60);
    }
    &$func(\@content,$hashref);
  return;   return;
     }      }
     close($config);      close($config);
Line 11561  sub get_dns { Line 11719  sub get_dns {
     &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");      &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
     open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");      open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
     my @content = <$config>;      my @content = <$config>;
     &$func(\@content);      &$func(\@content,$hashref);
       return;
   }
   
   # ------------------------------------------------------Get DNS checksums file
   sub parse_dns_checksums_tab {
       my ($lines,$hashref) = @_;
       my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
       my $loncaparev = &get_server_loncaparev($machine_dom);
       my ($release,$timestamp) = split(/\-/,$loncaparev);
       my (%chksum,%revnum);
       if (ref($lines) eq 'ARRAY') {
           chomp(@{$lines});
           my $version = shift(@{$lines});
           if ($version eq $release) {  
               foreach my $line (@{$lines}) {
                   my ($file,$version,$shasum) = split(/,/,$line);
                   $chksum{$file} = $shasum;
                   $revnum{$file} = $version;
               }
               if (ref($hashref) eq 'HASH') {
                   %{$hashref} = (
                                   sums     => \%chksum,
                                   versions => \%revnum,
                                 );
               }
           }
       }
     return;      return;
 }  }
   
   sub fetch_dns_checksums {
       my %checksums;
       my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
       my $loncaparev = &get_server_loncaparev($machine_dom);
       my ($release,$timestamp) = split(/\-/,$loncaparev);
       &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
                \%checksums);
       return \%checksums;
   }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Line 11873  sub get_dns { Line 12069  sub get_dns {
     }      }
     push(@{$iphost{$ip}},@{$name_to_host{$name}});      push(@{$iphost{$ip}},@{$name_to_host{$name}});
  }   }
  &Apache::lonnet::do_cache_new('iphost','iphost',   &do_cache_new('iphost','iphost',
       [\%iphost,\%name_to_ip,\%lonid_to_ip],        [\%iphost,\%name_to_ip,\%lonid_to_ip],
       48*60*60);        48*60*60);
   
  return %iphost;   return %iphost;
     }      }
Line 11931  sub get_dns { Line 12127  sub get_dns {
             }              }
             $seen{$prim_ip} = 1;              $seen{$prim_ip} = 1;
         }          }
         return &Apache::lonnet::do_cache_new('internetnames',$lonid,\@idns,12*60*60);          return &do_cache_new('internetnames',$lonid,\@idns,12*60*60);
     }      }
   
 }  }
Line 11940  sub all_loncaparevs { Line 12136  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);
 }  }
   
   # ---------------------------------------------------------- Read loncaparev table
   {
       sub load_loncaparevs { 
           if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
               if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
                   while (my $configline=<$config>) {
                       chomp($configline);
                       my ($hostid,$loncaparev)=split(/:/,$configline);
                       $loncaparevs{$hostid}=$loncaparev;
                   }
                   close($config);
               }
           }
       }
   }
   
   # ---------------------------------------------------------- Read serverhostID table
   {
       sub load_serverhomeIDs {
           if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
               if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
                   while (my $configline=<$config>) {
                       chomp($configline);
                       my ($name,$id)=split(/:/,$configline);
                       $serverhomeIDs{$name}=$id;
                   }
                   close($config);
               }
           }
       }
   }
   
   
 BEGIN {  BEGIN {
   
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf  # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
Line 12016  BEGIN { Line 12245  BEGIN {
 }  }
   
 # ---------------------------------------------------------- Read loncaparev table  # ---------------------------------------------------------- Read loncaparev table
 {  
     if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {  &load_loncaparevs();
         if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {  
             while (my $configline=<$config>) {  
                 chomp($configline);  
                 my ($hostid,$loncaparev)=split(/:/,$configline);  
                 $loncaparevs{$hostid}=$loncaparev;  
             }  
             close($config);  
         }  
     }  
 }  
   
 # ---------------------------------------------------------- Read serverhostID table  # ---------------------------------------------------------- Read serverhostID table
 {  
     if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {  
         if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {  
             while (my $configline=<$config>) {  
                 chomp($configline);  
                 my ($name,$id)=split(/:/,$configline);  
                 $serverhomeIDs{$name}=$id;  
             }  
             close($config);  
         }  
     }  
 }  
   
   &load_serverhomeIDs();
   
   # ---------------------------------------------------------- Read releaseslist XML
 {  {
     my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml';      my $file = $Apache::lonnet::perlvar{'lonTabDir'}.'/releaseslist.xml';
     if (-e $file) {      if (-e $file) {
Line 12101  $readit=1; Line 12311  $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 12241  were new keys. I.E. 1:foo will become 1: Line 12462  were new keys. I.E. 1:foo will become 1:
   
 Calling convention:  Calling convention:
   
  my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname,$home);   my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);
  &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$home);   &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname);
   
 For more detailed information, see lonnet specific documentation.  For more detailed information, see lonnet specific documentation.
   
Line 12419  environment).  If no custom name is defi Line 12640  environment).  If no custom name is defi
         
 =item *  =item *
   
 get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :  get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv) :
 All arguments are optional. Returns a hash of a roles, either for  All arguments are optional. Returns a hash of a roles, either for
 co-author/assistant author roles for a user's Construction Space  co-author/assistant author roles for a user's Construction Space
 (default), or if $context is 'userroles', roles for the user himself,  (default), or if $context is 'userroles', roles for the user himself,
Line 12442  Additional optional arguments are: $type Line 12663  Additional optional arguments are: $type
 to certain user status types -- previous (expired roles), active (currently  to certain user status types -- previous (expired roles), active (currently
 available roles) or future (roles available in the future), and  available roles) or future (roles available in the future), and
 $hideprivileged -- if true will not report course roles for users who  $hideprivileged -- if true will not report course roles for users who
 have active Domain Coordinator or Super User roles.  have active Domain Coordinator role in course's domain or in additional
   domains (specified in 'Domains to check for privileged users' in course
   environment -- set via:  Course Settings -> Classlists and staff listing).
   
   =item *
   
   privileged($username,$domain,$possdomains,$possroles) : returns 1 if user
   $username:$domain is a privileged user (e.g., Domain Coordinator or Super User)
   $possdomains and $possroles are optional array refs -- to domains to check and
   roles to check.  If $possdomains is not specified, a dump will be done of the
   users' roles.db to check for a dc or su role in any domain. This can be
   time consuming if &privileged is called repeatedly (e.g., when displaying a
   classlist), so in such cases, supplying a $possdomains array is preferred, as
   this then allows &privileged_by_domain() to be used, which caches the identity
   of privileged users, eliminating the need for repeated calls to &dump().
   
   =item *
   
   privileged_by_domain($possdomains,$roles) : returns a hash of a hash of a hash,
   where the outer hash keys are domains specified in the $possdomains array ref,
   next inner hash keys are privileged roles specified in the $roles array ref,
   and the innermost hash contains key = value pairs for username:domain = end:start
   for active or future "privileged" users with that role in that domain. To avoid
   repeated dumps of domain roles -- via &get_domain_roles() -- contents of the
   innerhash are cached using priv_$role and $dom as the identifiers.
   
 =back  =back
   
Line 12485  or when Autoupdate.pl is run by cron in Line 12730  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 12536  Inputs: Line 12781  Inputs:
   
 =item B<$context> role change context (shown in User Management Logs display in a course)  =item B<$context> role change context (shown in User Management Logs display in a course)
   
 =item B<$inststatus> institutional status of user - : separated string of escaped status types    =item B<$inststatus> institutional status of user - : separated string of escaped status types
   
   =item B<$credits> Number of credits student will earn from this class - only needs to be supplied if value needs to be different from default credits for class.
   
 =back  =back
   
Line 12544  Inputs: Line 12791  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 12581  Inputs: Line 12828  Inputs:
   
 =item $context  =item $context
   
   =item $credits, number of credits student will earn from this class
   
 =back  =back
   
   
Line 12637  If defined, the supplied username is use Line 12886  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 12646  data base, returning a hash that is keye Line 12895  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 12705  resource. Expects the local filesystem p Line 12958  resource. Expects the local filesystem p
   
 =item *  =item *
   
 EXT($varname,$symb,$udom,$uname) : evaluates and returns the value of  EXT($varname,$symb,$udom,$uname,$usection,$recurse,$cid) : evaluates 
 a vairety of different possible values, $varname should be a request  and returns the value of a variety of different possible values,
 string, and the other parameters can be used to specify who and what  $varname should be a request string, and the other parameters can be
 one is asking about.  used to specify who and what one is asking about. Ordinarily, $cid 
   does not need to be specified, as it is retrived from 
   $env{'request.course.id'}, but &Apache::lonnet::EXT() is called
   within lonuserstate::loadmap() when initializing a course, before
   $env{'request.course.id'} has been set, so it needs to be provided
   in that one case.
   
 Possible values for $varname are environment.lastname (or other item  Possible values for $varname are environment.lastname (or other item
 from the envirnment hash), user.name (or someother aspect about the  from the envirnment hash), user.name (or someother aspect about the
Line 12986  server ($udom and $uhome are optional) Line 13244  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
   
   =back
   
   =item
   inststatus: types of institutional affiliation, and order in which they are displayed.
   
   =over
   
   =item
   inststatustypes, inststatusorder
   
   =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, officialquota, unofficialquota, communityquota
   
   =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
   
Removed from v.1.1200  
changed lines
  Added in v.1.1243

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