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

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1172.2.48 and 1.1243

version 1.1172.2.48, 2014/05/10 14:24:19 version 1.1243, 2013/10/14 17:14:48
Line 75  use LWP::UserAgent(); Line 75  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  
   use Encode;
   
   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 109  require Exporter; Line 112  require Exporter;
 our @ISA = qw (Exporter);  our @ISA = qw (Exporter);
 our @EXPORT = qw(%env);  our @EXPORT = qw(%env);
   
   
 # ------------------------------------ Logging (parameters, docs, slots, roles)  # ------------------------------------ Logging (parameters, docs, slots, roles)
 {  {
     my $logid;      my $logid;
Line 123  our @EXPORT = qw(%env); Line 127  our @EXPORT = qw(%env);
  $logid ++;   $logid ++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
         my $logentry = {          my $logentry = { 
                          $id => {                            $id => {
                                   'exe_uname' => $env{'user.name'},                                     'exe_uname' => $env{'user.name'},
                                   'exe_udom'  => $env{'user.domain'},                                     'exe_udom'  => $env{'user.domain'},
                                   'exe_time'  => $now,                                     'exe_time'  => $now,
                                   'exe_ip'    => $ENV{'REMOTE_ADDR'},                                     'exe_ip'    => $ENV{'REMOTE_ADDR'},
                                   'delflag'   => $delflag,                                     'delflag'   => $delflag,
                                   'logentry'  => $storehash,                                     'logentry'  => $storehash,
                                   'uname'     => $uname,                                     'uname'     => $uname,
                                   'udom'      => $udom,                                     'udom'      => $udom,
                                 }                                    }
                        };                         };
         return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);   return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
     }      }
 }  }
   
Line 356  sub remote_devalidate_cache { Line 360  sub remote_devalidate_cache {
     my $items;      my $items;
     return unless (ref($cachekeys) eq 'ARRAY');      return unless (ref($cachekeys) eq 'ARRAY');
     my $cachestr = join('&',@{$cachekeys});      my $cachestr = join('&',@{$cachekeys});
     return &reply('devalidatecache:'.&escape($cachestr),$lonhost);      my $response = &reply('devalidatecache:'.&escape($cachestr),$lonhost);
       return $response;
 }  }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
Line 601  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,$userhashref) = @_;      my ($r,$name) = @_;
     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 632  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 (ref($userhashref) eq 'HASH') {          if ($disk_env{'user.domain'} eq $r->dir_config('lonDefDomain')) {
         $userhashref->{'name'} = $disk_env{'user.name'};              $r->user($disk_env{'user.name'});
         $userhashref->{'domain'} = $disk_env{'user.domain'};          } else {
               $r->user($disk_env{'user.name'}.':'.$disk_env{'user.domain'});
           }
     }      }
   
     return $handle;      return $handle;
 }  }
   
Line 671  sub appenv { Line 677  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 =~ m{^user\.(role|priv)\.(.+?)\./});                      my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
                     if (grep(/^\Q$role\E$/,@{$roles})) {                      if (grep(/^\Q$role\E$/,@{$roles})) {
                         $refused = 0;                          $refused = 0;
                     }                      }
