[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.1144 and 1.1172.2.32

version 1.1144, 2011/11/07 20:05:59 version 1.1172.2.32, 2013/08/13 12:48:47
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 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 96  use Math::Random; Line 96  use Math::Random;
 use File::MMagic;  use File::MMagic;
 use LONCAPA qw(:DEFAULT :match);  use LONCAPA qw(:DEFAULT :match);
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   use LONCAPA::lonmetadata;
   use LONCAPA::Lond;
   
 use File::Copy;  use File::Copy;
   
Line 107  require Exporter; Line 109  require Exporter;
 our @ISA = qw (Exporter);  our @ISA = qw (Exporter);
 our @EXPORT = qw(%env);  our @EXPORT = qw(%env);
   
   # ------------------------------------ Logging (parameters, docs, slots, roles)
 # --------------------------------------------------------------------- Logging  
 {  {
     my $logid;      my $logid;
     sub instructor_log {      sub write_log {
  my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;   my ($context,$hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
         if (($cnum eq '') || ($cdom eq '')) {          if ($context eq 'course') {
             $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};              if (($cnum eq '') || ($cdom eq '')) {
             $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};                  $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
                   $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               }
         }          }
  $logid++;   $logid ++;
         my $now = time();          my $now = time();
  my $id=$now.'00000'.$$.'00000'.$logid;   my $id=$now.'00000'.$$.'00000'.$logid;
  return &Apache::lonnet::put('nohist_'.$hash_name,          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,
     }                                  }
   },$cdom,$cnum);                         };
           return &put('nohist_'.$hash_name,$logentry,$cdom,$cnum);
     }      }
 }  }
   
Line 595  sub transfer_profile_to_env { Line 599  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) = @_;      my ($r,$name) = @_;
     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     my $lonid=$cookies{'lonID'};      if ($name eq '') {
           $name = 'lonID';
       }
       my $lonid=$cookies{$name};
     return undef if (!$lonid);      return undef if (!$lonid);
   
     my $handle=&LONCAPA::clean_handle($lonid->value);      my $handle=&LONCAPA::clean_handle($lonid->value);
     my $lonidsdir=$r->dir_config('lonIDsDir');      my $lonidsdir;
       if ($name eq 'lonDAV') {
           $lonidsdir=$r->dir_config('lonDAVsessDir');
       } else {
           $lonidsdir=$r->dir_config('lonIDsDir');
       }
     return undef if (!-e "$lonidsdir/$handle.id");      return undef if (!-e "$lonidsdir/$handle.id");
   
     my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
