[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.1138 and 1.1222

version 1.1138, 2011/10/17 17:23:29 version 1.1222, 2013/05/15 18:48:38
Line 75  use LWP::UserAgent(); Line 75  use LWP::UserAgent();
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   
 use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir  
   use Encode;
   
   use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir $apache
             $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
             %managerstab);              %managerstab);
   
Line 96  use Math::Random; Line 99  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 108  our @ISA = qw (Exporter); Line 113  our @ISA = qw (Exporter);
 our @EXPORT = qw(%env);  our @EXPORT = qw(%env);
   
   
 # --------------------------------------------------------------------- Logging  # ------------------------------------ Logging (parameters, docs, slots, roles)
 {  {
     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 603  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 634  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 953  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 964  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 982  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 1247  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 1273  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 1332  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 1355  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 1447  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 1524  sub idput { Line 1580  sub idput {
   
 # ------------------------------dump from db file owned by domainconfig user  # ------------------------------dump from db file owned by domainconfig user
 sub dump_dom {  sub dump_dom {
     my ($namespace,$udom,$regexp,$range)=@_;      my ($namespace, $udom, $regexp) = @_;
     if (!$udom) {  
         $udom=$env{'user.domain'};      $udom ||= $env{'user.domain'};
     }  
     my %returnhash;      return () unless $udom;
     if ($udom) {  
         my $uname = &get_domainconfiguser($udom);      return &dump($namespace, $udom, &get_domainconfiguser($udom), $regexp);
         %returnhash = &dump($namespace,$udom,$uname,$regexp,$range);  
     }  
     return %returnhash;  
 }  }
   
 # ------------------------------------------ get items from domain db files     # ------------------------------------------ get items from domain db files   
Line 1913  sub get_domain_defaults { Line 1966  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 1931  sub get_domain_defaults { Line 1986  sub get_domain_defaults {
         } 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};
Line 1943  sub get_domain_defaults { Line 1998  sub get_domain_defaults {
             $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};
Line 1952  sub get_domain_defaults { Line 2010  sub get_domain_defaults {
         foreach my $item ('canuse_pdfforms') {          foreach my $item ('canuse_pdfforms') {
             $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};              $domdefaults{$item} = $domconfig{'coursedefaults'}{$item};
         }          }
           if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
               $domdefaults{'officialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'official'};
               $domdefaults{'unofficialcredits'} = $domconfig{'coursedefaults'}{'coursecredits'}{'unofficial'};
           }
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
         if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
Line 1961  sub get_domain_defaults { Line 2023  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 2207  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 2433  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 2429  sub subscribe { Line 2489  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~m|^/home/httpd/html/adm/|) { return 'ok'; }      my $londocroot = $perlvar{'lonDocRoot'};
     if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'ok'; }      if ($filename=~m{^\Q$londocroot/adm/\E}) { return 'ok'; }
     if ($filename=~m|^/home/httpd/html/userfiles/| or      if ($filename=~m{^\Q/home/httpd/lonUsers/\E}) { return 'ok'; }
  $filename=~m -^/*(uploaded|editupload)/-) {       if ($filename=~m{^\Q$londocroot/userfiles/\E} or
    $filename=~m{^/*(uploaded|editupload)/}) {
  return &repcopy_userfile($filename);   return &repcopy_userfile($filename);
     }      }
     $filename=~s/[\n\r]//g;      $filename=~s/[\n\r]//g;
Line 2459  sub repcopy { Line 2520  sub repcopy {
         unless ($home eq $perlvar{'lonHostID'}) {          unless ($home eq $perlvar{'lonHostID'}) {
            my @parts=split(/\//,$filename);             my @parts=split(/\//,$filename);
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";             my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
            if ($path ne "$perlvar{'lonDocRoot'}/res") {             if ($path ne "$londocroot/res") {
                &logthis("Malconfiguration for replication: $filename");                 &logthis("Malconfiguration for replication: $filename");
        return 'bad_request';         return 'bad_request';
            }             }
Line 2558  sub ssi { Line 2619  sub ssi {
     }      }
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response=$ua->request($request);      my $response= $ua->request($request);
       my $content = $response->content;
   
   
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($content, $response);
     } else {      } else {
  return $response->content;   return $content;
     }      }
 }  }
   
Line 2592  sub allowuploaded { Line 2655  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;
                   }
               }
           }
           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 2797  sub resizeImage { Line 3111  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 2882  sub userfileupload { Line 3196  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 2897  sub userfileupload { Line 3213  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 2966  sub finishuserfileupload { Line 3282  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 2977  sub finishuserfileupload { Line 3300  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 3016  sub finishuserfileupload { Line 3336  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 3042  sub extract_embedded_items { Line 3363  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 3061  sub extract_embedded_items { Line 3404  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 3070  sub extract_embedded_items { Line 3416  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 3090  sub extract_embedded_items { Line 3446  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 3110  sub extract_embedded_items { Line 3475  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 3124  sub add_filetype { Line 3506  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 3250  sub flushcourselogs { Line 3647  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 3337  sub courseacclog { Line 3729  sub courseacclog {
     my $fnsymb=shift;      my $fnsymb=shift;
     unless ($env{'request.course.id'}) { return ''; }      unless ($env{'request.course.id'}) { return ''; }
     my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};      my $what=$fnsymb.':'.$env{'user.name'}.':'.$env{'user.domain'};
     if ($fnsymb=~/(problem|exam|quiz|assess|survey|form|task|page)$/) {      if ($fnsymb=~/$LONCAPA::assess_re/) {
         $what.=':POST';          $what.=':POST';
         # FIXME: Probably ought to escape things....          # FIXME: Probably ought to escape things....
  foreach my $key (keys(%env)) {   foreach my $key (keys(%env)) {
Line 3369  sub countacc { Line 3761  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 3381  sub linklog { Line 3779  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 3415  sub userrolelog { Line 3819  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 3460  sub get_course_adv_roles { Line 3896  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 3472  sub get_course_adv_roles { Line 3912  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 3514  sub get_my_roles { Line 3941  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 3536  sub get_my_roles { Line 3961  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 3559  sub get_my_roles { Line 3985  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 3585  sub get_my_roles { Line 4011  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 3710  sub courseiddump { Line 4123  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 3827  sub get_domain_roles { Line 4254  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 3849  sub get_domain_roles { Line 4276  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 3861  sub get_first_access { Line 4311  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 3876  sub set_first_access { Line 4326  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';
 }  }
   }
 # --------------------------------------------- Set Expire Date for Spreadsheet  # --------------------------------------------- Set Expire Date for Spreadsheet
   
 sub expirespread {  sub expirespread {
Line 4469  sub update_released_required { Line 4933  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 4812  sub delete_env_groupprivs { Line 5383  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 4829  sub set_adhoc_privileges { Line 5404  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 4892  sub del { Line 5467  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} = Apache::lonnet::thaw_unescape($value);
    }
       #return %returnhash;
       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)), $loncaparevs{$uhome});
           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;
           #$key = &unescape($key);
     next if ($key =~ /^error: 2 /);      next if ($key =~ /^error: 2 /);
     $returnhash{$key}=&thaw_unescape($value);      $returnhash{$key}=&thaw_unescape($value);
  }   }
Line 4921  sub dump { Line 5523  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 4963  sub currentdump { Line 5551  sub currentdump {
    $sdom     = $env{'user.domain'}       if (! defined($sdom));     $sdom     = $env{'user.domain'}       if (! defined($sdom));
    $sname    = $env{'user.name'}         if (! defined($sname));     $sname    = $env{'user.name'}         if (! defined($sname));
    my $uhome = &homeserver($sname,$sdom);     my $uhome = &homeserver($sname,$sdom);
    my $rep=reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);     my $rep;
   
      if (grep { $_ eq $uhome } current_machine_ids()) {
          $rep = LONCAPA::Lond::dump_profile_database(join(":", ($sdom, $sname, 
                      $courseid)));
      } else {
          $rep = reply('currentdump:'.$sdom.':'.$sname.':'.$courseid,$uhome);
      }
   
    return if ($rep =~ /^(error:|no_such_host)/);     return if ($rep =~ /^(error:|no_such_host)/);
    #     #
    my %returnhash=();     my %returnhash=();
Line 5206  sub tmpdel { Line 5802  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 5461  sub usertools_access { Line 6139  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 5479  sub usertools_access { Line 6162  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 5563  sub usertools_access { Line 6253  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 5910  sub allowed { Line 6600  sub allowed {
         }          }
     }      }
   
   # User who is not author or co-author might still be able to edit
   # resource of an author in the domain (e.g., if Domain Coordinator).
       if (($priv eq 'eco') && ($thisallowed eq '') && ($env{'request.course.id'}) &&
           (&allowed('mdc',$env{'request.course.id'}))) {
           if ($env{"user.priv.cm./$uri/"}=~/\Q$priv\E\&([^\:]*)/) {
               $thisallowed.=$1;
           }
       }
   
 # Course: uri itself is a course  # Course: uri itself is a course
     my $courseuri=$uri;      my $courseuri=$uri;
     $courseuri=~s/\_(\d)/\/$1/;      $courseuri=~s/\_(\d)/\/$1/;
Line 5930  sub allowed { Line 6629  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 5941  sub allowed { Line 6645  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 5993  sub allowed { Line 6702  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 6021  sub allowed { Line 6740  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 6180  sub allowed { Line 6909  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 6548  sub auto_validate_instcode { Line 7502  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 6915  sub get_users_groups { Line 7869  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 7088  sub assignrole { Line 8041  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 7137  sub assignrole { Line 8125  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 7441  sub modifyuser { Line 8443  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 7456  sub modifystudent { Line 8458  sub modifystudent {
     # students environment      # students 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 7504  sub modify_student_enrollment { Line 8508  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 7519  sub modify_student_enrollment { Line 8525  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 7718  sub generate_coursenum { Line 8733  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 8699  sub EXT { Line 9717  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 8987  sub metadata { Line 9997  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;
     }      }
     if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/})       if (($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) 
  && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {   && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  return undef;   return undef;
     }      }
Line 9028  sub metadata { Line 10038  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) {   if ($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) {
     my $which = &hreflocation('','/'.($liburi || $uri));      my $which = &hreflocation('','/'.($liburi || $uri));
     $metastring =       $metastring = 
  &Apache::lonnet::ssi_body($which,   &Apache::lonnet::ssi_body($which,
Line 9352  sub gettitle { Line 10362  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 9361  sub gettitle { Line 10375  sub gettitle {
     return $title;      return $title;
 }  }
   
   sub getdocspath {
       my ($symb) = @_;
       my $path;
       if ($symb) {
           my ($mapurl,$id,$resurl) = &decode_symb($symb);
           if ($resurl=~/\.(sequence|page)$/) {
               $mapurl=$resurl;
           } elsif ($resurl eq 'adm/navmaps') {
               $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'};
           }
           my $mapresobj;
           my $navmap = Apache::lonnavmaps::navmap->new();
           if (ref($navmap)) {
               $mapresobj = $navmap->getResourceByUrl($mapurl);
           }
           $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1};
           my $type=$2;
           if (ref($mapresobj)) {
               my $pcslist = $mapresobj->map_hierarchy();
               if ($pcslist ne '') {
                   foreach my $pc (split(/,/,$pcslist)) {
                       next if ($pc <= 1);
                       my $res = $navmap->getByMapPc($pc);
                       if (ref($res)) {
                           my $thisurl = $res->src();
                           $thisurl=~s{^.*/([^/]+)\.\w+$}{$1};
                           my $thistitle = $res->title();
                           $path .= '&'.
                                    &Apache::lonhtmlcommon::entity_encode($thisurl).'&'.
                                    &Apache::lonhtmlcommon::entity_encode($thistitle).
                                    ':'.$res->randompick().
                                    ':'.$res->randomout().
                                    ':'.$res->encrypted().
                                    ':'.$res->randomorder().
                                    ':'.$res->is_page();
                       }
                   }
               }
               $path =~ s/^\&//;
               my $maptitle = $mapresobj->title();
               if ($mapurl eq 'default') {
                   $maptitle = 'Main Course Documents';
               }
               $path .= ($path ne '')? '&' : ''.
                       &Apache::lonhtmlcommon::entity_encode($mapurl).'&'.
                       &Apache::lonhtmlcommon::entity_encode($maptitle).
                       ':'.$mapresobj->randompick().
                       ':'.$mapresobj->randomout().
                       ':'.$mapresobj->encrypted().
                       ':'.$mapresobj->randomorder().
                       ':'.$mapresobj->is_page();
           } else {
               my $maptitle = &gettitle($mapurl);
               my $ispage;
               if ($mapurl =~ /\.page$/) {
                   $ispage = 1;
               }
               if ($mapurl eq 'default') {
                   $maptitle = 'Main Course Documents';
               }
               $path = &Apache::lonhtmlcommon::entity_encode($mapurl).'&'.
                       &Apache::lonhtmlcommon::entity_encode($maptitle).':::::'.$ispage;
           }
           unless ($mapurl eq 'default') {
               $path = 'default&'.
                       &Apache::lonhtmlcommon::entity_encode('Main Course Documents').
                       ':::::&'.$path;
           }
       }
       return $path;
   }
   
 sub get_slot {  sub get_slot {
     my ($which,$cnum,$cdom)=@_;      my ($which,$cnum,$cdom)=@_;
     if (!$cnum || !$cdom) {      if (!$cnum || !$cdom) {
Line 9384  sub get_slot { Line 10470  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 9411  sub symblist { Line 10575  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 9430  sub symbverify { Line 10594  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 (ref($encstate)) {
                          $$encstate = $bighash{'encrypted_'.$id};
                      }
    if (($env{'request.role.adv'}) ||     if (($env{'request.role.adv'}) ||
        ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||         ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
                        ($thisurl eq '/adm/navmaps')) {                         ($thisurl eq '/adm/navmaps')) {
        $okay=1;          $okay=1;
                          last;
    }     }
        }         }
    }     }
Line 9527  sub deversion { Line 10706  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'});
  }   }
Line 9749  sub rndseed { Line 10932  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 9759  sub rndseed { Line 10944  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') {
Line 10085  sub getfile { Line 11269  sub getfile {
   
 sub repcopy_userfile {  sub repcopy_userfile {
     my ($file)=@_;      my ($file)=@_;
     if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }      my $londocroot = $perlvar{'lonDocRoot'};
     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'ok'; }      if ($file =~ m{^/*(uploaded|editupload)/}) { $file=&filelocation("",$file); }
       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 10215  sub filelocation { Line 11400  sub filelocation {
  $file=~s-^/adm/coursedocs/showdoc/-/-;   $file=~s-^/adm/coursedocs/showdoc/-/-;
     }      }
   
     if ($file=~m:^/~:) { # is a contruction space reference      if ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
         $location = $file;  
         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;  
     } elsif ($file=~m{^/home/$match_username/public_html/}) {  
  # is a correct contruction space reference  
         $location = $file;  
     } elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {  
         $location = $file;          $location = $file;
     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file      } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
         my ($udom,$uname,$filename)=          my ($udom,$uname,$filename)=
Line 10240  sub filelocation { Line 11419  sub filelocation {
  $location = $perlvar{'lonDocRoot'}.'/'.$file;   $location = $perlvar{'lonDocRoot'}.'/'.$file;
     } else {      } else {
         $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;          $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
         $file=~s:^/res/:/:;          $file=~s:^/(res|priv)/:/:;
           my $space=$1;
         if ( !( $file =~ m:^/:) ) {          if ( !( $file =~ m:^/:) ) {
             $location = $dir. '/'.$file;              $location = $dir. '/'.$file;
         } else {          } else {
             $location = '/home/httpd/html/res'.$file;              $location = $perlvar{'lonDocRoot'}.'/'.$space.$file;
         }          }
     }      }
     $location=~s://+:/:g; # remove duplicate /      $location=~s://+:/:g; # remove duplicate /
Line 10269  sub hreflocation { Line 11449  sub hreflocation {
     }      }
     if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {      if ($file=~m-^\Q$perlvar{'lonDocRoot'}\E-) {
  $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;   $file=~s-^\Q$perlvar{'lonDocRoot'}\E--;
     } elsif ($file=~m-/home/($match_username)/public_html/-) {  
  $file=~s-^/home/($match_username)/public_html/-/~$1/-;  
     } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {      } elsif ($file=~m-^\Q$perlvar{'lonUsersDir'}\E-) {
  $file=~s-^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/   $file=~s{^/home/httpd/lonUsers/($match_domain)/./././($match_name)/userfiles/}
     -/uploaded/$1/$2/-x;          {/uploaded/$1/$2/}x;
     }      }
     if ($file=~ m{^/userfiles/}) {      if ($file=~ m{^/userfiles/}) {
  $file =~ s{^/userfiles/}{/uploaded/};   $file =~ s{^/userfiles/}{/uploaded/};
Line 10281  sub hreflocation { Line 11459  sub hreflocation {
     return $file;      return $file;
 }  }
   
   
   
   
   
 sub current_machine_domains {  sub current_machine_domains {
     return &machine_domains(&hostname($perlvar{'lonHostID'}));      return &machine_domains(&hostname($perlvar{'lonHostID'}));
 }  }
Line 10346  sub declutter { Line 11528  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 10445  sub goodbye { Line 11628  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 10475  sub get_dns { Line 11658  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 10484  sub get_dns { Line 11669  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 10796  sub get_dns { Line 12034  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 10854  sub get_dns { Line 12092  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 11024  $readit=1; Line 12262  $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 11264  B<idput($udom,%ids)>: store away a list Line 12513  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 11305  allowed($priv,$uri,$symb,$role) : check Line 12560  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 11321  environment).  If no custom name is defi Line 12591  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 11335  of role statuses (active, future or prev Line 12605  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 11427  Inputs: Line 12732  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 11472  Inputs: Line 12779  Inputs:
   
 =item $context  =item $context
   
   =item $credits, number of credits student will earn from this class
   
 =back  =back
   
   
Line 11537  data base, returning a hash that is keye Line 12846  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.
   
   
 =back  =back
   
 =head2 Course Modification  =head2 Course Modification
Line 11557  createcourse($udom,$description,$url,$co Line 12865  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 11625  returns the data handle Line 12946  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 11683  expirespread($uname,$udom,$stype,$usymb) Line 13006  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 12238  Internal notes: Line 13589  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 12255  Returns: Line 13608  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.1138  
changed lines
  Added in v.1.1222

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