Line 885  sub spareserver { Line 891  sub spareserver {
 }  }
   
 sub compare_server_load {  sub compare_server_load {
     my ($try_server, $spare_server, $lowest_load, $required) = @_;      my ($try_server, $spare_server, $lowest_load) = @_;
   
     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 956  sub has_user_session { Line 952  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,$required,$skiploadbal) = @_;      my ($udom,$checkloginvia) = @_;
     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,$balancers);      my ($login_host,$hostname,$portal_path,$isredirect);
     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)) {
         my $loginvia;          my $loginvia;
         if ($skiploadbal) {  
             if (ref($balancers) eq 'HASH') {  
                 next if (exists($balancers->{$lonhost}));  
             }  
         }  
         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, $required);                      &compare_server_load($server, $login_host, $lowest_load);
                 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, $required);                      &compare_server_load($lonhost, $login_host, $lowest_load);
                 if ($login_host eq $lonhost) {                  if ($login_host eq $lonhost) {
                     $portal_path = '';                      $portal_path = '';
                     $isredirect = '';                       $isredirect = ''; 
Line 1000  sub choose_server { Line 979  sub choose_server {
             }              }
         } else {          } else {
             ($login_host, $lowest_load) =              ($login_host, $lowest_load) =
                 &compare_server_load($lonhost, $login_host, $lowest_load, $required);                  &compare_server_load($lonhost, $login_host, $lowest_load);
         }          }
     }      }
     if ($login_host ne '') {      if ($login_host ne '') {
Line 1297  sub check_loadbalancing { Line 1276  sub check_loadbalancing {
         }          }
     }      }
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         ($is_balancer,$currtargets,$currrules) =          ($is_balancer,$currtargets,$currrules) = 
             &check_balancer_result($result,@hosts);              &check_balancer_result($result,@hosts);
         if ($is_balancer) {          if ($is_balancer) {
             if (ref($currrules) eq 'HASH') {              if (ref($currrules) eq 'HASH') {
Line 1356  sub check_loadbalancing { Line 1335  sub check_loadbalancing {
             }              }
         }          }
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             ($is_balancer,$currtargets,$currrules) =              ($is_balancer,$currtargets,$currrules) = 
                 &check_balancer_result($result,@hosts);                  &check_balancer_result($result,@hosts);
             if ($is_balancer) {              if ($is_balancer) {
                 if (ref($currrules) eq 'HASH') {                  if (ref($currrules) eq 'HASH') {
Line 1412  sub check_loadbalancing { Line 1391  sub check_loadbalancing {
             $is_balancer = 0;              $is_balancer = 0;
             if ($uname ne '' && $udom ne '') {              if ($uname ne '' && $udom ne '') {
                 if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {                  if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
                       
                     &appenv({'user.loadbalexempt'     => $lonhost,                      &appenv({'user.loadbalexempt'     => $lonhost,  
                              'user.loadbalcheck.time' => time});                               'user.loadbalcheck.time' => time});
                 }                  }
             }              }
Line 1602  sub idput { Line 1581  sub idput {
     }      }
 }  }
   
 # ---------------------------------------- Delete unwanted IDs from ids.db file  # ---------------------------------------- Delete unwanted IDs from ids.db file 
   
 sub iddel {  sub iddel {
     my ($udom,$idshashref,$uhome)=@_;      my ($udom,$idshashref,$uhome)=@_;
Line 1757  sub retrieve_inst_usertypes { Line 1736  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')) {
         return ($domdefs{'inststatustypes'},$domdefs{'inststatusorder'});          %returnhash = %{$domdefs{'inststatustypes'}};
           @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("retrieve_inst_usertypes failed - $rep returned from $uhome in domain: $udom");                  &logthis("get_dom 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 1779  sub retrieve_inst_usertypes { Line 1759  sub retrieve_inst_usertypes {
                 push(@order,&unescape($item));                  push(@order,&unescape($item));
             }              }
         } else {          } else {
             &logthis("retrieve_inst_usertypes failed - no primary domain server for $udom");              &logthis("get_dom failed - no primary domain server for $udom");
         }          }
         return (\%returnhash,\@order);  
     }      }
       return (\%returnhash,\@order);
 }  }
   
 sub is_domainimage {  sub is_domainimage {
Line 2023  sub get_domain_defaults { Line 2003  sub get_domain_defaults {
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions',                                    'coursedefaults','usersessions',
                                   'requestauthor','selfenrollment',                                    'requestauthor'],$domain);
                                   '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 2055  sub get_domain_defaults { Line 2033  sub get_domain_defaults {
         }          }
     }      }
     if (ref($domconfig{'requestcourses'}) eq 'HASH') {      if (ref($domconfig{'requestcourses'}) eq 'HASH') {
         foreach my $item ('official','unofficial','community','textbook') {          foreach my $item ('official','unofficial','community') {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
Line 2063  sub get_domain_defaults { Line 2041  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','inststatusguest') {          foreach my $item ('inststatustypes','inststatusorder') {
             $domdefaults{$item} = $domconfig{'inststatus'}{$item};              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
         }          }
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         foreach my $type (@coursetypes) {          $domdefaults{'canuse_pdfforms'} = $domconfig{'coursedefaults'}{'canuse_pdfforms'};
             if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {          if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
                 unless ($type eq 'community') {              $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};
                     $domdefaults{$type.'credits'} = $domconfig{'coursedefaults'}{'coursecredits'}{$type};              $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};
                 }          }
             }          if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
             if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {              $domdefaults{'officialquota'} = $domconfig{'coursedefaults'}{'uploadquota'}{'official'};
                 $domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};              $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 2087  sub get_domain_defaults { Line 2065  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 2722  sub ssi { Line 2662  sub ssi {
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response= $ua->request($request);      my $response= $ua->request($request);
       my $content = $response->content;
   
   
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($content, $response);
     } else {      } else {
  return $response->content;   return $content;
     }      }
 }  }
   