Line 618  sub check_for_valid_session { Line 630  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 930  sub choose_server { Line 951  sub choose_server {
     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);      my ($login_host,$hostname,$portal_path,$isredirect);
     foreach my $lonhost (keys(%servers)) {      foreach my $lonhost (keys(%servers)) {
         my $loginvia;          my $loginvia;
         if ($checkloginvia) {          if ($checkloginvia) {
Line 941  sub choose_server { Line 962  sub choose_server {
                     &compare_server_load($server, $login_host, $lowest_load);                      &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;
                 }                  }
             } else {              } else {
                 ($login_host, $lowest_load) =                  ($login_host, $lowest_load) =
                     &compare_server_load($lonhost, $login_host, $lowest_load);                      &compare_server_load($lonhost, $login_host, $lowest_load);
                 if ($login_host eq $lonhost) {                  if ($login_host eq $lonhost) {
                     $portal_path = '';                      $portal_path = '';
                       $isredirect = ''; 
                 }                  }
             }              }
         } else {          } else {
Line 957  sub choose_server { Line 980  sub choose_server {
     if ($login_host ne '') {      if ($login_host ne '') {
         $hostname = &hostname($login_host);          $hostname = &hostname($login_host);
     }      }
     return ($login_host,$hostname,$portal_path);      return ($login_host,$hostname,$portal_path,$isredirect);
 }  }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
Line 1222  sub get_lonbalancer_config { Line 1245  sub get_lonbalancer_config {
   
 sub check_loadbalancing {  sub check_loadbalancing {
     my ($uname,$udom) = @_;      my ($uname,$udom) = @_;
     my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect,      my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
         $offloadto,$otherserver);          $rule_in_effect,$offloadto,$otherserver);
     my $lonhost = $perlvar{'lonHostID'};      my $lonhost = $perlvar{'lonHostID'};
       my @hosts = &current_machine_ids();
     my $uprimary_id = &Apache::lonnet::domain($udom,'primary');      my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
     my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);      my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
     my $intdom = &Apache::lonnet::internet_dom($lonhost);      my $intdom = &Apache::lonnet::internet_dom($lonhost);
Line 1247  sub check_loadbalancing { Line 1271  sub check_loadbalancing {
         }          }
     }      }
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         my $currbalancer = $result->{'lonhost'};          ($is_balancer,$currtargets,$currrules) =
         my $currtargets = $result->{'targets'};              &check_balancer_result($result,@hosts);
         my $currrules = $result->{'rules'};  
         if ($currbalancer ne '') {  
             my @hosts = &current_machine_ids();  
             if (grep(/^\Q$currbalancer\E$/,@hosts)) {  
                 $is_balancer = 1;  
             }  
         }  
         if ($is_balancer) {          if ($is_balancer) {
             if (ref($currrules) eq 'HASH') {              if (ref($currrules) eq 'HASH') {
                 if ($homeintdom) {                  if ($homeintdom) {
Line 1313  sub check_loadbalancing { Line 1330  sub check_loadbalancing {
             }              }
         }          }
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             my $currbalancer = $result->{'lonhost'};              ($is_balancer,$currtargets,$currrules) =
             my $currtargets = $result->{'targets'};                  &check_balancer_result($result,@hosts);
             my $currrules = $result->{'rules'};              if ($is_balancer) {
   
             if ($currbalancer eq $lonhost) {  
                 $is_balancer = 1;  
                 if (ref($currrules) eq 'HASH') {                  if (ref($currrules) eq 'HASH') {
                     if ($currrules->{'_LC_internetdom'} ne '') {                      if ($currrules->{'_LC_internetdom'} ne '') {
                         $rule_in_effect = $currrules->{'_LC_internetdom'};                          $rule_in_effect = $currrules->{'_LC_internetdom'};
Line 1339  sub check_loadbalancing { Line 1353  sub check_loadbalancing {
             $offloadto = &this_host_spares($dom_in_use);              $offloadto = &this_host_spares($dom_in_use);
         }          }
     }      }
     my $lowest_load = 30000;      if ($is_balancer) {
     if (ref($offloadto) eq 'HASH') {          my $lowest_load = 30000;
         if (ref($offloadto->{'primary'}) eq 'ARRAY') {          if (ref($offloadto) eq 'HASH') {
             foreach my $try_server (@{$offloadto->{'primary'}}) {              if (ref($offloadto->{'primary'}) eq 'ARRAY') {
                 ($otherserver,$lowest_load) =                  foreach my $try_server (@{$offloadto->{'primary'}}) {
                     &compare_server_load($try_server,$otherserver,$lowest_load);                      ($otherserver,$lowest_load) =
                           &compare_server_load($try_server,$otherserver,$lowest_load);
                   }
             }              }
         }              my $found_server = ($otherserver ne '' && $lowest_load < 100);
         my $found_server = ($otherserver ne '' && $lowest_load < 100);  
   
         if (!$found_server) {              if (!$found_server) {
             if (ref($offloadto->{'default'}) eq 'ARRAY') {                  if (ref($offloadto->{'default'}) eq 'ARRAY') {
                 foreach my $try_server (@{$offloadto->{'default'}}) {                      foreach my $try_server (@{$offloadto->{'default'}}) {
                           ($otherserver,$lowest_load) =
                               &compare_server_load($try_server,$otherserver,$lowest_load);
                       }
                   }
               }
           } elsif (ref($offloadto) eq 'ARRAY') {
               if (@{$offloadto} == 1) {
                   $otherserver = $offloadto->[0];
               } elsif (@{$offloadto} > 1) {
                   foreach my $try_server (@{$offloadto}) {
                     ($otherserver,$lowest_load) =                      ($otherserver,$lowest_load) =
                         &compare_server_load($try_server,$otherserver,$lowest_load);                          &compare_server_load($try_server,$otherserver,$lowest_load);
                 }                  }
             }              }
         }          }
     } elsif (ref($offloadto) eq 'ARRAY') {          if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
         if (@{$offloadto} == 1) {              $is_balancer = 0;
             $otherserver = $offloadto->[0];              if ($uname ne '' && $udom ne '') {
         } elsif (@{$offloadto} > 1) {                  if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
             foreach my $try_server (@{$offloadto}) {  
                 ($otherserver,$lowest_load) =                      &appenv({'user.loadbalexempt'     => $lonhost,
                     &compare_server_load($try_server,$otherserver,$lowest_load);                               'user.loadbalcheck.time' => time});
                   }
             }              }
         }          }
     }      }
     return ($is_balancer,$otherserver);      return ($is_balancer,$otherserver);
 }  }
   
   sub check_balancer_result {
       my ($result,@hosts) = @_;
       my ($is_balancer,$currtargets,$currrules);
       if (ref($result) eq 'HASH') {
           if ($result->{'lonhost'} ne '') {
               my $currbalancer = $result->{'lonhost'};
               if (grep(/^\Q$currbalancer\E$/,@hosts)) {
                   $is_balancer = 1;
                   $currtargets = $result->{'targets'};
                   $currrules = $result->{'rules'};
               }
           } else {
               foreach my $key (keys(%{$result})) {
                   if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
                       (ref($result->{$key}) eq 'HASH')) {
                       $is_balancer = 1;
                       $currrules = $result->{$key}{'rules'};
                       $currtargets = $result->{$key}{'targets'};
                       last;
                   }
               }
           }
       }
       return ($is_balancer,$currtargets,$currrules);
   }
   
 sub get_loadbalancer_targets {  sub get_loadbalancer_targets {
     my ($rule_in_effect,$currtargets,$uname,$udom) = @_;      my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
     my $offloadto;      my $offloadto;
     if ($rule_in_effect eq '') {      if ($rule_in_effect eq 'none') {
           return [$perlvar{'lonHostID'}];
       } elsif ($rule_in_effect eq '') {
         $offloadto = $currtargets;          $offloadto = $currtargets;
     } else {      } else {
         if ($rule_in_effect eq 'homeserver') {          if ($rule_in_effect eq 'homeserver') {
Line 1391  sub get_loadbalancer_targets { Line 1445  sub get_loadbalancer_targets {
                     }                      }
                 }                  }
             } else {              } else {
                 my %servers = &dom_servers($udom);                  my %servers = &internet_dom_servers($udom);
                 my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);                  my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
                 if (&hostname($remotebalancer) ne '') {                  if (&hostname($remotebalancer) ne '') {
                     $offloadto = [$remotebalancer];                      $offloadto = [$remotebalancer];
Line 1522  sub idput { Line 1576  sub idput {
     }      }
 }  }
   
 # ------------------------------dump from db file owned by domainconfig user  # ---------------------------------------- Delete unwanted IDs from ids.db file
 sub dump_dom {  
     my ($namespace,$udom,$regexp,$range)=@_;  sub iddel {
     if (!$udom) {      my ($udom,$idshashref,$uhome)=@_;
         $udom=$env{'user.domain'};      my %result=();
       unless (ref($idshashref) eq 'HASH') {
           return %result;
     }      }
     my %returnhash;      my %servers=();
     if ($udom) {      while (my ($id,$uname) = each(%{$idshashref})) {
         my $uname = &get_domainconfiguser($udom);          my $uhom;
         %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);          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);
               }
           }
     }      }
     return %returnhash;      foreach my $server (keys(%servers)) {
           $result{$server} = &critical('iddel:'.$udom.':'.$servers{$server},$uhome);
       }
       return %result;
   }
   
   # ------------------------------dump from db file owned by domainconfig user
   sub dump_dom {
       my ($namespace, $udom, $regexp) = @_;
   
       $udom ||= $env{'user.domain'};
   
       return () unless $udom;
   
       return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp);
 }  }
   
 # ------------------------------------------ get items from domain db files     # ------------------------------------------ get items from domain db files   
Line 1913  sub get_domain_defaults { Line 1994  sub get_domain_defaults {
     my %domconfig =      my %domconfig =
          &Apache::lonnet::get_dom('configuration',['defaults','quotas',           &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                   'requestcourses','inststatus',                                    'requestcourses','inststatus',
                                   'coursedefaults','usersessions'],$domain);                                    'coursedefaults','usersessions',
                                     'requestauthor'],$domain);
     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'};
         $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};          $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
         $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};          $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
         $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};          $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
           $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'};
     } else {      } else {
         $domdefaults{'lang_def'} = &domain($domain,'lang_def');          $domdefaults{'lang_def'} = &domain($domain,'lang_def');
         $domdefaults{'auth_def'} = &domain($domain,'auth_def');          $domdefaults{'auth_def'} = &domain($domain,'auth_def');
Line 1930  sub get_domain_defaults { Line 2013  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','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') {
             $domdefaults{$item} = $domconfig{'requestcourses'}{$item};              $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
         }          }
     }      }
       if (ref($domconfig{'requestauthor'}) eq 'HASH') {
           $domdefaults{'requestauthor'} = $domconfig{'requestauthor'};
       }
     if (ref($domconfig{'inststatus'}) eq 'HASH') {      if (ref($domconfig{'inststatus'}) eq 'HASH') {
         foreach my $item ('inststatustypes','inststatusorder') {          foreach my $item ('inststatustypes','inststatusorder') {
             $domdefaults{$item} = $domconfig{'inststatus'}{$item};              $domdefaults{$item} = $domconfig{'inststatus'}{$item};
         }          }
     }      }
     if (ref($domconfig{'coursedefaults'}) eq 'HASH') {      if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
         foreach my $item ('canuse_pdfforms') {          if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
             $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};              $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 1961  sub get_domain_defaults { Line 2056  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 2146  sub getsection { Line 2240  sub getsection {
     # If there is a role which has expired, return it.      # If there is a role which has expired, return it.
     #      #
     $courseid = &courseid_to_courseurl($courseid);      $courseid = &courseid_to_courseurl($courseid);
     my $extra = &freeze_escape({'skipcheck' => 1});      my %roleshash = &dump('roles',$udom,$unam,$courseid);
     my %roleshash = &dump('roles',$udom,$unam,$courseid,undef,$extra);  
     foreach my $key (keys(%roleshash)) {      foreach my $key (keys(%roleshash)) {
         next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);          next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
         my $section=$1;          my $section=$1;
Line 2373  sub chatsend { Line 2466  sub chatsend {
   
 sub getversion {  sub getversion {
     my $fname=&clutter(shift);      my $fname=&clutter(shift);
     unless ($fname=~/^\/res\//) { return -1; }      unless ($fname=~m{^(/adm/wrapper|)/res/}) { return -1; }
     return &currentversion(&filelocation('',$fname));      return &currentversion(&filelocation('',$fname));
 }  }
   
Line 2431  sub repcopy { Line 2524  sub repcopy {
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     my $londocroot = $perlvar{'lonDocRoot'};      my $londocroot = $perlvar{'lonDocRoot'};
     if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }      if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
     if ($filename=~m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; }      if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
     if ($filename=~m{^\Q$londocroot/userfiles/\E} or      if ($filename=~m{^\Q$londocroot/userfiles/\E} or
  $filename=~m{^/*(uploaded|editupload)/}) {   $filename=~m{^/*(uploaded|editupload)/}) {
  return &repcopy_userfile($filename);   return &repcopy_userfile($filename);
Line 2559  sub ssi { Line 2652  sub ssi {
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response=$ua->request($request);      my $response= $ua->request($request);
   
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($response->content, $response);
     } else {      } else {
Line 2593  sub allowuploaded { Line 2685  sub allowuploaded {
     &Apache::lonnet::appenv(\%httpref);      &Apache::lonnet::appenv(\%httpref);
 }  }
   
   #
   # Determine if the current user should be able to edit a particular resource,
   # when viewing in course context.
   # (a) When viewing resource used to determine if "Edit" item is included in
   #     Functions.
   # (b) When displaying folder contents in course editor, used to determine if
   #     "Edit" link will be displayed alongside resource.
   #
   #  input: six args -- filename (decluttered), course number, course domain,
   #                   url, symb (if registered) and group (if this is a group
   #                   item -- e.g., bulletin board, group page etc.).
   #  output: array of five scalars --
   #          $cfile -- url for file editing if editable on current server
   #          $home -- homeserver of resource (i.e., for author if published,
   #                                           or course if uploaded.).
   #          $switchserver --  1 if server switch will be needed.
   #          $forceedit -- 1 if icon/link should be to go to edit mode
   #          $forceview -- 1 if icon/link should be to go to view mode
   #
   
   sub can_edit_resource {
       my ($file,$cnum,$cdom,$resurl,$symb,$group) = @_;
       my ($cfile,$home,$switchserver,$forceedit,$forceview,$uploaded,$incourse);
   #
   # For aboutme pages user can only edit his/her own.
   #
       if ($resurl =~ m{^/?adm/($match_domain)/($match_username)/aboutme$}) {
           my ($sdom,$sname) = ($1,$2);
           if (($sdom eq $env{'user.domain'}) && ($sname eq $env{'user.name'})) {
               $home = $env{'user.home'};
               $cfile = $resurl;
               if ($env{'form.forceedit'}) {
                   $forceview = 1;
               } else {
                   $forceedit = 1;
               }
               return ($cfile,$home,$switchserver,$forceedit,$forceview);
           } else {
               return;
           }
       }
   
       if ($env{'request.course.id'}) {
           my $crsedit = &Apache::lonnet::allowed('mdc',$env{'request.course.id'});
           if ($group ne '') {
   # if this is a group homepage or group bulletin board, check group privs
               my $allowed = 0;
               if ($resurl =~ m{^/?adm/$cdom/$cnum/$group/smppg$}) {
                   if ((&allowed('mdg',$env{'request.course.id'}.
                                 ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||
                           (&allowed('mgh',$env{'request.course.id'}.'/'.$group)) || $crsedit) {
                       $allowed = 1;
                   }
               } elsif ($resurl =~ m{^/?adm/$cdom/$cnum/\d+/bulletinboard$}) {
                   if ((&allowed('mdg',$env{'request.course.id'}.($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:''))) ||
                           (&allowed('cgb',$env{'request.course.id'}.'/'.$group)) || $crsedit) {
                       $allowed = 1;
                   }
               }
               if ($allowed) {
                   $home=&homeserver($cnum,$cdom);
                   if ($env{'form.forceedit'}) {
                       $forceview = 1;
                   } else {
                       $forceedit = 1;
                   }
                   $cfile = $resurl;
               } else {
                   return;
               }
           } 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.
   #
                   return;
               }
           }
       }
   
       if ($file ne '') {
           if (($cnum =~ /$match_courseid/) && ($cdom =~ /$match_domain/)) {
               if (&is_course_upload($file,$cnum,$cdom)) {
                   $uploaded = 1;
                   $incourse = 1;
                   if ($file =~/\.(htm|html|css|js|txt)$/) {
                       $cfile = &hreflocation('',$file);
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                   }
               } elsif ($resurl =~ m{^/public/$cdom/$cnum/syllabus}) {
                   $incourse = 1;
                   if ($env{'form.forceedit'}) {
                       $forceview = 1;
                   } else {
                       $forceedit = 1;
                   }
                   $cfile = $resurl;
               } elsif (($resurl ne '') && (&is_on_map($resurl))) {
                   if ($resurl =~ m{^/adm/$match_domain/$match_username/\d+/smppg|bulletinboard$}) {
                       $incourse = 1;
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                       $cfile = $resurl;
                   } elsif ($resurl eq '/res/lib/templates/simpleproblem.problem') {
                       $incourse = 1;
                       $cfile = $resurl.'/smpedit';
                   } elsif ($resurl =~ m{^/adm/wrapper/ext/}) {
                       $incourse = 1;
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                       $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') {
                   my $template = '/res/lib/templates/simpleproblem.problem';
                   if (&is_on_map($template)) {
                       $incourse = 1;
                       $forceview = 1;
                       $cfile = $template;
                   }
               } elsif (($resurl =~ m{^/adm/wrapper/ext/}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
                       $incourse = 1;
                       if ($env{'form.forceedit'}) {
                           $forceview = 1;
                       } else {
                           $forceedit = 1;
                       }
                       $cfile = $resurl;
               } elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
                   $incourse = 1;
                   $forceview = 1;
                   if ($symb) {
                       my ($map,$id,$res)=&decode_symb($symb);
                       $env{'request.symb'} = $symb;
                       $cfile = &clutter($res);
                   } else {
                       $cfile = $env{'form.suppurl'};
                       $cfile =~ s{^http://}{};
                       $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) {
               $home=&homeserver($cnum,$cdom);
           } elsif ($file !~ m{/$}) {
               $file=~s{^(priv/$match_domain/$match_username)}{/$1};
               $file=~s{^($match_domain/$match_username)}{/priv/$1};
               # Check that the user has permission to edit this resource
               my $setpriv = 1;
               my ($cfuname,$cfudom)=&constructaccess($file,$setpriv);
               if (defined($cfudom)) {
                   $home=&homeserver($cfuname,$cfudom);
                   $cfile=$file;
               }
           }
           if (($cfile ne '') && (!$incourse || $uploaded) &&
               (($home ne '') && ($home ne 'no_host'))) {
               my @ids=&current_machine_ids();
               unless (grep(/^\Q$home\E$/,@ids)) {
                   $switchserver=1;
               }
           }
       }
       return ($cfile,$home,$switchserver,$forceedit,$forceview);
   }
   
   sub is_course_upload {
       my ($file,$cnum,$cdom) = @_;
       my $uploadpath = &LONCAPA::propath($cdom,$cnum);
       $uploadpath =~ s{^\/}{};
       if (($file =~ m{^\Q$uploadpath\E/userfiles/(docs|supplemental)/}) ||
           ($file =~ m{^userfiles/\Q$cdom\E/\Q$cnum\E/(docs|supplemental)/})) {
           return 1;
       }
       return;
   }
   
   sub in_course {
       my ($udom,$uname,$cdom,$cnum,$type,$hideprivileged) = @_;
       if ($hideprivileged) {
           my $skipuser;
           my %coursehash = &coursedescription($cdom.'_'.$cnum);
           my @possdoms = ($cdom);
           if ($coursehash{'checkforpriv'}) {
               push(@possdoms,split(/,/,$coursehash{'checkforpriv'}));
           }
           if (&privileged($uname,$udom,\@possdoms)) {
               $skipuser = 1;
               if ($coursehash{'nothideprivileged'}) {
                   foreach my $item (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
                       my $user;
                       if ($item =~ /:/) {
                           $user = $item;
                       } else {
                           $user = join(':',split(/[\@]/,$item));
                       }
                       if ($user eq $uname.':'.$udom) {
                           undef($skipuser);
                           last;
                       }
                   }
               }
               if ($skipuser) {
                   return 0;
               }
           }
       }
       $type ||= 'any';
       if (!defined($cdom) || !defined($cnum)) {
           my $cid  = $env{'request.course.id'};
           $cdom = $env{'course.'.$cid.'.domain'};
           $cnum = $env{'course.'.$cid.'.num'};
       }
       my $typesref;
       if (($type eq 'any') || ($type eq 'all')) {
           $typesref = ['active','previous','future'];
       } elsif ($type eq 'previous' || $type eq 'future') {
           $typesref = [$type];
       }
       my %roles = &get_my_roles($uname,$udom,'userroles',
                                 $typesref,undef,[$cdom]);
       my ($tmp) = keys(%roles);
       return 0 if ($tmp =~ /^(con_lost|error|no_such_host)/i);
       my @course_roles = grep(/^\Q$cnum\E:\Q$cdom\E:/, keys(%roles));
       if (@course_roles > 0) {
           return 1;
       }
       return 0;
   }
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 # input: action, courseID, current domain, intended  # input: action, courseID, current domain, intended
 #        path to file, source of file, instruction to parse file for objects,  #        path to file, source of file, instruction to parse file for objects,
Line 2798  sub resizeImage { Line 3148  sub resizeImage {
 #        $resizewidth - width (pixels) to which to resize uploaded image  #        $resizewidth - width (pixels) to which to resize uploaded image
 #        $resizeheight - height (pixels) to which to resize uploaded image  #        $resizeheight - height (pixels) to which to resize uploaded image
 #        $mimetype - reference to scalar to accommodate mime type determined  #        $mimetype - reference to scalar to accommodate mime type determined
 #                    from File::MMagic if $parser = parse.  #                    from File::MMagic.
 #   # 
 # output: url of file in userspace, or error: <message>   # output: url of file in userspace, or error: <message> 
 #             or /adm/notfound.html if failure to upload occurse  #             or /adm/notfound.html if failure to upload occurse
Line 2883  sub userfileupload { Line 3233  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 2898  sub userfileupload { Line 3250  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 2967  sub finishuserfileupload { Line 3319  sub finishuserfileupload {
             }                }  
  }   }
     }      }
       if (($context eq 'coursedoc') || ($parser eq 'parse')) {
           if (ref($mimetype)) {
               if ($$mimetype eq '') {
                   my $mm = new File::MMagic;
                   my $type = $mm->checktype_filename($filepath.'/'.$file);
                   $$mimetype = $type;
               }
           }
       }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
         my $mm = new File::MMagic;          if ((ref($mimetype)) && ($$mimetype eq 'text/html')) {
         my $type = $mm->checktype_filename($filepath.'/'.$file);  
         if ($type eq 'text/html') {  
             my $parse_result = &extract_embedded_items($filepath.'/'.$file,              my $parse_result = &extract_embedded_items($filepath.'/'.$file,
                                                        $allfiles,$codebase);                                                         $allfiles,$codebase);
             unless ($parse_result eq 'ok') {              unless ($parse_result eq 'ok') {
Line 2978  sub finishuserfileupload { Line 3337  sub finishuserfileupload {
            ' for embedded media: '.$parse_result);              ' for embedded media: '.$parse_result); 
             }              }
         }          }
         if (ref($mimetype)) {  
             $$mimetype = $type;  
         }  
     }      }
     if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {      if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
         my $input = $filepath.'/'.$file;          my $input = $filepath.'/'.$file;
Line 3017  sub finishuserfileupload { Line 3373  sub finishuserfileupload {
 sub extract_embedded_items {  sub extract_embedded_items {
     my ($fullpath,$allfiles,$codebase,$content) = @_;      my ($fullpath,$allfiles,$codebase,$content) = @_;
     my @state = ();      my @state = ();
       my (%lastids,%related,%shockwave,%flashvars);
     my %javafiles = (      my %javafiles = (
                       codebase => '',                        codebase => '',
                       code => '',                        code => '',
Line 3043  sub extract_embedded_items { Line 3400  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;
                 if ($attr->{'archive'} =~ /\.jar$/i) {                  if ($attr->{'archive'} =~ /\.jar$/i) {
                     &add_filetype($allfiles,$attr->{'archive'},'archive');                      &add_filetype($allfiles,$attr->{'archive'},'archive');
                 } else {                  } else {
                     &add_filetype($allfiles,$attr->{'src'},'src');                      if ($attr->{'src'} ne '') {
                           $src = $attr->{'src'};
                           &add_filetype($allfiles,$src,'src');
                       }
                   }
                   my $text = $p->get_trimmed_text();
                   if ($text =~ /\Qswfobject.registerObject(\E([^\)]+)\)/) {
                       my @swfargs = split(/,/,$1);
                       foreach my $item (@swfargs) {
                           $item =~ s/["']//g;
                           $item =~ s/^\s+//;
                           $item =~ s/\s+$//;
                       }
                       if (($swfargs[0] ne'') && ($swfargs[2] ne '')) {
                           if (ref($related{$swfargs[0]}) eq 'ARRAY') {
                               push(@{$related{$swfargs[0]}},$swfargs[2]);
                           } else {
                               $related{$swfargs[0]} = [$swfargs[2]];
                           }
                       }
                 }                  }
             }              }
             if (lc($tagname) eq 'link') {              if (lc($tagname) eq 'link') {
Line 3062  sub extract_embedded_items { Line 3441  sub extract_embedded_items {
  foreach my $item (keys(%javafiles)) {   foreach my $item (keys(%javafiles)) {
     $javafiles{$item} = '';      $javafiles{$item} = '';
  }   }
                   if ((lc($tagname) eq 'object') && (lc($state[-2]) ne 'object')) {
                       $lastids{lc($tagname)} = $attr->{'id'};
                   }
     }      }
     if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {      if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
  my $name = lc($attr->{'name'});   my $name = lc($attr->{'name'});
Line 3071  sub extract_embedded_items { Line 3453  sub extract_embedded_items {
  last;   last;
     }      }
  }   }
                   my $pathfrom;
  foreach my $item (keys(%mediafiles)) {   foreach my $item (keys(%mediafiles)) {
     if ($name eq $item) {      if ($name eq $item) {
  &add_filetype($allfiles, $attr->{'value'}, 'value');                          $pathfrom = $attr->{'value'};
                           $shockwave{$lastids{lc($state[-2])}} = $pathfrom;
    &add_filetype($allfiles,$pathfrom,$name);
  last;   last;
     }      }
  }   }
                   if ($name eq 'flashvars') {
                       $flashvars{$lastids{lc($state[-2])}} = $attr->{'value'};
                   }
                   if ($pathfrom ne '') {
                       &embedded_dependency($allfiles,\%related,$lastids{lc($state[-2])},
                                            $pathfrom);
                   }
     }      }
     if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {      if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
  foreach my $item (keys(%javafiles)) {   foreach my $item (keys(%javafiles)) {
Line 3091  sub extract_embedded_items { Line 3483  sub extract_embedded_items {
  last;   last;
     }      }
  }   }
                   if (lc($tagname) eq 'embed') {
                       if (($attr->{'name'} ne '') && ($attr->{'src'} ne '')) {
                           &embedded_dependency($allfiles,\%related,$attr->{'name'},
                                                $attr->{'src'});
                       }
                   }
     }      }
               if ($t->[4] =~ m{/>$}) {
                   pop(@state);  
               }
  } elsif ($t->[0] eq 'E') {   } elsif ($t->[0] eq 'E') {
     my ($tagname) = ($t->[1]);      my ($tagname) = ($t->[1]);
     if ($javafiles{'codebase'} ne '') {      if ($javafiles{'codebase'} ne '') {
Line 3111  sub extract_embedded_items { Line 3512  sub extract_embedded_items {
     pop @state;      pop @state;
  }   }
     }      }
       foreach my $id (sort(keys(%flashvars))) {
           if ($shockwave{$id} ne '') {
               my @pairs = split(/\&/,$flashvars{$id});
               foreach my $pair (@pairs) {
                   my ($key,$value) = split(/\=/,$pair);
                   if ($key eq 'thumb') {
                       &add_filetype($allfiles,$value,$key);
                   } elsif ($key eq 'content') {
                       my ($path) = ($shockwave{$id} =~ m{^(.+/)[^/]+$});
                       my ($ext) = ($value =~ /\.([^.]+)$/);
                       if ($ext ne '') {
                           &add_filetype($allfiles,$path.$value,$ext);
                       }
                   }
               }
           }
       }
     return 'ok';      return 'ok';
 }  }
   
Line 3125  sub add_filetype { Line 3543  sub add_filetype {
     }      }
 }  }
   
   sub embedded_dependency {
       my ($allfiles,$related,$identifier,$pathfrom) = @_;
       if ((ref($allfiles) eq 'HASH') && (ref($related) eq 'HASH')) {
           if (($identifier ne '') &&
               (ref($related->{$identifier}) eq 'ARRAY') &&
               ($pathfrom ne '')) {
               my ($path) = ($pathfrom =~ m{^(.+/)[^/]+$});
               foreach my $dep (@{$related->{$identifier}}) {
                   &add_filetype($allfiles,$path.$dep,'object');
               }
           }
       }
       return;
   }
   
 sub removeuploadedurl {  sub removeuploadedurl {
     my ($url)=@_;      my ($url)=@_;
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);          my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);    
Line 3251  sub flushcourselogs { Line 3684  sub flushcourselogs {
             my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);              my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
             if ($result eq 'ok') {              if ($result eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
             } elsif ($result eq 'unknown_cmd') {  
                 # Target server has old code running on it.  
                 my %temphash=($entry => $value);  
                 if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {  
                     delete $accesshash{$entry};  
                 }  
             }              }
         } else {          } else {
             my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});              my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
               if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; }
             my %temphash=($entry => $accesshash{$entry});              my %temphash=($entry => $accesshash{$entry});
             if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {              if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                 delete $accesshash{$entry};                  delete $accesshash{$entry};
Line 3370  sub countacc { Line 3798  sub countacc {
     my $url=&declutter(shift);      my $url=&declutter(shift);
     return if (! defined($url) || $url eq '');      return if (! defined($url) || $url eq '');
     unless ($env{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
   #
   # Mark that this url was used in this course
   #
     $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;      $accesshash{$env{'request.course.id'}.'___'.$url.'___course'}=1;
   #
   # Increase the access count for this resource in this child process
   #
     my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';      my $key=$$.$processmarker.'_'.$dumpcount.'___'.$url.'___count';
     $accesshash{$key}++;      $accesshash{$key}++;
 }  }
Line 3382  sub linklog { Line 3816  sub linklog {
     $accesshash{$from.'___'.$to.'___comefrom'}=1;      $accesshash{$from.'___'.$to.'___comefrom'}=1;
     $accesshash{$to.'___'.$from.'___goto'}=1;      $accesshash{$to.'___'.$from.'___goto'}=1;
 }  }
   
   sub statslog {
       my ($symb,$part,$users,$av_attempts,$degdiff)=@_;
       if ($users<2) { return; }
       my %dynstore=&LONCAPA::lonmetadata::dynamic_metadata_storage({
               'course'       => $env{'request.course.id'},
               'sections'     => '"all"',
               'num_students' => $users,
               'part'         => $part,
               'symb'         => $symb,
               'mean_tries'   => $av_attempts,
               'deg_of_diff'  => $degdiff});
       foreach my $key (keys(%dynstore)) {
           $accesshash{$key}=$dynstore{$key};
       }
   }
       
 sub userrolelog {  sub userrolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend)=@_;
     if (($trole=~/^ca/) || ($trole=~/^aa/) ||      if ( $trole =~ /^(ca|aa|in|cc|ep|cr|ta|co)/ ) {
         ($trole=~/^in/) || ($trole=~/^cc/) ||  
         ($trole=~/^ep/) || ($trole=~/^cr/) ||  
         ($trole=~/^ta/) || ($trole=~/^co/)) {  
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                     =$tend.':'.$tstart;                      =$tend.':'.$tstart;
     }      }
     if (($env{'request.role'} =~ /dc\./) &&      if ($env{'request.role'} =~ /dc\./ && $trole =~ /^(au|in|cc|ep|cr|ta|co)/) {
  (($trole=~/^au/) || ($trole=~/^in/) ||  
  ($trole=~/^cc/) || ($trole=~/^ep/) ||  
  ($trole=~/^cr/) || ($trole=~/^ta/) ||  
          ($trole=~/^co/))) {  
        $userrolehash         $userrolehash
          {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}           {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                     =$tend.':'.$tstart;                      =$tend.':'.$tstart;
     }      }
     if (($trole=~/^dc/) || ($trole=~/^ad/) ||      if ($trole =~ /^(dc|ad|li|au|dg|sc)/ ) {
         ($trole=~/^li/) || ($trole=~/^li/) ||  
         ($trole=~/^au/) || ($trole=~/^dg/) ||  
         ($trole=~/^sc/)) {  
        my (undef,$rudom,$runame,$rsec)=split(/\//,$area);         my (undef,$rudom,$runame,$rsec)=split(/\//,$area);
        $domainrolehash         $domainrolehash
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
Line 3416  sub userrolelog { Line 3856  sub userrolelog {
   
 sub courserolelog {  sub courserolelog {
     my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;      my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
     if (($trole eq 'cc') || ($trole eq 'in') ||      if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
         ($trole eq 'ep') || ($trole eq 'ad') ||          my $cdom = $1;
         ($trole eq 'ta') || ($trole eq 'st') ||          my $cnum = $2;
         ($trole=~/^cr/) || ($trole eq 'gr') ||          my $sec = $3;
         ($trole eq 'co')) {          my $namespace = 'rolelog';
         if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {          my %storehash = (
             my $cdom = $1;                             role    => $trole,
             my $cnum = $2;                             start   => $tstart,
             my $sec = $3;                             end     => $tend,
             my $namespace = 'rolelog';                             selfenroll => $selfenroll,
             my %storehash = (                             context    => $context,
                                role    => $trole,                          );
                                start   => $tstart,          if ($trole eq 'gr') {
                                end     => $tend,              $namespace = 'groupslog';
                                selfenroll => $selfenroll,              $storehash{'group'} = $sec;
                                context    => $context,          } else {
                             );              $storehash{'section'} = $sec;
             if ($trole eq 'gr') {          }
                 $namespace = 'groupslog';          &write_log('course',$namespace,\%storehash,$delflag,$username,
                 $storehash{'group'} = $sec;                     $domain,$cnum,$cdom);
             } else {          if (($trole ne 'st') || ($sec ne '')) {
                 $storehash{'section'} = $sec;              &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
             }  
             &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);  
             if (($trole ne 'st') || ($sec ne '')) {  
                 &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);  
             }  
         }          }
     }      }
     return;      return;
 }  }
   
   sub domainrolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
       if ($area =~ m{^/($match_domain)/$}) {
           my $cdom = $1;
           my $domconfiguser = &Apache::lonnet::get_domainconfiguser($cdom);
           my $namespace = 'rolelog';
           my %storehash = (
                              role    => $trole,
                              start   => $tstart,
                              end     => $tend,
                              context => $context,
                           );
           &write_log('domain',$namespace,\%storehash,$delflag,$username,
                      $domain,$domconfiguser,$cdom);
       }
       return;
   
   }
   
   sub coauthorrolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$context)=@_;
       if ($area =~ m{^/($match_domain)/($match_username)$}) {
           my $audom = $1;
           my $auname = $2;
           my $namespace = 'rolelog';
           my %storehash = (
                              role    => $trole,
                              start   => $tstart,
                              end     => $tend,
                              context => $context,
                           );
           &write_log('author',$namespace,\%storehash,$delflag,$username,
                      $domain,$auname,$audom);
       }
       return;
   }
   
 sub get_course_adv_roles {  sub get_course_adv_roles {
     my ($cid,$codes) = @_;      my ($cid,$codes) = @_;
     $cid=$env{'request.course.id'} unless (defined($cid));      $cid=$env{'request.course.id'} unless (defined($cid));
Line 3461  sub get_course_adv_roles { Line 3933  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 3473  sub get_course_adv_roles { Line 3949  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 3515  sub get_my_roles { Line 3978  sub get_my_roles {
     unless (defined($udom)) { $udom=$env{'user.domain'}; }      unless (defined($udom)) { $udom=$env{'user.domain'}; }
     my (%dumphash,%nothide);      my (%dumphash,%nothide);
     if ($context eq 'userroles') {      if ($context eq 'userroles') {
         my $extra = &freeze_escape({'skipcheck' => 1});          %dumphash = &dump('roles',$udom,$uname);
         %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);  
     } 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 3537  sub get_my_roles { Line 3998  sub get_my_roles {
     foreach my $entry (keys(%dumphash)) {      foreach my $entry (keys(%dumphash)) {
         my ($role,$tend,$tstart);          my ($role,$tend,$tstart);
         if ($context eq 'userroles') {          if ($context eq 'userroles') {
               next if ($entry =~ /^rolesdef/);
     ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});      ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
         } else {          } else {
             ($tend,$tstart)=split(/\:/,$dumphash{$entry});              ($tend,$tstart)=split(/\:/,$dumphash{$entry});
Line 3560  sub get_my_roles { Line 4022  sub get_my_roles {
         }          }
         my ($rolecode,$username,$domain,$section,$area);          my ($rolecode,$username,$domain,$section,$area);
         if ($context eq 'userroles') {          if ($context eq 'userroles') {
             ($area,$rolecode) = split(/_/,$entry);              ($area,$rolecode) = ($entry =~ /^(.+)_([^_]+)$/);
             (undef,$domain,$username,$section) = split(/\//,$area);              (undef,$domain,$username,$section) = split(/\//,$area);
         } else {          } else {
             ($role,$username,$domain,$section) = split(/\:/,$entry);              ($role,$username,$domain,$section) = split(/\:/,$entry);
Line 3586  sub get_my_roles { Line 4048  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 3711  sub courseiddump { Line 4160  sub courseiddump {
   
     if (($domfilter eq '') ||      if (($domfilter eq '') ||
  (&host_domain($tryserver) eq $domfilter)) {   (&host_domain($tryserver) eq $domfilter)) {
                 my $rep =                   my $rep;
                   &reply('courseiddump:'.&host_domain($tryserver).':'.                  if (grep { $_ eq $tryserver } &current_machine_ids()) {
                          $sincefilter.':'.&escape($descfilter).':'.                      $rep = &LONCAPA::Lond::dump_course_id_handler(
                          &escape($instcodefilter).':'.&escape($ownerfilter).                          join(":", (&host_domain($tryserver), $sincefilter,
                          ':'.&escape($coursefilter).':'.&escape($typefilter).                                  &escape($descfilter), &escape($instcodefilter),
                          ':'.&escape($regexp_ok).':'.$as_hash.':'.                                  &escape($ownerfilter), &escape($coursefilter),
                          &escape($selfenrollonly).':'.&escape($catfilter).':'.                                  &escape($typefilter), &escape($regexp_ok),
                          $showhidden.':'.$caller.':'.&escape($cloner).':'.                                  $as_hash, &escape($selfenrollonly),
                          &escape($cc_clone).':'.$cloneonly.':'.                                  &escape($catfilter), $showhidden, $caller,
                          &escape($createdbefore).':'.&escape($createdafter).':'.                                  &escape($cloner), &escape($cc_clone), $cloneonly,
                          &escape($creationcontext).':'.$domcloner,                                  &escape($createdbefore), &escape($createdafter),
                          $tryserver);                                  &escape($creationcontext), $domcloner)));
                   } else {
                       $rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
                                $sincefilter.':'.&escape($descfilter).':'.
                                &escape($instcodefilter).':'.&escape($ownerfilter).
                                ':'.&escape($coursefilter).':'.&escape($typefilter).
                                ':'.&escape($regexp_ok).':'.$as_hash.':'.
                                &escape($selfenrollonly).':'.&escape($catfilter).':'.
                                $showhidden.':'.$caller.':'.&escape($cloner).':'.
                                &escape($cc_clone).':'.$cloneonly.':'.
                                &escape($createdbefore).':'.&escape($createdafter).':'.
                                &escape($creationcontext).':'.$domcloner,
                                $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 3828  sub get_domain_roles { Line 4291  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 3850  sub get_domain_roles { Line 4313  sub get_domain_roles {
   
 # ----------------------------------------------------------- Interval timing   # ----------------------------------------------------------- Interval timing 
   
   {
   # Caches needed for speedup of navmaps
   # We don't want to cache this for very long at all (5 seconds at most)
   # 
   # The user for whom we cache
   my $cachedkey='';
   # The cached times for this user
   my %cachedtimes=();
   # When this was last done
   my $cachedtime=();
   
   sub load_all_first_access {
       my ($uname,$udom)=@_;
       if (($cachedkey eq $uname.':'.$udom) &&
           (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
           return;
       }
       $cachedtime=time;
       $cachedkey=$uname.':'.$udom;
       %cachedtimes=&dump('firstaccesstimes',$udom,$uname);
   }
   
 sub get_first_access {  sub get_first_access {
     my ($type,$argsymb)=@_;      my ($type,$argsymb,$argmap)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
       if ($argmap) { $map = $argmap; }
     if ($type eq 'course') {      if ($type eq 'course') {
  $res='course';   $res='course';
     } elsif ($type eq 'map') {      } elsif ($type eq 'map') {
Line 3862  sub get_first_access { Line 4348  sub get_first_access {
     } else {      } else {
  $res=$symb;   $res=$symb;
     }      }
     my %times=&get('firstaccesstimes',["$courseid\0$res"],$udom,$uname);      &load_all_first_access($uname,$udom);
     return $times{"$courseid\0$res"};      return $cachedtimes{"$courseid\0$res"};
 }  }
   
 sub set_first_access {  sub set_first_access {
     my ($type)=@_;      my ($type,$interval)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'course') {      if ($type eq 'course') {
Line 3877  sub set_first_access { Line 4363  sub set_first_access {
     } else {      } else {
  $res=$symb;   $res=$symb;
     }      }
     my $firstaccess=&get_first_access($type,$symb);      $cachedkey='';
       my $firstaccess=&get_first_access($type,$symb,$map);
     if (!$firstaccess) {      if (!$firstaccess) {
  return &put('firstaccesstimes',{"$courseid\0$res"=>time},$udom,$uname);          my $start = time;
    my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
                             $udom,$uname);
           if ($putres eq 'ok') {
               &put('timerinterval',{"$courseid\0$res"=>$interval},
                    $udom,$uname); 
               &appenv(
                        {
                           'course.'.$courseid.'.firstaccess.'.$res   => $start,
                           'course.'.$courseid.'.timerinterval.'.$res => $interval,
                        }
                     );
           }
           return $putres;
     }      }
     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
   
Line 4333  sub restore { Line 4919  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 4470  sub update_released_required { Line 5059  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=&reply("dump:$domain:$username:roles",      my $now = time;
  &homeserver($username,$domain));      my $roles;
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||       if (ref($possroles) eq 'ARRAY') {
         ($rolesdump =~ /^error:/)) {          $roles = $possroles;
         return 0;      } else {
     }          $roles = ['dc','su'];
     my $now=time;      }
     if ($rolesdump ne '') {      if (ref($possdomains) eq 'ARRAY') {
         foreach my $entry (split(/&/,$rolesdump)) {          my %privileged = &privileged_by_domain($possdomains,$roles);
     if ($entry!~/^rolesdef_/) {          foreach my $dom (@{$possdomains}) {
  my ($area,$role)=split(/=/,$entry);              if (($username =~ /^$match_username$/) && ($domain =~ /^$match_domain$/) &&
  $area=~s/\_\w\w$//;                  (ref($privileged{$dom}) eq 'HASH')) {
  my ($trole,$tend,$tstart)=split(/_/,$role);                  foreach my $role (@{$roles}) {
  if (($trole eq 'dc') || ($trole eq 'su')) {                      if (ref($privileged{$dom}{$role}) eq 'HASH') {
     my $active=1;                          if (exists($privileged{$dom}{$role}{$username.':'.$domain})) {
     if ($tend) {                              my ($end,$start) = split(/:/,$privileged{$dom}{$role}{$username.':'.$domain});
  if ($tend<$now) { $active=0; }                              return 1 unless (($end && $end < $now) ||
     }                                               ($start && $start > $now));
     if ($tstart) {                          }
  if ($tstart>$now) { $active=0; }                      }
     }                  }
     if ($active) { return 1; }              }
  }          }
     }      } else {
  }          my %rolesdump = &dump("roles", $domain, $username) or return 0;
           my $now = time;
   
           for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
               my ($trole, $tend, $tstart) = split(/_/, $role);
               if (grep(/^\Q$trole\E$/,@{$roles})) {
                   return 1 unless ($tend && $tend < $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 {
     my ($domain,$username,$authhost)=@_;      my ($domain, $username) = @_;
     my $now=time;      my %userroles = ('user.login.time' => time);
     my %userroles = ('user.login.time' => $now);      my %rolesdump = &dump("roles", $domain, $username) or return \%userroles;
     my $extra = &freeze_escape({'skipcheck' => 1});  
     my $rolesdump=reply("dump:$domain:$username:roles:.::$extra",$authhost);      # firstaccess and timerinterval are related to timed maps/resources. 
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||       # also, blocking can be triggered by an activating timer
         ($rolesdump =~ /^error:/)) {      # it's saved in the user's %env.
         return \%userroles;      my %firstaccess = &dump('firstaccesstimes', $domain, $username);
       my %timerinterval = &dump('timerinterval', $domain, $username);
       my (%coursetimerstarts, %firstaccchk, %firstaccenv, %coursetimerintervals,
           %timerintchk, %timerintenv);
   
       foreach my $key (keys(%firstaccess)) {
           my ($cid, $rest) = split(/\0/, $key);
           $coursetimerstarts{$cid}{$rest} = $firstaccess{$key};
       }
   
       foreach my $key (keys(%timerinterval)) {
           my ($cid,$rest) = split(/\0/,$key);
           $coursetimerintervals{$cid}{$rest} = $timerinterval{$key};
     }      }
   
     my %allroles=();      my %allroles=();
     my %allgroups=();         my %allgroups=();
   
     if ($rolesdump ne '') {      for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {
         foreach my $entry (split(/&/,$rolesdump)) {          my $role = $rolesdump{$area};
   if ($entry!~/^rolesdef_/) {          $area =~ s/\_\w\w$//;
             my ($area,$role)=split(/=/,$entry);  
     $area=~s/\_\w\w$//;          my ($trole, $tend, $tstart, $group_privs);
             my ($trole,$tend,$tstart,$group_privs);  
     if ($role=~/^cr/) {           if ($role =~ /^cr/) {
  if ($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {          # Custom role, defined by a user 
     ($trole,my $trest)=($role=~m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|);          # e.g., user.role.cr/msu/smith/mynewrole
     ($tend,$tstart)=split('_',$trest);              if ($role =~ m|^(cr/$match_domain/$match_username/[a-zA-Z0-9]+)_(.*)$|) {
  } else {                  $trole = $1;
     $trole=$role;                  ($tend, $tstart) = split('_', $2);
  }              } else {
             } elsif ($role =~ m|^gr/|) {                  $trole = $role;
                 ($trole,$tend,$tstart) = split(/_/,$role);  
                 next if ($tstart eq '-1');  
                 ($trole,$group_privs) = split(/\//,$trole);  
                 $group_privs = &unescape($group_privs);  
     } else {  
  ($trole,$tend,$tstart)=split(/_/,$role);  
     }  
     my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,  
  $username);  
     @userroles{keys(%new_role)} = @new_role{keys(%new_role)};  
             if (($tend!=0) && ($tend<$now)) { $trole=''; }  
             if (($tstart!=0) && ($tstart>$now)) { $trole=''; }  
             if (($area ne '') && ($trole ne '')) {  
  my $spec=$trole.'.'.$area;  
  my ($tdummy,$tdomain,$trest)=split(/\//,$area);  
  if ($trole =~ /^cr\//) {  
                     &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);  
                 } elsif ($trole eq 'gr') {  
                     &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);  
  } else {  
                     &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);  
  }  
             }              }
           }          } elsif ($role =~ m|^gr/|) {
           # Role of member in a group, defined within a course/community
           # e.g., user.role.gr/msu/04935610a19ee4a5fmsul1/leopards
               ($trole, $tend, $tstart) = split(/_/, $role);
               next if $tstart eq '-1';
               ($trole, $group_privs) = split(/\//, $trole);
               $group_privs = &unescape($group_privs);
           } else {
           # Just a normal role, defined in roles.tab
               ($trole, $tend, $tstart) = split(/_/,$role);
           }
   
           my %new_role = &set_arearole($trole,$area,$tstart,$tend,$domain,
                    $username);
           @userroles{keys(%new_role)} = @new_role{keys(%new_role)};
   
           # role expired or not available yet?
           $trole = '' if ($tend != 0 && $tend < $userroles{'user.login.time'}) or 
               ($tstart != 0 && $tstart > $userroles{'user.login.time'});
   
           next if $area eq '' or $trole eq '';
   
           my $spec = "$trole.$area";
           my ($tdummy, $tdomain, $trest) = split(/\//, $area);
   
           if ($trole =~ /^cr\//) {
           # Custom role, defined by a user
               &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
           } elsif ($trole eq 'gr') {
           # Role of a member in a group, defined within a course/community
               &group_roleprivs(\%allgroups,$area,$group_privs,$tend,$tstart);
               next;
           } else {
           # Normal role, defined in roles.tab
               &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
           }
   
           my $cid = $tdomain.'_'.$trest;
           unless ($firstaccchk{$cid}) {
               if (ref($coursetimerstarts{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerstarts{$cid}})) {
                       $firstaccenv{'course.'.$cid.'.firstaccess.'.$item} = 
                           $coursetimerstarts{$cid}{$item}; 
                   }
               }
               $firstaccchk{$cid} = 1;
           }
           unless ($timerintchk{$cid}) {
               if (ref($coursetimerintervals{$cid}) eq 'HASH') {
                   foreach my $item (keys(%{$coursetimerintervals{$cid}})) {
                       $timerintenv{'course.'.$cid.'.timerinterval.'.$item} =
                          $coursetimerintervals{$cid}{$item};
                   }
               }
               $timerintchk{$cid} = 1;
         }          }
         my ($author,$adv) = &set_userprivs(\%userroles,\%allroles,\%allgroups);  
         $userroles{'user.adv'}    = $adv;  
  $userroles{'user.author'} = $author;  
         $env{'user.adv'}=$adv;  
     }      }
     return \%userroles;    
       @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles,
           \%allroles, \%allgroups);
       $env{'user.adv'} = $userroles{'user.adv'};
   
       return (\%userroles,\%firstaccenv,\%timerintenv);
 }  }
   
 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 4813  sub delete_env_groupprivs { Line 5509  sub delete_env_groupprivs {
 sub check_adhoc_privs {  sub check_adhoc_privs {
     my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;      my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
     my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;      my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
       my $setprivs;
     if ($env{$cckey}) {      if ($env{$cckey}) {
         my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);          my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
         &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);          &role_status($cckey,$update,$refresh,$now,\$role,\$where,\$trolecode,\$tstatus,\$tstart,\$tend);
         unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {          unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
             &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);              &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
               $setprivs = 1;
         }          }
     } else {      } else {
         &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);          &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
           $setprivs = 1;
     }      }
       return $setprivs;
 }  }
   
 sub set_adhoc_privileges {  sub set_adhoc_privileges {
Line 4830  sub set_adhoc_privileges { Line 5530  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 4893  sub del { Line 5593  sub del {
   
 # -------------------------------------------------------------- dump interface  # -------------------------------------------------------------- dump interface
   
   sub unserialize {
       my ($rep, $escapedkeys) = @_;
   
       return {} if $rep =~ /^error/;
   
       my %returnhash=();
       foreach my $item (split(/\&/,$rep)) {
           my ($key, $value) = split(/=/, $item, 2);
           $key = unescape($key) unless $escapedkeys;
           next if $key =~ /^error: 2 /;
           $returnhash{$key} = &thaw_unescape($value);
       }
       return \%returnhash;
   }
   
   # see Lond::dump_with_regexp
   # if $escapedkeys hash keys won't get unescaped.
 sub dump {  sub dump {
     my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;      my ($namespace,$udomain,$uname,$regexp,$range,$escapedkeys)=@_;
     if (!$udomain) { $udomain=$env{'user.domain'}; }      if (!$udomain) { $udomain=$env{'user.domain'}; }
     if (!$uname) { $uname=$env{'user.name'}; }      if (!$uname) { $uname=$env{'user.name'}; }
     my $uhome=&homeserver($uname,$udomain);      my $uhome=&homeserver($uname,$udomain);
   
       my $reply;
       if (grep { $_ eq $uhome } &current_machine_ids()) {
           # user is hosted on this machine
           $reply = LONCAPA::Lond::dump_with_regexp(join(':', ($udomain,
                       $uname, $namespace, $regexp, $range)), $perlvar{'lonVersion'});
           return %{&unserialize($reply, $escapedkeys)};
       }
     if ($regexp) {      if ($regexp) {
  $regexp=&escape($regexp);   $regexp=&escape($regexp);
     } else {      } else {
  $regexp='.';   $regexp='.';
     }      }
     my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range:$extra",$uhome);      my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);
     my @pairs=split(/\&/,$rep);      my @pairs=split(/\&/,$rep);
     my %returnhash=();      my %returnhash=();
     if (!($rep =~ /^error/ )) {      if (!($rep =~ /^error/ )) {
  foreach my $item (@pairs) {   foreach my $item (@pairs) {
     my ($key,$value)=split(/=/,$item,2);      my ($key,$value)=split(/=/,$item,2);
     $key = &unescape($key);              $key = &unescape($key) unless ($escapedkeys);
     next if ($key =~ /^error: 2 /);      next if ($key =~ /^error: 2 /);
     $returnhash{$key}=&thaw_unescape($value);      $returnhash{$key}=&thaw_unescape($value);
  }   }
Line 4922  sub dump { Line 5647  sub dump {
   
 sub dumpstore {  sub dumpstore {
    my ($namespace,$udomain,$uname,$regexp,$range)=@_;     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     # same as dump but keys must be escaped. They may contain colon separated
    if (!$uname) { $uname=$env{'user.name'}; }     # lists of values that may themself contain colons (e.g. symbs).
    my $uhome=&homeserver($uname,$udomain);     return &dump($namespace, $udomain, $uname, $regexp, $range, 1);
    if ($regexp) {  
        $regexp=&escape($regexp);  
    } else {  
        $regexp='.';  
    }  
    my $rep=&reply("dump:$udomain:$uname:$namespace:$regexp:$range",$uhome);  
    my @pairs=split(/\&/,$rep);  
    my %returnhash=();  
    foreach my $item (@pairs) {  
        my ($key,$value)=split(/=/,$item,2);  
        next if ($key =~ /^error: 2 /);  
        $returnhash{$key}=&thaw_unescape($value);  
    }  
    return %returnhash;  
 }  }
   
 # -------------------------------------------------------------- keys interface  # -------------------------------------------------------------- keys interface
Line 5207  sub tmpdel { Line 5918  sub tmpdel {
     return &reply("tmpdel:$token",$server);      return &reply("tmpdel:$token",$server);
 }  }
   
   # ------------------------------------------------------------ get_timebased_id
   
   sub get_timebased_id {
       my ($prefix,$keyid,$namespace,$cdom,$cnum,$idtype,$who,$locktries,
           $maxtries) = @_;
       my ($newid,$error,$dellock);
       unless (($prefix =~ /^\w+$/) && ($keyid =~ /^\w+$/) && ($namespace ne '')) {
           return ('','ok','invalid call to get suffix');
       }
   
   # set defaults for any optional args for which values were not supplied
       if ($who eq '') {
           $who = $env{'user.name'}.':'.$env{'user.domain'};
       }
       if (!$locktries) {
           $locktries = 3;
       }
       if (!$maxtries) {
           $maxtries = 10;
       }
   
       if (($cdom eq '') || ($cnum eq '')) {
           if ($env{'request.course.id'}) {
               $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
               $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           }
           if (($cdom eq '') || ($cnum eq '')) {
               return ('','ok','call to get suffix not in course context');
           }
       }
   
   # construct locking item
       my $lockhash = {
                         $prefix."\0".'locked_'.$keyid => $who,
                      };
       my $tries = 0;
   
   # attempt to get lock on nohist_$namespace file
       my $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
       while (($gotlock ne 'ok') && $tries <$locktries) {
           $tries ++;
           sleep 1;
           $gotlock = &Apache::lonnet::newput('nohist_'.$namespace,$lockhash,$cdom,$cnum);
       }
   
   # attempt to get unique identifier, based on current timestamp
       if ($gotlock eq 'ok') {
           my %inuse = &Apache::lonnet::dump('nohist_'.$namespace,$cdom,$cnum,$prefix);
           my $id = time;
           $newid = $id;
           my $idtries = 0;
           while (exists($inuse{$prefix."\0".$newid}) && $idtries < $maxtries) {
               if ($idtype eq 'concat') {
                   $newid = $id.$idtries;
               } else {
                   $newid ++;
               }
               $idtries ++;
           }
           if (!exists($inuse{$prefix."\0".$newid})) {
               my %new_item =  (
                                 $prefix."\0".$newid => $who,
                               );
               my $putresult = &Apache::lonnet::put('nohist_'.$namespace,\%new_item,
                                                    $cdom,$cnum);
               if ($putresult ne 'ok') {
                   undef($newid);
                   $error = 'error saving new item: '.$putresult;
               }
           } else {
                $error = ('error: no unique suffix available for the new item ');
           }
   #  remove lock
           my @del_lock = ($prefix."\0".'locked_'.$keyid);
           $dellock = &Apache::lonnet::del('nohist_'.$namespace,\@del_lock,$cdom,$cnum);
       } else {
           $error = "error: could not obtain lockfile\n";
           $dellock = 'ok';
       }
       return ($newid,$dellock,$error);
   }
   
 # -------------------------------------------------- portfolio access checking  # -------------------------------------------------- portfolio access checking
   
 sub portfolio_access {  sub portfolio_access {
Line 5462  sub usertools_access { Line 6255  sub usertools_access {
                       unofficial => 1,                        unofficial => 1,
                       community  => 1,                        community  => 1,
                  );                   );
       } elsif ($context eq 'requestauthor') {
           %tools = (
                         requestauthor => 1,
                    );
     } else {      } else {
         %tools = (          %tools = (
                       aboutme   => 1,                        aboutme   => 1,
                       blog      => 1,                        blog      => 1,
                         webdav    => 1,
                       portfolio => 1,                        portfolio => 1,
                  );                   );
     }      }
Line 5480  sub usertools_access { Line 6278  sub usertools_access {
         if ($action ne 'reload') {          if ($action ne 'reload') {
             if ($context eq 'requestcourses') {              if ($context eq 'requestcourses') {
                 return $env{'environment.canrequest.'.$tool};                  return $env{'environment.canrequest.'.$tool};
               } elsif ($context eq 'requestauthor') {
                   return $env{'environment.canrequest.author'};
             } else {              } else {
                 return $env{'environment.availabletools.'.$tool};                  return $env{'environment.availabletools.'.$tool};
             }              }
         }          }
     }      }
   
     my ($toolstatus,$inststatus);      my ($toolstatus,$inststatus,$envkey);
       if ($context eq 'requestauthor') {
           $envkey = $context;
       } else {
           $envkey = $context.'.'.$tool;
       }
   
     if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&      if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
          ($action ne 'reload')) {           ($action ne 'reload')) {
         $toolstatus = $env{'environment.'.$context.'.'.$tool};          $toolstatus = $env{'environment.'.$envkey};
         $inststatus = $env{'environment.inststatus'};          $inststatus = $env{'environment.inststatus'};
     } else {      } else {
         if (ref($userenvref) eq 'HASH') {          if (ref($userenvref) eq 'HASH') {
             $toolstatus = $userenvref->{$context.'.'.$tool};              $toolstatus = $userenvref->{$envkey};
             $inststatus = $userenvref->{'inststatus'};              $inststatus = $userenvref->{'inststatus'};
         } else {          } else {
             my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool,'inststatus');              my %userenv = &userenvironment($udom,$uname,$envkey,'inststatus');
             $toolstatus = $userenv{$context.'.'.$tool};              $toolstatus = $userenv{$envkey};
             $inststatus = $userenv{'inststatus'};              $inststatus = $userenv{'inststatus'};
         }          }
     }      }
Line 5564  sub usertools_access { Line 6369  sub usertools_access {
             }              }
         }          }
     } else {      } else {
         if ($context eq 'tools') {          if (($context eq 'tools') && ($tool ne 'webdav')) {
             $access = 1;              $access = 1;
         } else {          } else {
             $access = 0;              $access = 0;
Line 5940  sub allowed { Line 6745  sub allowed {
         if ($match) {          if ($match) {
             if ($env{'user.priv.'.$env{'request.role'}.'./'}              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                 $thisallowed.=$1;                  my @blockers = &has_comm_blocking($priv,$symb,$uri);
                   if (@blockers > 0) {
                       $thisallowed = 'B';
                   } else {
                       $thisallowed.=$1;
                   }
             }              }
         } else {          } else {
             my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};              my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
Line 5951  sub allowed { Line 6761  sub allowed {
                     $refuri=&declutter($refuri);                      $refuri=&declutter($refuri);
                     my ($match) = &is_on_map($refuri);                      my ($match) = &is_on_map($refuri);
                     if ($match) {                      if ($match) {
                         $thisallowed='F';                          my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                           if (@blockers > 0) {
                               $thisallowed = 'B';
                           } else {
                               $thisallowed='F';
                           }
                     }                      }
                 }                  }
             }              }
Line 6003  sub allowed { Line 6818  sub allowed {
            $statecond=$cond;             $statecond=$cond;
            if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}             if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                =~/\Q$priv\E\&([^\:]*)/) {                 =~/\Q$priv\E\&([^\:]*)/) {
                $thisallowed.=$1;                 my $value = $1;
                  if ($priv eq 'bre') {
                      my @blockers = &has_comm_blocking($priv,$symb,$uri);
                      if (@blockers > 0) {
                          $thisallowed = 'B';
                      } else {
                          $thisallowed.=$value;
                      }
                  } else {
                      $thisallowed.=$value;
                  }
                $checkreferer=0;                 $checkreferer=0;
            }             }
        }         }
Line 6031  sub allowed { Line 6856  sub allowed {
               my $refstatecond=$cond;                my $refstatecond=$cond;
               if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}                if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                   =~/\Q$priv\E\&([^\:]*)/) {                    =~/\Q$priv\E\&([^\:]*)/) {
                   $thisallowed.=$1;                    my $value = $1;
                     if ($priv eq 'bre') {
                         my @blockers = &has_comm_blocking($priv,$symb,$refuri);
                         if (@blockers > 0) {
                             $thisallowed = 'B';
                         } else {
                             $thisallowed.=$value;
                         }
                     } else {
                         $thisallowed.=$value;
                     }
                   $uri=$refuri;                    $uri=$refuri;
                   $statecond=$refstatecond;                    $statecond=$refstatecond;
               }                }
Line 6190  sub allowed { Line 7025  sub allowed {
     }      }
    return 'F';     return 'F';
 }  }
   
   # ------------------------------------------- Check construction space access
   
   sub constructaccess {
       my ($url,$setpriv)=@_;
   
   # We do not allow editing of previous versions of files
       if ($url=~/\.(\d+)\.(\w+)$/) { return ''; }
   
   # Get username and domain from URL
       my ($ownername,$ownerdomain,$ownerhome);
   
       ($ownerdomain,$ownername) =
           ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/});
   
   # The URL does not really point to any authorspace, forget it
       unless (($ownername) && ($ownerdomain)) { return ''; }
   
   # Now we need to see if the user has access to the authorspace of
   # $ownername at $ownerdomain
   
       if (($ownername eq $env{'user.name'}) && ($ownerdomain eq $env{'user.domain'})) {
   # Real author for this?
          $ownerhome = $env{'user.home'};
          if (exists($env{'user.priv.au./'.$ownerdomain.'/./'})) {
             return ($ownername,$ownerdomain,$ownerhome);
          }
       } else {
   # Co-author for this?
           if (exists($env{'user.priv.ca./'.$ownerdomain.'/'.$ownername.'./'}) ||
               exists($env{'user.priv.aa./'.$ownerdomain.'/'.$ownername.'./'}) ) {
               $ownerhome = &homeserver($ownername,$ownerdomain);
               return ($ownername,$ownerdomain,$ownerhome);
           }
       }
   
   # We don't have any access right now. If we are not possibly going to do anything about this,
   # we might as well leave
      unless ($setpriv) { return ''; }
   
   # Backdoor access?
       my $allowed=&allowed('eco',$ownerdomain);
   # Nope
       unless ($allowed) { return ''; }
   # Looks like we may have access, but could be locked by the owner of the construction space
       if ($allowed eq 'U') {
           my %blocked=&get('environment',['domcoord.author'],
                            $ownerdomain,$ownername);
   # Is blocked by owner
           if ($blocked{'domcoord.author'} eq 'blocked') { return ''; }
       }
       if (($allowed eq 'F') || ($allowed eq 'U')) {
   # Grant temporary access
           my $then=$env{'user.login.time'};
           my $update=$env{'user.update.time'};
           if (!$update) { $update = $then; }
           my $refresh=$env{'user.refresh.time'};
           if (!$refresh) { $refresh = $update; }
           my $now = time;
           &check_adhoc_privs($ownerdomain,$ownername,$update,$refresh,
                              $now,'ca','constructaccess');
           $ownerhome = &homeserver($ownername,$ownerdomain);
           return($ownername,$ownerdomain,$ownerhome);
       }
   # No business here
       return '';
   }
   
   sub get_comm_blocks {
       my ($cdom,$cnum) = @_;
       if ($cdom eq '' || $cnum eq '') {
           return unless ($env{'request.course.id'});
           $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
       }
       my %commblocks;
       my $hashid=$cdom.'_'.$cnum;
       my ($blocksref,$cached)=&is_cached_new('comm_block',$hashid);
       if ((defined($cached)) && (ref($blocksref) eq 'HASH')) {
           %commblocks = %{$blocksref};
       } else {
           %commblocks = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
           my $cachetime = 600;
           &do_cache_new('comm_block',$hashid,\%commblocks,$cachetime);
       }
       return %commblocks;
   }
   
   sub has_comm_blocking {
       my ($priv,$symb,$uri,$blocks) = @_;
       return unless ($env{'request.course.id'});
       return unless ($priv eq 'bre');
       return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
       my %commblocks;
       if (ref($blocks) eq 'HASH') {
           %commblocks = %{$blocks};
       } else {
           %commblocks = &get_comm_blocks();
       }
       return unless (keys(%commblocks) > 0);
       if (!$symb) { $symb=&symbread($uri,1); }
       my ($map,$resid,undef)=&decode_symb($symb);
       my %tocheck = (
                       maps      => $map,
                       resources => $symb,
                     );
       my @blockers;
       my $now = time;
       my $navmap = Apache::lonnavmaps::navmap->new();
       foreach my $block (keys(%commblocks)) {
           if ($block =~ /^(\d+)____(\d+)$/) {
               my ($start,$end) = ($1,$2);
               if ($start <= $now && $end >= $now) {
                   if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                       if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                           if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
                               if ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) {
                                   unless (grep(/^\Q$block\E$/,@blockers)) {
                                       push(@blockers,$block);
                                   }
                               }
                           }
                           if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
                               if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) {
                                   unless (grep(/^\Q$block\E$/,@blockers)) {  
                                       push(@blockers,$block);
                                   }
                               }
                           }
                       }
                   }
               }
           } elsif ($block =~ /^firstaccess____(.+)$/) {
               my $item = $1;
               my @to_test;
               if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
                   if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
                       my $check_interval;
                       if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) {
                           my @interval;
                           my $type = 'map';
                           if ($item eq 'course') {
                               $type = 'course';
                               @interval=&EXT("resource.0.interval");
                           } else {
                               if ($item =~ /___\d+___/) {
                                   $type = 'resource';
                                   @interval=&EXT("resource.0.interval",$item);
                                   if (ref($navmap)) {                        
                                       my $res = $navmap->getBySymb($item); 
                                       push(@to_test,$res);
                                   }
                               } else {
                                   my $mapsymb = &symbread($item,1);
                                   if ($mapsymb) {
                                       if (ref($navmap)) {
                                           my $mapres = $navmap->getBySymb($mapsymb);
                                           @to_test = $mapres->retrieveResources($mapres,undef,0,1);
                                           foreach my $res (@to_test) {
                                               my $symb = $res->symb();
                                               next if ($symb eq $mapsymb);
                                               if ($symb ne '') {
                                                   @interval=&EXT("resource.0.interval",$symb);
                                                   last;
                                               }
                                           }
                                       }
                                   }
                               }
                           }
                           if ($interval[0] =~ /\d+/) {
                               my $first_access;
                               if ($type eq 'resource') {
                                   $first_access=&get_first_access($interval[1],$item);
                               } elsif ($type eq 'map') {
                                   $first_access=&get_first_access($interval[1],undef,$item);
                               } else {
                                   $first_access=&get_first_access($interval[1]);
                               }
                               if ($first_access) {
                                   my $timesup = $first_access+$interval[0];
                                   if ($timesup > $now) {
                                       foreach my $res (@to_test) {
                                           if ($res->is_problem()) {
                                               if ($res->completable()) {
                                                   unless (grep(/^\Q$block\E$/,@blockers)) {
                                                       push(@blockers,$block);
                                                   }
                                                   last;
                                               }
                                           }
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return @blockers;
   }
   
   sub check_docs_block {
       my ($docsblock,$tocheck) =@_;
       if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) {
           return;
       }
       if (ref($docsblock->{'maps'}) eq 'HASH') {
           if ($tocheck->{'maps'}) {
               if ($docsblock->{'maps'}{$tocheck->{'maps'}}) {
                   return 1;
               }
           }
       }
       if (ref($docsblock->{'resources'}) eq 'HASH') {
           if ($tocheck->{'resources'}) {
               if ($docsblock->{'resources'}{$tocheck->{'resources'}}) {
                   return 1;
               }
           }
       }
       return;
   }
   
 #  #
 #   Removes the versino from a URI and  #   Removes the versino from a URI and
 #   splits it in to its filename and path to the filename.  #   splits it in to its filename and path to the filename.
Line 6558  sub auto_validate_instcode { Line 7618  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 6925  sub get_users_groups { Line 7985  sub get_users_groups {
     } else {        } else {  
         $grouplist = '';          $grouplist = '';
         my $courseurl = &courseid_to_courseurl($courseid);          my $courseurl = &courseid_to_courseurl($courseid);
         my $extra = &freeze_escape({'skipcheck' => 1});          my %roleshash = &dump('roles',$udom,$uname,$courseurl);
         my %roleshash = &dump('roles',$udom,$uname,$courseurl,undef,$extra);  
         my $access_end = $env{'course.'.$courseid.          my $access_end = $env{'course.'.$courseid.
                               '.default_enrollment_end_date'};                                '.default_enrollment_end_date'};
         my $now = time;          my $now = time;
Line 7098  sub assignrole { Line 8157  sub assignrole {
                             }                              }
                         }                          }
                     }                      }
                   } elsif ($context eq 'requestauthor') {
                       if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
                           ($url eq '/'.$udom.'/') && ($role eq 'au')) {
                           if ($env{'environment.requestauthor'} eq 'automatic') {
                               $refused = '';
                           } else {
                               my %domdefaults = &get_domain_defaults($udom);
                               if (ref($domdefaults{'requestauthor'}) eq 'HASH') {
                                   my $checkbystatus;
                                   if ($env{'user.adv'}) {
                                       my $disposition = $domdefaults{'requestauthor'}{'_LC_adv'};
                                       if ($disposition eq 'automatic') {
                                           $refused = '';
                                       } elsif ($disposition eq '') {
                                           $checkbystatus = 1;
                                       }
                                   } else {
                                       $checkbystatus = 1;
                                   }
                                   if ($checkbystatus) {
                                       if ($env{'environment.inststatus'}) {
                                           my @inststatuses = split(/,/,$env{'environment.inststatus'});
                                           foreach my $type (@inststatuses) {
                                               if (($type ne '') &&
                                                   ($domdefaults{'requestauthor'}{$type} eq 'automatic')) {
                                                   $refused = '';
                                               }
                                           }
                                       } elsif ($domdefaults{'requestauthor'}{'default'} eq 'automatic') {
                                           $refused = '';
                                       }
                                   }
                               }
                           }
                       }
                 }                  }
                 if ($refused) {                  if ($refused) {
                     &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.                      &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
Line 7147  sub assignrole { Line 8241  sub assignrole {
 # log new user role if status is ok  # log new user role if status is ok
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($role,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
           if (($role eq 'cc') || ($role eq 'in') ||
               ($role eq 'ep') || ($role eq 'ad') ||
               ($role eq 'ta') || ($role eq 'st') ||
               ($role=~/^cr/) || ($role eq 'gr') ||
               ($role eq 'co')) {
 # for course roles, perform group memberships changes triggered by role change.  # for course roles, perform group memberships changes triggered by role change.
         &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);              unless ($role =~ /^gr/) {
         unless ($role =~ /^gr/) {                  &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,                                                   $origstart,$selfenroll,$context);
                                              $origstart,$selfenroll,$context);              }
               &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $selfenroll,$context);
           } elsif (($role eq 'li') || ($role eq 'dg') || ($role eq 'sc') ||
                    ($role eq 'au') || ($role eq 'dc')) {
               &domainrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                              $context);
           } elsif (($role eq 'ca') || ($role eq 'aa')) {
               &coauthorrolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,
                                $context);
         }          }
         if ($role eq 'cc') {          if ($role eq 'cc') {
             &autoupdate_coowners($url,$end,$start,$uname,$udom);              &autoupdate_coowners($url,$end,$start,$uname,$udom);
Line 7451  sub modifyuser { Line 8559  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 7463  sub modifystudent { Line 8571  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 7514  sub modify_student_enrollment { Line 8624  sub modify_student_enrollment {
         $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');          $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
     }      }
     my $fullname = &format_name($first,$middle,$last,$gene,'lastname');      my $fullname = &format_name($first,$middle,$last,$gene,'lastname');
       my $user = "$uname:$udom";
       my %old_entry = &Apache::lonnet::get('classlist',[$user],$cdom,$cnum);
     my $reply=cput('classlist',      my $reply=cput('classlist',
    {"$uname:$udom" =>      {$user => 
  join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },   join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype,$credits) },
    $cdom,$cnum);     $cdom,$cnum);
     unless (($reply eq 'ok') || ($reply eq 'delayed')) {      if (($reply eq 'ok') || ($reply eq 'delayed')) {
           &devalidate_getsection_cache($udom,$uname,$cid);
       } else { 
  return 'error: '.$reply;   return 'error: '.$reply;
     } else {  
  &devalidate_getsection_cache($udom,$uname,$cid);  
     }      }
     # Add student role to user      # Add student role to user
     my $uurl='/'.$cid;      my $uurl='/'.$cid;
Line 7529  sub modify_student_enrollment { Line 8641  sub modify_student_enrollment {
     if ($usec) {      if ($usec) {
  $uurl.='/'.$usec;   $uurl.='/'.$usec;
     }      }
     return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);      my $result = &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,
                                $selfenroll,$context);
       if ($result ne 'ok') {
           if ($old_entry{$user} ne '') {
               $reply = &cput('classlist',\%old_entry,$cdom,$cnum);
           } else {
               $reply = &del('classlist',[$user],$cdom,$cnum);
           }
       }
       return $result; 
 }  }
   
 sub format_name {  sub format_name {
Line 7728  sub generate_coursenum { Line 8849  sub generate_coursenum {
 }  }
   
 sub is_course {  sub is_course {
     my ($cdom,$cnum) = @_;      my ($cdom, $cnum) = scalar(@_) == 1 ? 
     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,           ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
  undef,'.');  
     if (exists($courses{$cdom.'_'.$cnum})) {      return unless $cdom and $cnum;
         return 1;  
     }      my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,
     return 0;          '.');
   
       return unless(exists($courses{$cdom.'_'.$cnum}));
       return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
 }  }
   
 sub store_userdata {  sub store_userdata {
Line 7758  sub store_userdata { Line 8882  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 8580  sub resdata { Line 9707  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 8608  sub EXT_cache_set { Line 9755  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 8709  sub EXT { Line 9856  sub EXT {
    } elsif ($realm eq 'request') {     } elsif ($realm eq 'request') {
 # ------------------------------------------------------------- request.browser  # ------------------------------------------------------------- request.browser
         if ($space eq 'browser') {          if ($space eq 'browser') {
     if ($qualifier eq 'textremote') {              return $env{'browser.'.$qualifier};
  if (&Apache::lonlocal::mt('textual_remote_display') eq 'on') {  
     return 1;  
  } else {  
     return 0;  
  }  
     } else {  
  return $env{'browser.'.$qualifier};  
     }  
 # ------------------------------------------------------------ request.filename  # ------------------------------------------------------------ request.filename
         } else {          } else {
             return $env{'request.'.$spacequalifierrest};              return $env{'request.'.$spacequalifierrest};
Line 8731  sub EXT { Line 9870  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 8997  sub metadata { Line 10161  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 9362  sub gettitle { Line 10526  sub gettitle {
  }   }
  $title=~s/\&colon\;/\:/gs;   $title=~s/\&colon\;/\:/gs;
  if ($title) {   if ($title) {
   # Remember both $symb and $title for dynamic metadata
               $accesshash{$symb.'___crstitle'}=$title;
               $accesshash{&declutter($map).'___'.&declutter($url).'___usage'}=time;
   # Cache this title and then return it
     return &do_cache_new('title',$key,$title,600);      return &do_cache_new('title',$key,$title,600);
  }   }
  $urlsymb=$url;   $urlsymb=$url;
Line 9394  sub get_slot { Line 10562  sub get_slot {
     }      }
     return $slotinfo{$which};      return $slotinfo{$which};
 }  }
   
   sub get_reservable_slots {
       my ($cnum,$cdom,$uname,$udom) = @_;
       my $now = time;
       my $reservable_info;
       my $key=join("\0",'reservableslots',$cdom,$cnum,$uname,$udom);
       if (exists($remembered{$key})) {
           $reservable_info = $remembered{$key};
       } else {
           my %resv;
           ($resv{'now_order'},$resv{'now'},$resv{'future_order'},$resv{'future'}) =
           &Apache::loncommon::get_future_slots($cnum,$cdom,$now);
           $reservable_info = \%resv;
           $remembered{$key} = $reservable_info;
       }
       return $reservable_info;
   }
   
   sub get_course_slots {
       my ($cnum,$cdom) = @_;
       my $hashid=$cnum.':'.$cdom;
       my ($result,$cached) = &Apache::lonnet::is_cached_new('allslots',$hashid);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               return %{$result};
           }
       } else {
           my %slots=&Apache::lonnet::dump('slots',$cdom,$cnum);
           my ($tmp) = keys(%slots);
           if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
               &do_cache_new('allslots',$hashid,\%slots,600);
               return %slots;
           }
       }
       return;
   }
   
   sub devalidate_slots_cache {
       my ($cnum,$cdom)=@_;
       my $hashid=$cnum.':'.$cdom;
       &devalidate_cache_new('allslots',$hashid);
   }
   
   sub get_coursechange {
       my ($cdom,$cnum) = @_;
       if ($cdom eq '' || $cnum eq '') {
           return unless ($env{'request.course.id'});
           $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
           $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
       }
       my $hashid=$cdom.'_'.$cnum;
       my ($change,$cached)=&is_cached_new('crschange',$hashid);
       if ((defined($cached)) && ($change ne '')) {
           return $change;
       } else {
           my %crshash;
           %crshash = &get('environment',['internal.contentchange'],$cdom,$cnum);
           if ($crshash{'internal.contentchange'} eq '') {
               $change = $env{'course.'.$cdom.'_'.$cnum.'.internal.created'};
               if ($change eq '') {
                   %crshash = &get('environment',['internal.created'],$cdom,$cnum);
                   $change = $crshash{'internal.created'};
               }
           } else {
               $change = $crshash{'internal.contentchange'};
           }
           my $cachetime = 600;
           &do_cache_new('crschange',$hashid,$change,$cachetime);
       }
       return $change;
   }
   
   sub devalidate_coursechange_cache {
       my ($cnum,$cdom)=@_;
       my $hashid=$cnum.':'.$cdom;
       &devalidate_cache_new('crschange',$hashid);
   }
   
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
   
 sub symblist {  sub symblist {
Line 9421  sub symblist { Line 10667  sub symblist {
 # --------------------------------------------------------------- Verify a symb  # --------------------------------------------------------------- Verify a symb
   
 sub symbverify {  sub symbverify {
     my ($symb,$thisurl)=@_;      my ($symb,$thisurl,$encstate)=@_;
     my $thisfn=$thisurl;      my $thisfn=$thisurl;
     $thisfn=&declutter($thisfn);      $thisfn=&declutter($thisfn);
 # direct jump to resource in page or to a sequence - will construct own symbs  # direct jump to resource in page or to a sequence - will construct own symbs
Line 9440  sub symbverify { Line 10686  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) {
    if (($env{'request.role.adv'}) ||                     if (ref($encstate)) {
        ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||                         $$encstate = $bighash{'encrypted_'.$id};
                      }
                      if (($env{'request.role.adv'}) ||
                          ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
                        ($thisurl eq '/adm/navmaps')) {                         ($thisurl eq '/adm/navmaps')) {
        $okay=1;                          $okay=1;
    }                         last;
        }                     }
    }                 }
              }
         }          }
  untie(%bighash);   untie(%bighash);
     }      }
Line 9537  sub deversion { Line 10798  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})) { return $env{$cache_str}; }      if ($thisfn ne '') {
           $cache_str='request.symbread.cached.'.$thisfn;
           if ($env{$cache_str} ne '') {
               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'});
  }          }
  $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 9759  sub rndseed { Line 11024  sub rndseed {
     if (!defined($symb)) {      if (!defined($symb)) {
  unless ($symb=$wsymb) { return time; }   unless ($symb=$wsymb) { return time; }
     }      }
     if (!$courseid) { $courseid=$wcourseid; }      if (!defined $courseid) { 
     if (!$domain) { $domain=$wdomain; }   $courseid=$wcourseid; 
     if (!$username) { $username=$wusername }      }
       if (!defined $domain) { $domain=$wdomain; }
       if (!defined $username) { $username=$wusername }
   
     my $which;      my $which;
     if (defined($cenv->{'rndseed'})) {      if (defined($cenv->{'rndseed'})) {
Line 9769  sub rndseed { Line 11036  sub rndseed {
     } else {      } else {
  $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 10097  sub repcopy_userfile { Line 11362  sub repcopy_userfile {
     my ($file)=@_;      my ($file)=@_;
     my $londocroot = $perlvar{'lonDocRoot'};      my $londocroot = $perlvar{'lonDocRoot'};
     if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }      if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }
     if ($file =~ m{^\Q$londocroot/lonUsers/\E}) { return 'ok'; }      if ($file =~ m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
     my ($cdom,$cnum,$filename) =       my ($cdom,$cnum,$filename) = 
  ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
     my $uri="/uploaded/$cdom/$cnum/$filename";      my $uri="/uploaded/$cdom/$cnum/$filename";
Line 10354  sub declutter { Line 11619  sub declutter {
     $thisfn=~s|^adm/wrapper/||;      $thisfn=~s|^adm/wrapper/||;
     $thisfn=~s|^adm/coursedocs/showdoc/||;      $thisfn=~s|^adm/coursedocs/showdoc/||;
     $thisfn=~s/^res\///;      $thisfn=~s/^res\///;
       $thisfn=~s/^priv\///;
     unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {      unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
         $thisfn=~s/\?.+$//;          $thisfn=~s/\?.+$//;
     }      }
Line 10453  sub goodbye { Line 11719  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 10483  sub get_dns { Line 11749  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 10492  sub get_dns { Line 11760  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 $versions = shift(@{$lines});
           my %supported;
           if ($versions =~ /^VERSIONS\:([\w\.\,]+)$/) {
               my $releaseslist = $1;
               if ($releaseslist =~ /,/) {
                   map { $supported{$_} = 1; } split(/,/,$releaseslist);
               } elsif ($releaseslist) {
                   $supported{$releaseslist} = 1;
               }
           }
           if ($supported{$release}) {
               my $matchthis = 0;
               foreach my $line (@{$lines}) {
                   if ($line =~ /^(\d[\w\.]+)$/) {
                       if ($matchthis) {
                           last;
                       } elsif ($1 eq $release) {
                           $matchthis = 1;
                       }
                   } elsif ($matchthis) {
                       my ($file,$version,$shasum) = split(/,/,$line);
                       $chksum{$file} = $shasum;
                       $revnum{$file} = $version;
                   }
               }
               if (ref($hashref) eq 'HASH') {
                   %{$hashref} = (
                                   sums     => \%chksum,
                                   versions => \%revnum,
                                 );
               }
           }
       }
     return;      return;
 }  }
   
   sub fetch_dns_checksums {
       my %checksums;
       &get_dns('/adm/dns/checksums',\&parse_dns_checksums_tab,1,1,
                \%checksums);
       return \%checksums;
   }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Line 10804  sub get_dns { Line 12125  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 10862  sub get_dns { Line 12183  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 10871  sub all_loncaparevs { Line 12192  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 10946  BEGIN { Line 12300  BEGIN {
     close($config);      close($config);
 }  }
   
 # ---------------------------------------------------------- Read loncaparev table  # --------------------------------------------------------- Read loncaparev table
 {  
     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  &load_loncaparevs();
 {  
     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);  
         }  
     }  
 }  
   
   # ------------------------------------------------------- Read serverhostID table
   
   &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 11032  $readit=1; Line 12367  $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 11172  were new keys. I.E. 1:foo will become 1: Line 12518  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 11272  B<idput($udom,%ids)>: store away a list Line 12618  B<idput($udom,%ids)>: store away a list
   
 =item *  =item *
 X<rolesinit()>  X<rolesinit()>
 B<rolesinit($udom,$username,$authhost)>: get user privileges  B<rolesinit($udom,$username)>: get user privileges.
   returns user role, first access and timer interval hashes
   
   =item *
   X<privileged()>
   B<privileged($username,$domain)>: returns a true if user has a
   privileged and active role (i.e. su or dc), false otherwise.
   
 =item *  =item *
 X<getsection()>  X<getsection()>
Line 11313  allowed($priv,$uri,$symb,$role) : check Line 12665  allowed($priv,$uri,$symb,$role) : check
   
 =item *  =item *
   
   constructaccess($url,$setpriv) : check for access to construction space URL
   
   See if the owner domain and name in the URL match those in the
   expected environment.  If so, return three element list
   ($ownername,$ownerdomain,$ownerhome).
   
   Otherwise return the null string.
   
   If second argument 'setpriv' is true, it assigns the privileges,
   and returns the same three element list, unless the owner has
   blocked "ad hoc" Domain Coordinator access to the Author Space,
   in which case the null string is returned.
   
   =item *
   
 definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom  definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
 role rolename set privileges in format of lonTabs/roles.tab for system, domain,  role rolename set privileges in format of lonTabs/roles.tab for system, domain,
 and course level  and course level
Line 11329  environment).  If no custom name is defi Line 12696  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 11343  of role statuses (active, future or prev Line 12710  of role statuses (active, future or prev
 to restrict the list of roles reported. If no array ref is   to restrict the list of roles reported. If no array ref is 
 provided for types, will default to return only active roles.  provided for types, will default to return only active roles.
   
   =item *
   
   in_course($udom,$uname,$cdom,$cnum,$type,$hideprivileged) : determine if
   user: $uname:$udom has a role in the course: $cdom_$cnum.
   
   Additional optional arguments are: $type (if role checking is to be restricted
   to certain user status types -- previous (expired roles), active (currently
   available roles) or future (roles available in the future), and
   $hideprivileged -- if true will not report course roles for users who
   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
   
 =head2 User Modification  =head2 User Modification
Line 11384  or when Autoupdate.pl is run by cron in Line 12786  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 11435  Inputs: Line 12837  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 11443  Inputs: Line 12847  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 11480  Inputs: Line 12884  Inputs:
   
 =item $context  =item $context
   
   =item $credits, number of credits student will earn from this class
   
 =back  =back
   
   
Line 11536  If defined, the supplied username is use Line 12942  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 11545  data base, returning a hash that is keye Line 12951  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
   
Line 11565  createcourse($udom,$description,$url,$co Line 12974  createcourse($udom,$description,$url,$co
   
 generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).  generate_coursenum($udom,$crstype) : get a unique (unused) course number in domain $udom for course type $crstype (Course or Community).
   
   =item *
   
   is_course($courseid), is_course($cdom, $cnum)
   
   Accepts either a combined $courseid (in the form of domain_courseid) or the
   two component version $cdom, $cnum. It checks if the specified course exists.
   
   Returns:
       undef if the course doesn't exist, otherwise
       in scalar context the combined courseid.
       in list context the two components of the course identifier, domain and 
       courseid.    
   
 =back  =back
   
 =head2 Resource Subroutines  =head2 Resource Subroutines
Line 11592  resource. Expects the local filesystem p Line 13014  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 11633  returns the data handle Line 13060  returns the data handle
   
 =item *  =item *
   
 symbverify($symb,$thisfn) : verifies that $symb actually exists and is  symbverify($symb,$thisfn,$encstate) : verifies that $symb actually exists
 a possible symb for the URL in $thisfn, and if is an encryypted  and is a possible symb for the URL in $thisfn, and if is an encrypted
 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 existance 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 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
   call to symbverify, it will be set to 1 if the symb has been set to be 
   encrypted; otherwise it will be null.
   
 =item *  =item *
   
Line 11691  expirespread($uname,$udom,$stype,$usymb) Line 13120  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 *
   
   can_edit_resource($file,$cnum,$cdom,$resurl,$symb,$group) : determine if current user can edit a particular resource,
   when viewing in course context.
   
    input: six args -- filename (decluttered), course number, course domain,
                       url, symb (if registered) and group (if this is a
                       group item -- e.g., bulletin board, group page etc.).
   
    output: array of five scalars --
            $cfile -- url for file editing if editable on current server
            $home -- homeserver of resource (i.e., for author if published,
                                             or course if uploaded.).
            $switchserver --  1 if server switch will be needed.
            $forceedit -- 1 if icon/link should be to go to edit mode
            $forceview -- 1 if icon/link should be to go to view mode
   
   =item *
   
   is_course_upload($file,$cnum,$cdom)
   
   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
   homeserver.
   
     input: 3 args -- filename (decluttered), course number and course domain.
     output: boolean -- 1 if file was uploaded.
   
 =back  =back
   
 =head2 Storing/Retreiving Data  =head2 Storing/Retreiving Data
Line 12246  Internal notes: Line 13703  Internal notes:
     
  Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.   Locks on files (resulting from submission of portfolio file to a homework problem stored in array of arrays.
   
   =item *
   
 modify_access_controls():  modify_access_controls():
   
 Modifies access controls for a portfolio file  Modifies access controls for a portfolio file
Line 12263  Returns: Line 13722  Returns:
 3. reference to hash of any new or updated access controls.  3. reference to hash of any new or updated access controls.
 4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.  4. reference to hash used to map incoming IDs to uniqueIDs assigned to control.
    key = integer (inbound ID)     key = integer (inbound ID)
    value = uniqueID       value = uniqueID
   
   =item *
   
   get_timebased_id():
   
   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,
   group bulletin boards).
   
   Args: (first three required; six others optional)
   
   1. prefix (alphanumeric): of keys in hash, e.g., suppsequence, docspage,
      docssequence, or name of group
   
   2. keyid (alphanumeric): name of temporary locking key in hash,
      e.g., num, boardids
   
   3. namespace: name of gdbm file used to store suffixes already assigned;
      file will be named nohist_namespace.db
   
   4. cdom: domain of course; default is current course domain 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
      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
      timestamp by 1 until a unique key is obtained.
   
   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
      retrying); default is 3.
   
   9. maxtries: number of attempts to obtain a unique suffix; default is 20.
   
   Returns:
   
   1. suffix obtained (numeric)
   
   2. result of deleting locking key (ok if deleted, or lock never obtained)
   
   3. error: contains (localized) error message if an error occurred.
   
   
 =back  =back
   
Removed from v.1.1144  
changed lines
  Added in v.1.1172.2.32

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