Line 2757  sub allowuploaded { Line 2700  sub allowuploaded {
 #  #
 # Determine if the current user should be able to edit a particular resource,  # Determine if the current user should be able to edit a particular resource,
 # when viewing in course context.  # when viewing in course context.
 # (a) When viewing resource used to determine if "Edit" item is included in  # (a) When viewing resource used to determine if "Edit" item is included in 
 #     Functions.  #     Functions.
 # (b) When displaying folder contents in course editor, used to determine if  # (b) When displaying folder contents in course editor, used to determine if
 #     "Edit" link will be displayed alongside resource.  #     "Edit" link will be displayed alongside resource.
Line 2765  sub allowuploaded { Line 2708  sub allowuploaded {
 #  input: six args -- filename (decluttered), course number, course domain,  #  input: six args -- filename (decluttered), course number, course domain,
 #                   url, symb (if registered) and group (if this is a group  #                   url, symb (if registered) and group (if this is a group
 #                   item -- e.g., bulletin board, group page etc.).  #                   item -- e.g., bulletin board, group page etc.).
 #  output: array of five scalars --  #  output: array of five scalars -- 
 #          $cfile -- url for file editing if editable on current server  #          $cfile -- url for file editing if editable on current server
 #          $home -- homeserver of resource (i.e., for author if published,  #          $home -- homeserver of resource (i.e., for author if published,
 #                                           or course if uploaded.).  #                                           or course if uploaded.).
 #          $switchserver --  1 if server switch will be needed.  #          $switchserver --  1 if server switch will be needed.
 #          $forceedit -- 1 if icon/link should be to go to edit mode  #          $forceedit -- 1 if icon/link should be to go to edit mode 
 #          $forceview -- 1 if icon/link should be to go to view mode  #          $forceview -- 1 if icon/link should be to go to view mode
 #  #
   
Line 2859  sub can_edit_resource { Line 2802  sub can_edit_resource {
                     $forceedit = 1;                      $forceedit = 1;
                 }                  }
                 $cfile = $resurl;                  $cfile = $resurl;
             } elsif (($resurl ne '') && (&is_on_map($resurl))) {              } elsif (($resurl ne '') && (&is_on_map($resurl))) { 
                 if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {                  if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {
                     $incourse = 1;                      $incourse = 1;
                     if ($env{'form.forceedit'}) {                      if ($env{'form.forceedit'}) {
Line 2890  sub can_edit_resource { Line 2833  sub can_edit_resource {
                 }                  }
             } 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';
                 if (&is_on_map($template)) {                  if (&is_on_map($template)) { 
                     $incourse = 1;                      $incourse = 1;
                     $forceview = 1;                      $forceview = 1;
                     $cfile = $template;                      $cfile = $template;
Line 2937  sub can_edit_resource { Line 2880  sub can_edit_resource {
                 $cfile=$file;                  $cfile=$file;
             }              }
         }          }
         if (($cfile ne '') && (!$incourse || $uploaded) &&          if (($cfile ne '') && (!$incourse || $uploaded) && 
             (($home ne '') && ($home ne 'no_host'))) {              (($home ne '') && ($home ne 'no_host'))) {
             my @ids=&current_machine_ids();              my @ids=&current_machine_ids();
             unless (grep(/^\Q$home\E$/,@ids)) {              unless (grep(/^\Q$home\E$/,@ids)) {
Line 2964  sub in_course { Line 2907  sub in_course {
     if ($hideprivileged) {      if ($hideprivileged) {
         my $skipuser;          my $skipuser;
         my %coursehash = &coursedescription($cdom.'_'.$cnum);          my %coursehash = &coursedescription($cdom.'_'.$cnum);
         my @possdoms = ($cdom);          my @possdoms = ($cdom);  
         if ($coursehash{'checkforpriv'}) {          if ($coursehash{'checkforpriv'}) { 
             push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));              push(@possdoms,split(/,/,$coursehash{'checkforpriv'})); 
         }          }
         if (&privileged($uname,$udom,\@possdoms)) {          if (&privileged($uname,$udom,\@possdoms)) {
             $skipuser = 1;              $skipuser = 1;
Line 3470  sub extract_embedded_items { Line 3413  sub extract_embedded_items {
     }      }
     if (lc($tagname) eq 'a') {      if (lc($tagname) eq 'a') {
                 unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {                  unless (($attr->{'href'} =~ /^#/) || ($attr->{'href'} eq '')) {
     &add_filetype($allfiles,$attr->{'href'},'href');                      &add_filetype($allfiles,$attr->{'href'},'href');
                 }                  }
     }      }
             if (lc($tagname) eq 'script') {              if (lc($tagname) eq 'script') {
Line 4141  sub get_my_roles { Line 4084  sub get_my_roles {
             } else {              } else {
                 my $possdoms = [$domain];                  my $possdoms = [$domain];
                 if (ref($roledoms) eq 'ARRAY') {                  if (ref($roledoms) eq 'ARRAY') {
                    push(@{$possdoms},@{$roledoms});                     push(@{$possdoms},@{$roledoms}); 
                 }                  }
                 if (&privileged($username,$domain,$possdoms,\@privroles)) {                  if (&privileged($username,$domain,$possdoms,\@privroles)) {
                     if (!$nothide{$username.':'.$domain}) {                      if (!$nothide{$username.':'.$domain}) {
Line 4235  sub courseiddump { Line 4178  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 4249  sub courseiddump { Line 4191  sub courseiddump {
     if (($domfilter eq '') ||      if (($domfilter eq '') ||
  (&host_domain($tryserver) eq $domfilter)) {   (&host_domain($tryserver) eq $domfilter)) {
                 my $rep;                  my $rep;
                 if (grep { $_ eq $tryserver } &current_machine_ids()) {                  if (grep { $_ eq $tryserver } current_machine_ids()) {
                     $rep = &LONCAPA::Lond::dump_course_id_handler(                      $rep = LONCAPA::Lond::dump_course_id_handler(
                         join(":", (&host_domain($tryserver), $sincefilter,                          join(":", (&host_domain($tryserver), $sincefilter, 
                                 &escape($descfilter), &escape($instcodefilter),                                  &escape($descfilter), &escape($instcodefilter), 
                                 &escape($ownerfilter), &escape($coursefilter),                                  &escape($ownerfilter), &escape($coursefilter),
                                 &escape($typefilter), &escape($regexp_ok),                                  &escape($typefilter), &escape($regexp_ok), 
                                 $as_hash, &escape($selfenrollonly),                                  $as_hash, &escape($selfenrollonly), 
                                 &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, $hasuniquecode)));                                  &escape($creationcontext), $domcloner)));
                 } else {                  } else {
                     $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.                      $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
                              $sincefilter.':'.&escape($descfilter).':'.                               $sincefilter.':'.&escape($descfilter).':'.
Line 4270  sub courseiddump { Line 4212  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.':'.$hasuniquecode,                               &escape($creationcontext).':'.$domcloner,
                              $tryserver);                               $tryserver);
                 }                  }
                        
                 my @pairs=split(/\&/,$rep);                  my @pairs=split(/\&/,$rep);
                 foreach my $item (@pairs) {                  foreach my $item (@pairs) {
                     my ($key,$value)=split(/\=/,$item,2);                      my ($key,$value)=split(/\=/,$item,2);
Line 4472  sub set_first_access { Line 4414  sub set_first_access {
     return 'already_set';      return 'already_set';
 }  }
 }  }
   
 sub checkout {  
     my ($symb,$tuname,$tudom,$tcrsid)=@_;  
     my $now=time;  
     my $lonhost=$perlvar{'lonHostID'};  
     my $infostr=&escape(  
                  'CHECKOUTTOKEN&'.  
                  $tuname.'&'.  
                  $tudom.'&'.  
                  $tcrsid.'&'.  
                  $symb.'&'.  
                  $now.'&'.$ENV{'REMOTE_ADDR'});  
     my $token=&reply('tmpput:'.$infostr,$lonhost);  
     if ($token=~/^error\:/) {  
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
         return '';  
     }  
   
     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;  
     $token=~tr/a-z/A-Z/;  
   
     my %infohash=('resource.0.outtoken' => $token,  
                   'resource.0.checkouttime' => $now,  
                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});  
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {  
        return '';  
     } else {  
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
     }  
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),  
                          &escape('Checkout '.$infostr.' - '.  
                                                  $token)) ne 'ok') {  
         return '';  
     } else {  
         &logthis("<font color=\"blue\">WARNING: ".  
                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.  
                  "</font>");  
     }  
     return $token;  
 }  
   
 # ------------------------------------------------------------ Check in an item  
   
 sub checkin {  
     my $token=shift;  
     my $now=time;  
     my ($ta,$tb,$lonhost)=split(/\*/,$token);  
     $lonhost=~tr/A-Z/a-z/;  
     my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;  
     $dtoken=~s/\W/\_/g;  
     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=  
                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));  
   
     unless (($tuname) && ($tudom)) {  
         &logthis('Check in '.$token.' ('.$dtoken.') failed');  
         return '';  
     }  
   
     unless (&allowed('mgr',$tcrsid)) {  
         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.  
                  $env{'user.name'}.' - '.$env{'user.domain'});  
         return '';  
     }  
   
     my %infohash=('resource.0.intoken' => $token,  
                   'resource.0.checkintime' => $now,  
                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});  
   
     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {  
        return '';  
     }  
   
     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),  
                          &escape('Checkin - '.$token)) ne 'ok') {  
         return '';  
     }  
   
     return ($symb,$tuname,$tudom,$tcrsid);  
 }  
   
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 5151  sub privileged { Line 5007  sub privileged {
     my $now = time;      my $now = time;
     my $roles;      my $roles;
     if (ref($possroles) eq 'ARRAY') {      if (ref($possroles) eq 'ARRAY') {
         $roles = $possroles;          $roles = $possroles; 
     } else {      } else {
         $roles = ['dc','su'];          $roles = ['dc','su'];
     }      }
Line 5178  sub privileged { Line 5034  sub privileged {
         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 (grep(/^\Q$trole\E$/,@{$roles})) {              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);
             }              }
         }          }
Line 5216  sub privileged_by_domain { Line 5072  sub privileged_by_domain {
                         my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);                          my ($trole,$uname,$udom,$rest) = split(/:/,$item,4);
                         my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});                          my ($end,$start) = split(/:/,$dompersonnel{$server}{$item});
                         next if ($end && $end < $now);                          next if ($end && $end < $now);
                         $privileged{$dom}{$trole}{$uname.':'.$udom} =                          $privileged{$dom}{$trole}{$uname.':'.$udom} = 
                             $dompersonnel{$server}{$item};                              $dompersonnel{$server}{$item};
                     }                      }
                 }                  }
Line 5356  sub set_arearole { Line 5212  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 5477  sub set_userprivs { Line 5333  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 '') {
         my ($one,$two) = split(m{\./},$rolekey,2);          (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
         (undef,undef,$$role) = split(/\./,$one,3);  
         unless (!defined($$role) || $$role eq '') {          unless (!defined($$role) || $$role eq '') {
             $$where = '/'.$two;              $$where=join('.',@pwhere);
             $$trolecode=$$role.'.'.$$where;              $$trolecode=$$role.'.'.$$where;
             ($$tstart,$$tend)=split(/\./,$env{$rolekey});              ($$tstart,$$tend)=split(/\./,$env{$rolekey});
             $$tstatus='is';              $$tstatus='is';
Line 5687  sub unserialize { Line 5543  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} = &thaw_unescape($value);      $returnhash{$key} = Apache::lonnet::thaw_unescape($value);
     }   }
       #return %returnhash;
     return \%returnhash;      return \%returnhash;
 }  }        
   
 # see Lond::dump_with_regexp  # see Lond::dump_with_regexp
 # if $escapedkeys hash keys won't get unescaped.  # if $escapedkeys hash keys won't get unescaped.
Line 5705  sub dump { Line 5562  sub dump {
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
   
     my $reply;      my $reply;
     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)), $perlvar{'lonVersion'});                      $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
         return %{&unserialize($reply, $escapedkeys)};          return %{unserialize($reply, $escapedkeys)};
     }      }
     if ($regexp) {      if ($regexp) {
  $regexp=&escape($regexp);   $regexp=&escape($regexp);
Line 5722  sub dump { Line 5579  sub dump {
     if (!($rep =~ /^error/ )) {      if (!($rep =~ /^error/ )) {
  foreach my $item (@pairs) {   foreach my $item (@pairs) {
     my ($key,$value)=split(/=/,$item,2);      my ($key,$value)=split(/=/,$item,2);
             $key = &unescape($key) unless ($escapedkeys);          $key = unescape($key) unless $escapedkeys;
           #$key = &unescape($key);
     next if ($key =~ /^error: 2 /);      next if ($key =~ /^error: 2 /);
     $returnhash{$key}=&thaw_unescape($value);      $returnhash{$key}=&thaw_unescape($value);
  }   }
Line 5763  sub currentdump { Line 5621  sub currentdump {
    $sdom     = $env{'user.domain'}       if (! defined($sdom));     $sdom     = $env{'user.domain'}       if (! defined($sdom));
    $sname    = $env{'user.name'}         if (! defined($sname));     $sname    = $env{'user.name'}         if (! defined($sname));
    my $uhome = &homeserver($sname,$sdom);     my $uhome = &homeserver($sname,$sdom);
    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);     my $rep;
   
      if (grep { $_ eq $uhome } current_machine_ids()) {
          $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, 
                      $courseid)));
      } else {
          $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
      }
   
    return if ($rep =~ /^(error:|no_such_host)/);     return if ($rep =~ /^(error:|no_such_host)/);
    #     #
    my %returnhash=();     my %returnhash=();
Line 6006  sub tmpdel { Line 5872  sub tmpdel {
     return &reply("tmpdel:$token",$server);      return &reply("tmpdel:$token",$server);
 }  }
   
 # ------------------------------------------------------------ get_timebased_id  # ------------------------------------------------------------ get_timebased_id 
   
 sub get_timebased_id {  sub get_timebased_id {
     my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,      my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,
         $maxtries) = @_;          $maxtries) = @_;
     my ($newid,$error,$dellock);      my ($newid,$error,$dellock);
     unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {      unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {  
         return ('','ok','invalid call to get suffix');          return ('','ok','invalid call to get suffix');
     }      }
   
Line 6026  sub get_timebased_id { Line 5892  sub get_timebased_id {
     if (!$maxtries) {      if (!$maxtries) {
         $maxtries = 10;          $maxtries = 10;
     }      }
       
     if (($cdom eq '') || ($cnum eq '')) {      if (($cdom eq '') || ($cnum eq '')) {
         if ($env{'request.course.id'}) {          if ($env{'request.course.id'}) {
             $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};              $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
Line 6342  sub usertools_access { Line 6208  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 6377  sub usertools_access { Line 6242  sub usertools_access {
   
     my ($toolstatus,$inststatus,$envkey);      my ($toolstatus,$inststatus,$envkey);
     if ($context eq 'requestauthor') {      if ($context eq 'requestauthor') {
         $envkey = $context;          $envkey = $context; 
     } else {      } else {
         $envkey = $context.'.'.$tool;          $envkey = $context.'.'.$tool;
     }      }
Line 7455  sub metadata_query { Line 7320  sub metadata_query {
     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 = '';          my $domains = ''; 
         if (ref($domains_hash) eq 'HASH') {          if (ref($domains_hash) eq 'HASH') {
             $domains = $domains_hash->{$server};                  $domains = $domains_hash->{$server}; 
         }          }
  unless ($custom or $customshow) {   unless ($custom or $customshow) {
     my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);      my $reply=&reply("querysend:".&escape($query).':::'.&escape($domains),$server);
Line 7954  sub auto_courserequest_checks { Line 7819  sub auto_courserequest_checks {
 }  }
   
 sub auto_courserequest_validation {  sub auto_courserequest_validation {
     my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist,$custominfo) = @_;      my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = @_;
     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),
                                     $customdata,$homeserver));                                      $homeserver));
     }      }
     return $response;      return $response;
 }  }
Line 7986  sub auto_validate_class_sec { Line 7848  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 8282  sub assignrole { Line 8116  sub assignrole {
                         }                          }
                     }                      }
                 } elsif ($context eq 'requestauthor') {                  } elsif ($context eq 'requestauthor') {
                     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&                      if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) && 
                         ($url eq '/'.$udom.'/') && ($role eq 'au')) {                          ($url eq '/'.$udom.'/') && ($role eq 'au')) {
                         if ($env{'environment.requestauthor'} eq 'automatic') {                          if ($env{'environment.requestauthor'} eq 'automatic') {
                             $refused = '';                              $refused = '';
Line 8290  sub assignrole { Line 8124  sub assignrole {
                             my %domdefaults = &get_domain_defaults($udom);                              my %domdefaults = &get_domain_defaults($udom);
                             if (ref($domdefaults{'requestauthor'}) eq 'HASH') {                              if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
                                 my $checkbystatus;                                  my $checkbystatus;
                                 if ($env{'user.adv'}) {                                  if ($env{'user.adv'}) { 
                                     my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};                                      my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
                                     if ($disposition eq 'automatic') {                                      if ($disposition eq 'automatic') {
                                         $refused = '';                                          $refused = '';
                                     } elsif ($disposition eq '') {                                      } elsif ($disposition eq '') {
                                         $checkbystatus = 1;                                          $checkbystatus = 1;
                                     }                                      } 
                                 } else {                                  } else {
                                     $checkbystatus = 1;                                      $checkbystatus = 1;
                                 }                                  }
Line 8383  sub assignrole { Line 8217  sub assignrole {
                            $context);                             $context);
         } elsif (($role eq 'ca') || ($role eq 'aa')) {          } elsif (($role eq 'ca') || ($role eq 'aa')) {
             &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,              &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $context);                               $context); 
         }          }
         if ($role eq 'cc') {          if ($role eq 'cc') {
             &autoupdate_coowners($url,$end,$start,$uname,$udom);              &autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 8698  sub modifystudent { Line 8532  sub modifystudent {
     # student's 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,
                                         $cid,$selfenroll,$context,$credits);                                          $cid,$selfenroll,$context,$credits);
     return $reply;      return $reply;
 }  }
Line 9843  sub get_numsuppfiles { Line 9677  sub get_numsuppfiles {
         unless ($chome eq 'no_host') {          unless ($chome eq 'no_host') {
             ($suppcount,my $errors) = (0,0);              ($suppcount,my $errors) = (0,0);
             my $suppmap = 'supplemental.sequence';              my $suppmap = 'supplemental.sequence';
             ($suppcount,$errors) =              ($suppcount,$errors) = 
                 &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);                  &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);
         }          }
         &do_cache_new('suppcount',$hashid,$suppcount,600);          &do_cache_new('suppcount',$hashid,$suppcount,600);
Line 10038  sub EXT { Line 9872  sub EXT {
             $courseid = $cid;              $courseid = $cid;
         }          }
  if (($symbparm && $courseid) &&    if (($symbparm && $courseid) && 
     (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid))) {      (($courseid eq $env{'request.course.id'}) || ($courseid eq $cid)))  {
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
Line 10826  sub symbverify { Line 10660  sub symbverify {
             $ids=$bighash{'ids_'.&clutter($thisurl)};              $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) {
Line 10842  sub symbverify { Line 10676  sub symbverify {
                    if (ref($encstate)) {                     if (ref($encstate)) {
                        $$encstate = $bighash{'encrypted_'.$id};                         $$encstate = $bighash{'encrypted_'.$id};
                    }                     }
                    if (($env{'request.role.adv'}) ||     if (($env{'request.role.adv'}) ||
                        ($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;                         last;
                    }     }
                }         }
            }     }
         }          }
  untie(%bighash);   untie(%bighash);
     }      }
Line 10928  sub symbread { Line 10762  sub symbread {
         if ($env{$cache_str} ne '') {          if ($env{$cache_str} ne '') {
             return $env{$cache_str};              return $env{$cache_str};
         }          }
    } else {      } else {
 # no filename provided? try from environment  # no filename provided? try from environment
         if ($env{'request.symb'}) {          if ($env{'request.symb'}) {
             return $env{$cache_str}=&symbclean($env{'request.symb'});      return $env{$cache_str}=&symbclean($env{'request.symb'});
         }   }
         $thisfn=$env{'request.filename'};   $thisfn=$env{'request.filename'};
     }      }
     if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }      if ($thisfn=~m|^/enc/|) { $thisfn=&Apache::lonenc::unencrypted($thisfn); }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
Line 11161  sub rndseed { Line 10995  sub rndseed {
  $which =&get_rand_alg($courseid);   $which =&get_rand_alg($courseid);
     }      }
     if (defined(&getCODE())) {      if (defined(&getCODE())) {
   
  if ($which eq '64bit5') {   if ($which eq '64bit5') {
     return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);      return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
  } elsif ($which eq '64bit4') {   } elsif ($which eq '64bit4') {
Line 11873  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);
         unless ($nocache) {   unless ($nocache) {
     &do_cache_new('dns',$url,\@content,30*24*60*60);      &do_cache_new('dns',$url,\@content,30*24*60*60);
         }   }
  &$func(\@content,$hashref);   &$func(\@content,$hashref);
  return;   return;
     }      }
Line 11898  sub parse_dns_checksums_tab { Line 11733  sub parse_dns_checksums_tab {
     if (ref($lines) eq 'ARRAY') {      if (ref($lines) eq 'ARRAY') {
         chomp(@{$lines});          chomp(@{$lines});
         my $version = shift(@{$lines});          my $version = shift(@{$lines});
         if ($version eq $release) {          if ($version eq $release) {  
             foreach my $line (@{$lines}) {              foreach my $line (@{$lines}) {
                 my ($file,$version,$shasum) = split(/,/,$line);                  my ($file,$version,$shasum) = split(/,/,$line);
                 $chksum{$file} = $shasum;                  $chksum{$file} = $shasum;
Line 11918  sub parse_dns_checksums_tab { Line 11753  sub parse_dns_checksums_tab {
 sub fetch_dns_checksums {  sub fetch_dns_checksums {
     my %checksums;      my %checksums;
     my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});      my $machine_dom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
     my $loncaparev = &get_server_loncaparev($machine_dom,$perlvar{'lonHostID'});      my $loncaparev = &get_server_loncaparev($machine_dom);
     my ($release,$timestamp) = split(/\-/,$loncaparev);      my ($release,$timestamp) = split(/\-/,$loncaparev);
     &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,      &get_dns("/adm/dns/checksums/$release",\&parse_dns_checksums_tab,1,1,
              \%checksums);               \%checksums);
Line 12298  sub fetch_dns_checksums { Line 12133  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 2.11);      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  # ---------------------------------------------------------- Read loncaparev table
 {  {
     sub load_loncaparevs {      sub load_loncaparevs { 
         if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {          if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
             if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {              if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
                 while (my $configline=<$config>) {                  while (my $configline=<$config>) {
Line 12317  sub all_loncaparevs { Line 12152  sub all_loncaparevs {
     }      }
 }  }
   
 # ----------------------------------------------------- Read serverhostID table  # ---------------------------------------------------------- Read serverhostID table
 {  {
     sub load_serverhomeIDs {      sub load_serverhomeIDs {
         if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {          if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
Line 12409  BEGIN { Line 12244  BEGIN {
     close($config);      close($config);
 }  }
   
 # --------------------------------------------------------- Read loncaparev table  # ---------------------------------------------------------- Read loncaparev table
   
 &load_loncaparevs();  &load_loncaparevs();
   
 # ------------------------------------------------------- Read serverhostID table  # ---------------------------------------------------------- Read serverhostID table
   
 &load_serverhomeIDs();  &load_serverhomeIDs();
   
Line 12476  $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 12811  provided for types, will default to retu Line 12657  provided for types, will default to retu
 =item *  =item *
   
 in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if  in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if
 user: $uname:$udom has a role in the course: $cdom_$cnum.  user: $uname:$udom has a role in the course: $cdom_$cnum. 
   
 Additional optional arguments are: $type (if role checking is to be restricted  Additional optional arguments are: $type (if role checking is to be restricted 
 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
Line 13050  values that are the resource value.  I b Line 12896  values that are the resource value.  I b
 versions are also returned.  versions are also returned.
   
 get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's  get_numsuppfiles($cnum,$cdom) : retrieve number of files in a course's
 supplemental content area. This routine caches the number of files for  supplemental content area. This routine caches the number of files for 
 10 minutes.  10 minutes.
   
 =back  =back
Line 13163  and is a possible symb for the URL in $t Line 13009  and is a possible symb for the URL in $t
 resource that the user accessed using /enc/ returns a 1 on success, 0  resource that the user accessed using /enc/ returns a 1 on success, 0
 on failure, user must be in a course, as it assumes the existence of  on failure, user must be in a course, as it assumes the existence of
 the course initial hash, and uses $env('request.course.id'}.  The third  the course initial hash, and uses $env('request.course.id'}.  The third
 arg is an optional reference to a scalar.  If this arg is passed in the  arg is an optional reference to a scalar.  If this arg is passed in the 
 call to symbverify, it will be set to 1 if the symb has been set to be   call to symbverify, it will be set to 1 if the symb has been set to be 
 encrypted; otherwise it will be null.  encrypted; otherwise it will be null.  
   
 =item *  =item *
   
Line 13218  expirespread($uname,$udom,$stype,$usymb) Line 13064  expirespread($uname,$udom,$stype,$usymb)
 devalidate($symb) : devalidate temporary spreadsheet calculations,  devalidate($symb) : devalidate temporary spreadsheet calculations,
 forcing spreadsheet to reevaluate the resource scores next time.  forcing spreadsheet to reevaluate the resource scores next time.
   
 =item *  =item * 
   
 can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,  can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,
 when viewing in course context.  when viewing in course context.
   
  input: six args -- filename (decluttered), course number, course domain,   input: six args -- filename (decluttered), course number, course domain,
                     url, symb (if registered) and group (if this is a                      url, symb (if registered) and group (if this is a 
                     group item -- e.g., bulletin board, group page etc.).                      group item -- e.g., bulletin board, group page etc.).
   
  output: array of five scalars --   output: array of five scalars --
Line 13232  when viewing in course context. Line 13078  when viewing in course context.
          $home -- homeserver of resource (i.e., for author if published,           $home -- homeserver of resource (i.e., for author if published,
                                           or course if uploaded.).                                            or course if uploaded.).
          $switchserver --  1 if server switch will be needed.           $switchserver --  1 if server switch will be needed.
          $forceedit -- 1 if icon/link should be to go to edit mode           $forceedit -- 1 if icon/link should be to go to edit mode 
          $forceview -- 1 if icon/link should be to go to view mode           $forceview -- 1 if icon/link should be to go to view mode
   
 =item *  =item *
   
 is_course_upload($file,$cnum,$cdom)  is_course_upload($file,$cnum,$cdom)
   
 Used in course context to determine if current file was uploaded to  Used in course context to determine if current file was uploaded to 
 the course (i.e., would be found in /userfiles/docs on the course's  the course (i.e., would be found in /userfiles/docs on the course's 
 homeserver.  homeserver.
   
   input: 3 args -- filename (decluttered), course number and course domain.    input: 3 args -- filename (decluttered), course number and course domain.
Line 13398  server ($udom and $uhome are optional) Line 13244  server ($udom and $uhome are optional)
   
 =item *   =item * 
   
 get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults  get_domain_defaults($target_domain,$ignore_cache) : returns hash with defaults 
 for: authentication, language, quotas, timezone, date locale, and portal URL in  for: authentication, language, quotas, timezone, date locale, and portal URL in
 the target domain.  the target domain.
   
Line 13432  requestcourses: ability to request cours Line 13278  requestcourses: ability to request cours
 =over  =over
   
 =item  =item
 official, unofficial, community, textbook  official, unofficial, community
   
 =back  =back
   
Line 13442  inststatus: types of institutional affil Line 13288  inststatus: types of institutional affil
 =over  =over
   
 =item  =item
 inststatustypes, inststatusorder, inststatusguest  inststatustypes, inststatusorder
   
 =back  =back
   
Line 13453  for course's uploaded content. Line 13299  for course's uploaded content.
 =over  =over
   
 =item  =item
 canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, communityquota, textbookquota  canuse_pdfforms, officialcredits, unofficialcredits, officialquota, unofficialquota, communityquota
   
 =back  =back
   
Line 13463  on your servers. Line 13309  on your servers.
   
 =over  =over
   
 =item  =item 
 remotesessions, hostedsessions  remotesessions, hostedsessions
   
 =back  =back
Line 13471  remotesessions, hostedsessions Line 13317  remotesessions, hostedsessions
 =back  =back
   
 In cases where a domain coordinator has never used the "Set Domain Configuration"  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  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  only the following domain defaults: auth_def, auth_arg_def, lang_def
 -- corresponding values are authentication type (internal, krb4, krb5,  -- corresponding values are authentication type (internal, krb4, krb5,
 or localauth), initial password or a kerberos realm, language (e.g., en-us) --  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  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),  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.  or lastly from values in lonTabs/dns_domain,tab, or lonTabs/domain.tab.
Line 13901  Returns: Line 13747  Returns:
   
 get_timebased_id():  get_timebased_id():
   
 Attempts to get a unique timestamp-based suffix for use with items added to a  Attempts to get a unique timestamp-based suffix for use with items added to a 
 course via the Course Editor (e.g., folders, composite pages,  course via the Course Editor (e.g., folders, composite pages, 
 group bulletin boards).  group bulletin boards).
   
 Args: (first three required; six others optional)  Args: (first three required; six others optional)
Line 13913  Args: (first three required; six others Line 13759  Args: (first three required; six others
 2. keyid (alphanumeric): name of temporary locking key in hash,  2. keyid (alphanumeric): name of temporary locking key in hash,
    e.g., num, boardids     e.g., num, boardids
   
 3. namespace: name of gdbm file used to store suffixes already assigned;  3. namespace: name of gdbm file used to store suffixes already assigned;  
    file will be named nohist_namespace.db     file will be named nohist_namespace.db
   
 4. cdom: domain of course; default is current course domain from %env  4. cdom: domain of course; default is current course domain from %env
   
 5. cnum: course number; default is current course number from %env  5. cnum: course number; default is current course number from %env
   
 6. idtype: set to concat if an additional digit is to be appended to the  6. idtype: set to concat if an additional digit is to be appended to the 
    unix timestamp to form the suffix, if the plain timestamp is already     unix timestamp to form the suffix, if the plain timestamp is already
    in use.  Default is to not do this, but simply increment the unix     in use.  Default is to not do this, but simply increment the unix 
    timestamp by 1 until a unique key is obtained.     timestamp by 1 until a unique key is obtained.
   
 7. who: holder of locking key; defaults to user:domain for user.  7. who: holder of locking key; defaults to user:domain for user.
   
 8. locktries: number of attempts to obtain a lock (sleep of 1s before  8. locktries: number of attempts to obtain a lock (sleep of 1s before 
    retrying); default is 3.     retrying); default is 3.
   
 9. maxtries: number of attempts to obtain a unique suffix; default is 20.  9. maxtries: number of attempts to obtain a unique suffix; default is 20.  
   
 Returns:  Returns:
   
Removed from v.1.1172.2.48  
changed lines
  Added in v.1.1243

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