loncom/lonnet/perl/lonnet.pm - diff

Return to lonnet.pm CVS log

Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1056.4.35 and 1.1176

-version 1.1056.4.35, 2012/01/08 22:58:21
+version 1.1176, 2012/05/30 20:29:45
  Line 75  use LWP::UserAgent();
  use HTTP::Date;
  use Image::Magick;
+ use Encode;
  use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
              $_64bit %env %protocol %loncaparevs %serverhomeIDs %needsrelease
              %managerstab);
- Line 96  use Math::Random;
+ Line 98  use Math::Random;
  use File::MMagic;
  use LONCAPA qw(:DEFAULT :match);
  use LONCAPA::Configuration;
+ use LONCAPA::lonmetadata;
+ use LONCAPA::Lond;
  use File::Copy;
  my $readit;
- Line 288  sub get_server_homeID {
+ Line 293  sub get_server_homeID {
      }
      my $cachetime = 12*3600;
      my $serverhomeID;
      if ($caller eq 'loncron') {
          my @machine_ids = &machine_ids($hostname);
          foreach my $id (@machine_ids) {
              my $response = &reply('serverhomeID',$id);
- Line 306  sub get_server_homeID {
+ Line 311  sub get_server_homeID {
      return &do_cache_new('serverhomeID',$hostname,$serverhomeID,$cachetime);
  }
+ sub get_remote_globals {
+     my ($lonhost,$whathash,$ignore_cache) = @_;
+     my ($result,%returnhash,%whatneeded);
+     if (ref($whathash) eq 'HASH') {
+         foreach my $what (sort(keys(%{$whathash}))) {
+             my $hashid = $lonhost.'-'.$what;
+             my ($response,$cached);
+             unless ($ignore_cache) {
+                 ($response,$cached)=&is_cached_new('lonnetglobal',$hashid);
+             }
+             if (defined($cached)) {
+                 $returnhash{$what} = $response;
+             } else {
+                 $whatneeded{$what} = 1;
+             }
+         }
+         if (keys(%whatneeded) == 0) {
+             $result = 'ok';
+         } else {
+             my $requested = &freeze_escape(\%whatneeded);
+             my $rep=&reply('readlonnetglobal:'.$requested,$lonhost);
+             if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
+                 ($rep eq 'unknown_cmd')) {
+                 $result = $rep;
+             } else {
+                 $result = 'ok';
+                 my @pairs=split(/\&/,$rep);
+                 foreach my $item (@pairs) {
+                     my ($key,$value)=split(/=/,$item,2);
+                     my $what = &unescape($key);
+                     my $hashid = $lonhost.'-'.$what;
+                     $returnhash{$what}=&thaw_unescape($value);
+                     &do_cache_new('lonnetglobal',$hashid,$returnhash{$what},600);
+                 }
+             }
+         }
+     }
+     return ($result,\%returnhash);
+ }
+ sub remote_devalidate_cache {
+     my ($lonhost,$name,$id) = @_;
+     my $response = &reply('devalidatecache:'.&escape($name).':'.&escape($id),$lonhost);
+     return $response;
+ }
  # -------------------------------------------------- Non-critical communication
  sub subreply {
      my ($cmd,$server)=@_;
- Line 548  sub transfer_profile_to_env {
+ Line 599  sub transfer_profile_to_env {
  # ---------------------------------------------------- Check for valid session
  sub check_for_valid_session {
-     my ($r) = @_;
+     my ($r,$name) = @_;
      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);
      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");
      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
- Line 636  sub appenv {
+ Line 695  sub appenv {
  # ----------------------------------------------------- Delete from Environment
  sub delenv {
-     my ($delthis,$regexp) = @_;
+     my ($delthis,$regexp,$roles) = @_;
-     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
+     if (($delthis=~/^user\.role/) || ($delthis=~/^user\.priv/)) {
-         &logthis("<font color=\"blue\">WARNING: ".
+         my $refused = 1;
-                 "Attempt to delete from environment ".$delthis);
+         if (ref($roles) eq 'ARRAY') {
-         return 'error';
+             my ($type,$role) = ($delthis =~ /^user\.(role|priv)\.([^.]+)\./);
+             if (grep(/^\Q$role\E$/,@{$roles})) {
+                 $refused = 0;
+             }
+         }
+         if ($refused) {
+             &logthis("<font color=\"blue\">WARNING: ".
+                      "Attempt to delete from environment ".$delthis);
+             return 'error';
+         }
      }
      my $opened = open(my $env_file,'+<',$env{'user.environment'});
      if ($opened
- Line 749  sub userload {
+ Line 817  sub userload {
      return $userloadpercent;
  }
- # ------------------------------------------ Fight off request when overloaded
- sub overloaderror {
-     my ($r,$checkserver)=@_;
-     unless ($checkserver) { $checkserver=$perlvar{'lonHostID'}; }
-     my $loadavg;
-     if ($checkserver eq $perlvar{'lonHostID'}) {
-        open(my $loadfile,'/proc/loadavg');
-        $loadavg=<$loadfile>;
-        $loadavg =~ s/\s.*//g;
-        $loadavg = 100*$loadavg/$perlvar{'lonLoadLim'};
-        close($loadfile);
-     } else {
-        $loadavg=&reply('load',$checkserver);
-     }
-     my $overload=$loadavg-100;
-     if ($overload>0) {
- 	$r->err_headers_out->{'Retry-After'}=$overload;
-         $r->log_error('Overload of '.$overload.' on '.$checkserver);
-         return 413;
-     }
-     return '';
- }
  # ------------------------------ Find server with least workload from spare.tab
  sub spareserver {
- Line 788  sub spareserver {
+ Line 832  sub spareserver {
          my %udomdefaults = &Apache::lonnet::get_domain_defaults($udom);
          $remotesessions = $udomdefaults{'remotesessions'};
      }
-     foreach my $try_server (@{ $spareid{'primary'} }) {
+     my $spareshash = &this_host_spares($udom);
-         if ($uint_dom) {
+     if (ref($spareshash) eq 'HASH') {
-             next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
+         if (ref($spareshash->{'primary'}) eq 'ARRAY') {
-                                          $try_server));
+             foreach my $try_server (@{ $spareshash->{'primary'} }) {
+                 if ($uint_dom) {
+                     next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
+                                                  $try_server));
+                 }
+ 	        ($spare_server, $lowest_load) =
+ 	            &compare_server_load($try_server, $spare_server, $lowest_load);
+             }
          }
- 	($spare_server, $lowest_load) =
- 	    &compare_server_load($try_server, $spare_server, $lowest_load);
-     }
-     my $found_server = ($spare_server ne '' && $lowest_load < 100);
-     if (!$found_server) {
+         my $found_server = ($spare_server ne '' && $lowest_load < 100);
- 	foreach my $try_server (@{ $spareid{'default'} }) {
-             if ($uint_dom) {
+         if (!$found_server) {
-                 next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
+             if (ref($spareshash->{'default'}) eq 'ARRAY') {
-                                              $try_server));
+ 	        foreach my $try_server (@{ $spareshash->{'default'} }) {
-             }
+                     if ($uint_dom) {
- 	    ($spare_server, $lowest_load) =
+                         next unless (&spare_can_host($udom,$uint_dom,
- 		&compare_server_load($try_server, $spare_server, $lowest_load);
+                                                      $remotesessions,$try_server));
- 	}
+                     }
+ 	            ($spare_server, $lowest_load) =
+ 		        &compare_server_load($try_server, $spare_server, $lowest_load);
+                 }
+ 	    }
+         }
      }
      if (!$want_server_name) {
- Line 832  sub compare_server_load {
+ Line 883  sub compare_server_load {
      my $userloadans = &reply('userload',$try_server);
      if ($loadans !~ /\d/ && $userloadans !~ /\d/) {
-         return ($spare_server, $lowest_load); #didn't get a number from the server
+ 	return ($spare_server, $lowest_load); #didn't get a number from the server
      }
      my $load;
- Line 858  sub compare_server_load {
+ Line 909  sub compare_server_load {
  # --------------------------- ask offload servers if user already has a session
  sub find_existing_session {
      my ($udom,$uname) = @_;
-     foreach my $try_server (@{ $spareid{'primary'} },
+     my $spareshash = &this_host_spares($udom);
- 			    @{ $spareid{'default'} }) {
+     if (ref($spareshash) eq 'HASH') {
- 	return $try_server if (&has_user_session($try_server, $udom, $uname));
+         if (ref($spareshash->{'primary'}) eq 'ARRAY') {
+             foreach my $try_server (@{ $spareshash->{'primary'} }) {
+                 return $try_server if (&has_user_session($try_server, $udom, $uname));
+             }
+         }
+         if (ref($spareshash->{'default'}) eq 'ARRAY') {
+             foreach my $try_server (@{ $spareshash->{'default'} }) {
+                 return $try_server if (&has_user_session($try_server, $udom, $uname));
+             }
+         }
      }
      return;
  }
- Line 882  sub choose_server {
+ Line 942  sub choose_server {
      my %domconfhash = &Apache::loncommon::get_domainconf($udom);
      my %servers = &get_servers($udom);
      my $lowest_load = 30000;
-     my ($login_host,$hostname,$portal_path);
+     my ($login_host,$hostname,$portal_path,$isredirect);
      foreach my $lonhost (keys(%servers)) {
          my $loginvia;
          if ($checkloginvia) {
- Line 890  sub choose_server {
+ Line 950  sub choose_server {
              if ($loginvia) {
                  my ($server,$path) = split(/:/,$loginvia);
                  ($login_host, $lowest_load) =
-                     &compare_server_load($lonhost, $login_host, $lowest_load);
+                     &compare_server_load($server, $login_host, $lowest_load);
                  if ($login_host eq $server) {
                      $portal_path = $path;
+                     $isredirect = 1;
                  }
              } else {
                  ($login_host, $lowest_load) =
                      &compare_server_load($lonhost, $login_host, $lowest_load);
                  if ($login_host eq $lonhost) {
                      $portal_path = '';
+                     $isredirect = '';
                  }
              }
          } else {
- Line 909  sub choose_server {
+ Line 971  sub choose_server {
      if ($login_host ne '') {
          $hostname = &hostname($login_host);
      }
-     return ($login_host,$hostname,$portal_path);
+     return ($login_host,$hostname,$portal_path,$isredirect);
  }
  # --------------------------------------------- Try to change a user's password
- Line 1093  sub spare_can_host {
+ Line 1155  sub spare_can_host {
      return $canhost;
  }
+ sub this_host_spares {
+     my ($dom) = @_;
+     my ($dom_in_use,$lonhost_in_use,$result);
+     my @hosts = &current_machine_ids();
+     foreach my $lonhost (@hosts) {
+         if (&host_domain($lonhost) eq $dom) {
+             $dom_in_use = $dom;
+             $lonhost_in_use = $lonhost;
+             last;
+         }
+     }
+     if ($dom_in_use ne '') {
+         $result = &spares_for_offload($dom_in_use,$lonhost_in_use);
+     }
+     if (ref($result) ne 'HASH') {
+         $lonhost_in_use = $perlvar{'lonHostID'};
+         $dom_in_use = &host_domain($lonhost_in_use);
+         $result = &spares_for_offload($dom_in_use,$lonhost_in_use);
+         if (ref($result) ne 'HASH') {
+             $result = \%spareid;
+         }
+     }
+     return $result;
+ }
+ sub spares_for_offload  {
+     my ($dom_in_use,$lonhost_in_use) = @_;
+     my ($result,$cached)=&is_cached_new('spares',$dom_in_use);
+     if (defined($cached)) {
+         return $result;
+     } else {
+         my $cachetime = 60*60*24;
+         my %domconfig =
+             &Apache::lonnet::get_dom('configuration',['usersessions'],$dom_in_use);
+         if (ref($domconfig{'usersessions'}) eq 'HASH') {
+             if (ref($domconfig{'usersessions'}{'spares'}) eq 'HASH') {
+                 if (ref($domconfig{'usersessions'}{'spares'}{$lonhost_in_use}) eq 'HASH') {
+                     return &do_cache_new('spares',$dom_in_use,$domconfig{'usersessions'}{'spares'}{$lonhost_in_use},$cachetime);
+                 }
+             }
+         }
+     }
+     return;
+ }
+ sub get_lonbalancer_config {
+     my ($servers) = @_;
+     my ($currbalancer,$currtargets);
+     if (ref($servers) eq 'HASH') {
+         foreach my $server (keys(%{$servers})) {
+             my %what = (
+                          spareid => 1,
+                          perlvar => 1,
+                        );
+             my ($result,$returnhash) = &get_remote_globals($server,\%what);
+             if ($result eq 'ok') {
+                 if (ref($returnhash) eq 'HASH') {
+                     if (ref($returnhash->{'perlvar'}) eq 'HASH') {
+                         if ($returnhash->{'perlvar'}->{'lonBalancer'} eq 'yes') {
+                             $currbalancer = $server;
+                             $currtargets = {};
+                             if (ref($returnhash->{'spareid'}) eq 'HASH') {
+                                 if (ref($returnhash->{'spareid'}->{'primary'}) eq 'ARRAY') {
+                                     $currtargets->{'primary'} = $returnhash->{'spareid'}->{'primary'};
+                                 }
+                                 if (ref($returnhash->{'spareid'}->{'default'}) eq 'ARRAY') {
+                                     $currtargets->{'default'} = $returnhash->{'spareid'}->{'default'};
+                                 }
+                             }
+                             last;
+                         }
+                     }
+                 }
+             }
+         }
+     }
+     return ($currbalancer,$currtargets);
+ }
+ sub check_loadbalancing {
+     my ($uname,$udom) = @_;
+     my ($is_balancer,$dom_in_use,$homeintdom,$rule_in_effect,
+         $offloadto,$otherserver);
+     my $lonhost = $perlvar{'lonHostID'};
+     my @hosts = &current_machine_ids();
+     my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
+     my $uintdom = &Apache::lonnet::internet_dom($uprimary_id);
+     my $intdom = &Apache::lonnet::internet_dom($lonhost);
+     my $serverhomedom = &host_domain($lonhost);
+     my $cachetime = 60*60*24;
+     if (($uintdom ne '') && ($uintdom eq $intdom)) {
+         $dom_in_use = $udom;
+         $homeintdom = 1;
+     } else {
+         $dom_in_use = $serverhomedom;
+     }
+     my ($result,$cached)=&is_cached_new('loadbalancing',$dom_in_use);
+     unless (defined($cached)) {
+         my %domconfig =
+             &Apache::lonnet::get_dom('configuration',['loadbalancing'],$dom_in_use);
+         if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
+             $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
+         }
+     }
+     if (ref($result) eq 'HASH') {
+         my $currbalancer = $result->{'lonhost'};
+         my $currtargets = $result->{'targets'};
+         my $currrules = $result->{'rules'};
+         if ($currbalancer ne '') {
+             if (grep(/^\Q$currbalancer\E$/,@hosts)) {
+                 $is_balancer = 1;
+             }
+         }
+         if ($is_balancer) {
+             if (ref($currrules) eq 'HASH') {
+                 if ($homeintdom) {
+                     if ($uname ne '') {
+                         if (($currrules->{'_LC_adv'} ne '') || ($currrules->{'_LC_author'} ne '')) {
+                             my ($is_adv,$is_author) = &is_advanced_user($udom,$uname);
+                             if (($currrules->{'_LC_author'} ne '') && ($is_author)) {
+                                 $rule_in_effect = $currrules->{'_LC_author'};
+                             } elsif (($currrules->{'_LC_adv'} ne '') && ($is_adv)) {
+                                 $rule_in_effect = $currrules->{'_LC_adv'}
+                             }
+                         }
+                         if ($rule_in_effect eq '') {
+                             my %userenv = &userenvironment($udom,$uname,'inststatus');
+                             if ($userenv{'inststatus'} ne '') {
+                                 my @statuses = map { &unescape($_); } split(/:/,$userenv{'inststatus'});
+                                 my ($othertitle,$usertypes,$types) =
+                                     &Apache::loncommon::sorted_inst_types($udom);
+                                 if (ref($types) eq 'ARRAY') {
+                                     foreach my $type (@{$types}) {
+                                         if (grep(/^\Q$type\E$/,@statuses)) {
+                                             if (exists($currrules->{$type})) {
+                                                 $rule_in_effect = $currrules->{$type};
+                                             }
+                                         }
+                                     }
+                                 }
+                             } else {
+                                 if (exists($currrules->{'default'})) {
+                                     $rule_in_effect = $currrules->{'default'};
+                                 }
+                             }
+                         }
+                     } else {
+                         if (exists($currrules->{'default'})) {
+                             $rule_in_effect = $currrules->{'default'};
+                         }
+                     }
+                 } else {
+                     if ($currrules->{'_LC_external'} ne '') {
+                         $rule_in_effect = $currrules->{'_LC_external'};
+                     }
+                 }
+                 $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets,
+                                                        $uname,$udom);
+             }
+         }
+     } elsif (($homeintdom) && ($udom ne $serverhomedom)) {
+         my ($result,$cached)=&is_cached_new('loadbalancing',$serverhomedom);
+         unless (defined($cached)) {
+             my %domconfig =
+                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$serverhomedom);
+             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
+                 $result = &do_cache_new('loadbalancing',$dom_in_use,$domconfig{'loadbalancing'},$cachetime);
+             }
+         }
+         if (ref($result) eq 'HASH') {
+             my $currbalancer = $result->{'lonhost'};
+             my $currtargets = $result->{'targets'};
+             my $currrules = $result->{'rules'};
+             if ($currbalancer eq $lonhost) {
+                 $is_balancer = 1;
+                 if (ref($currrules) eq 'HASH') {
+                     if ($currrules->{'_LC_internetdom'} ne '') {
+                         $rule_in_effect = $currrules->{'_LC_internetdom'};
+                     }
+                 }
+                 $offloadto = &get_loadbalancer_targets($rule_in_effect,$currtargets,
+                                                        $uname,$udom);
+             }
+         } else {
+             if ($perlvar{'lonBalancer'} eq 'yes') {
+                 $is_balancer = 1;
+                 $offloadto = &this_host_spares($dom_in_use);
+             }
+         }
+     } else {
+         if ($perlvar{'lonBalancer'} eq 'yes') {
+             $is_balancer = 1;
+             $offloadto = &this_host_spares($dom_in_use);
+         }
+     }
+     if ($is_balancer) {
+         my $lowest_load = 30000;
+         if (ref($offloadto) eq 'HASH') {
+             if (ref($offloadto->{'primary'}) eq 'ARRAY') {
+                 foreach my $try_server (@{$offloadto->{'primary'}}) {
+                     ($otherserver,$lowest_load) =
+                         &compare_server_load($try_server,$otherserver,$lowest_load);
+                 }
+             }
+             my $found_server = ($otherserver ne '' && $lowest_load < 100);
+             if (!$found_server) {
+                 if (ref($offloadto->{'default'}) eq 'ARRAY') {
+                     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) =
+                         &compare_server_load($try_server,$otherserver,$lowest_load);
+                 }
+             }
+         }
+         if (($otherserver ne '') && (grep(/^\Q$otherserver\E$/,@hosts))) {
+             $is_balancer = 0;
+             if ($uname ne '' && $udom ne '') {
+                 if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
+                     &appenv({'user.loadbalexempt'     => $lonhost,
+                              'user.loadbalcheck.time' => time});
+                 }
+             }
+         }
+     }
+     return ($is_balancer,$otherserver);
+ }
+ sub get_loadbalancer_targets {
+     my ($rule_in_effect,$currtargets,$uname,$udom) = @_;
+     my $offloadto;
+     if ($rule_in_effect eq 'none') {
+         return [$perlvar{'lonHostID'}];
+     } elsif ($rule_in_effect eq '') {
+         $offloadto = $currtargets;
+     } else {
+         if ($rule_in_effect eq 'homeserver') {
+             my $homeserver = &homeserver($uname,$udom);
+             if ($homeserver ne 'no_host') {
+                 $offloadto = [$homeserver];
+             }
+         } elsif ($rule_in_effect eq 'externalbalancer') {
+             my %domconfig =
+                 &Apache::lonnet::get_dom('configuration',['loadbalancing'],$udom);
+             if (ref($domconfig{'loadbalancing'}) eq 'HASH') {
+                 if ($domconfig{'loadbalancing'}{'lonhost'} ne '') {
+                     if (&hostname($domconfig{'loadbalancing'}{'lonhost'}) ne '') {
+                         $offloadto = [$domconfig{'loadbalancing'}{'lonhost'}];
+                     }
+                 }
+             } else {
+                 my %servers = &dom_servers($udom);
+                 my ($remotebalancer,$remotetargets) = &get_lonbalancer_config(\%servers);
+                 if (&hostname($remotebalancer) ne '') {
+                     $offloadto = [$remotebalancer];
+                 }
+             }
+         } elsif (&hostname($rule_in_effect) ne '') {
+             $offloadto = [$rule_in_effect];
+         }
+     }
+     return $offloadto;
+ }
+ sub internet_dom_servers {
+     my ($dom) = @_;
+     my (%uniqservers,%servers);
+     my $primaryserver = &hostname(&domain($dom,'primary'));
+     my @machinedoms = &machine_domains($primaryserver);
+     foreach my $mdom (@machinedoms) {
+         my %currservers = %servers;
+         my %server = &get_servers($mdom);
+         %servers = (%currservers,%server);
+     }
+     my %by_hostname;
+     foreach my $id (keys(%servers)) {
+         push(@{$by_hostname{$servers{$id}}},$id);
+     }
+     foreach my $hostname (sort(keys(%by_hostname))) {
+         if (@{$by_hostname{$hostname}} > 1) {
+             my $match = 0;
+             foreach my $id (@{$by_hostname{$hostname}}) {
+                 if (&host_domain($id) eq $dom) {
+                     $uniqservers{$id} = $hostname;
+                     $match = 1;
+                 }
+             }
+             unless ($match) {
+                 $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
+             }
+         } else {
+             $uniqservers{$by_hostname{$hostname}[0]} = $hostname;
+         }
+     }
+     return %uniqservers;
+ }
  # ---------------------- Find the homebase for a user from domain's lib servers
  my %homecache;
- Line 1180  sub idput {
+ Line 1552  sub idput {
  # ------------------------------dump from db file owned by domainconfig user
  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
- Line 1803  sub getsection {
+ Line 2172  sub getsection {
      # If there is a role which has expired, return it.
      #
      $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)) {
          next if ($key !~/^\Q$courseid\E(?:\/)*(\w+)*\_st$/);
          my $section=$1;
- Line 1870  sub is_cached_new {
+ Line 2238  sub is_cached_new {
      my ($name,$id,$debug) = @_;
      $id=&make_key($name,$id);
      if (exists($remembered{$id})) {
- 	if ($debug) { &Apache::lonnet::logthis("Earyl return $id of $remembered{$id} "); }
+ 	if ($debug) { &Apache::lonnet::logthis("Early return $id of $remembered{$id} "); }
  	$accessed{$id}=[&gettimeofday()];
  	$hits++;
  	return ($remembered{$id},1);
- Line 2036  sub getversion {
+ Line 2404  sub getversion {
  sub currentversion {
      my $fname=shift;
-     my ($result,$cached)=&is_cached_new('resversion',$fname);
-     if (defined($cached)) { return $result; }
      my $author=$fname;
      $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
      my ($udom,$uname)=split(/\//,$author);
-     my $home=homeserver($uname,$udom);
+     my $home=&homeserver($uname,$udom);
      if ($home eq 'no_host') {
          return -1;
      }
-     my $answer=reply("currentversion:$fname",$home);
+     my $answer=&reply("currentversion:$fname",$home);
      if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
  	return -1;
      }
-     return &do_cache_new('resversion',$fname,$answer,600);
+     return $answer;
+ }
+ #
+ # Return special version number of resource if set by override, empty otherwise
+ #
+ sub usedversion {
+     my $fname=shift;
+     unless ($fname) { $fname=$env{'request.uri'}; }
+     my ($urlversion)=($fname=~/\.(\d+)\.\w+$/);
+     if ($urlversion) { return $urlversion; }
+     return '';
  }
  # ----------------------------- Subscribe to a resource, return URL if possible
- Line 2077  sub subscribe {
+ Line 2454  sub subscribe {
  sub repcopy {
      my $filename=shift;
      $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);
      }
      $filename=~s/[\n\r]//g;
- Line 2107  sub repcopy {
+ Line 2485  sub repcopy {
          unless ($home eq $perlvar{'lonHostID'}) {
             my @parts=split(/\//,$filename);
             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");
  	       return 'bad_request';
             }
- Line 2206  sub ssi {
+ Line 2584  sub ssi {
      }
      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
-     my $response=$ua->request($request);
+     my $response= $ua->request($request);
+     my $content = Encode::decode_utf8($response->content);
      if (wantarray) {
- 	return ($response->content, $response);
+ 	return ($content, $response);
      } else {
- 	return $response->content;
+ 	return $content;
      }
  }
- Line 2311  sub process_coursefile {
+ Line 2689  sub process_coursefile {
                  }
                  if (ref($mimetype)) {
                      $$mimetype = $type;
                  }
              }
              $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                   $home);
- Line 2429  sub resizeImage {
+ Line 2807  sub resizeImage {
  # input: $formname - the contents of the file are in $env{"form.$formname"}
  #                    the desired filename is in $env{"form.$formname.filename"}
  #        $context - possible values: coursedoc, existingfile, overwrite,
  #                                    canceloverwrite, or ''.
  #                   if 'coursedoc': upload to the current course
  #                   if 'existingfile': write file to tmp/overwrites directory
  #                   if 'canceloverwrite': delete file written to tmp/overwrites directory
  #                   $context is passed as argument to &finishuserfileupload
  #        $subdir - directory in userfile to store the file into
  #        $parser - instruction to parse file for objects ($parser = parse)
  #        $allfiles - reference to hash for embedded objects
- Line 2445  sub resizeImage {
+ Line 2823  sub resizeImage {
  #        $resizewidth - width (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
- #                    from File::MMagic if $parser = parse.
+ #                    from File::MMagic.
  #
  # output: url of file in userspace, or error: <message>
  #             or /adm/notfound.html if failure to upload occurse
- Line 2585  sub finishuserfileupload {
+ Line 2963  sub finishuserfileupload {
  	    return '/adm/notfound.html';
  	}
          if ($context eq 'overwrite') {
-             my $source =  $perlvar{'lonDaemons'}.'/tmp/overwrites/'.$docudom.'/'.$docuname.'/'.$fname;
+             my $source =  LONCAPA::tempdir().'/overwrites/'.$docudom.'/'.$docuname.'/'.$fname;
              my $target = $filepath.'/'.$file;
              if (-e $source) {
                  my @info = stat($source);
                  if ($info[9] eq $env{'form.timestamp'}) {
                      unless (&File::Copy::move($source,$target)) {
                          &logthis('Failed to overwrite '.$filepath.'/'.$file);
                          return "Moving from $source failed";
- Line 2600  sub finishuserfileupload {
+ Line 2978  sub finishuserfileupload {
              } else {
                  return "Temporary file: $source missing";
              }
- 	} elsif (!print FH ($env{'form.'.$formname})) {
+         } elsif (!print FH ($env{'form.'.$formname})) {
  	    &logthis('Failed to write to '.$filepath.'/'.$file);
  	    print STDERR ('Failed to write to '.$filepath.'/'.$file."\n");
  	    return '/adm/notfound.html';
- Line 2614  sub finishuserfileupload {
+ Line 2992  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') {
-         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,
                                                         $allfiles,$codebase);
              unless ($parse_result eq 'ok') {
- Line 2625  sub finishuserfileupload {
+ Line 3010  sub finishuserfileupload {
  	   	         ' for embedded media: '.$parse_result);
              }
          }
-         if (ref($mimetype)) {
-             $$mimetype = $type;
-         }
      }
      if (($thumbwidth =~ /^\d+$/) && ($thumbheight =~ /^\d+$/)) {
          my $input = $filepath.'/'.$file;
- Line 2664  sub finishuserfileupload {
+ Line 3046  sub finishuserfileupload {
  sub extract_embedded_items {
      my ($fullpath,$allfiles,$codebase,$content) = @_;
      my @state = ();
+     my (%lastids,%related,%shockwave,%flashvars);
      my %javafiles = (
                        codebase => '',
                        code => '',
- Line 2693  sub extract_embedded_items {
+ Line 3076  sub extract_embedded_items {
  		&add_filetype($allfiles,$attr->{'href'},'href');
  	    }
              if (lc($tagname) eq 'script') {
+                 my $src;
                  if ($attr->{'archive'} =~ /\.jar$/i) {
                      &add_filetype($allfiles,$attr->{'archive'},'archive');
                  } 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') {
- Line 2709  sub extract_embedded_items {
+ Line 3112  sub extract_embedded_items {
  		foreach my $item (keys(%javafiles)) {
  		    $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') {
  		my $name = lc($attr->{'name'});
- Line 2718  sub extract_embedded_items {
+ Line 3124  sub extract_embedded_items {
  			last;
  		    }
  		}
+                 my $pathfrom;
  		foreach my $item (keys(%mediafiles)) {
  		    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;
  		    }
  		}
+                 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') {
  		foreach my $item (keys(%javafiles)) {
- Line 2738  sub extract_embedded_items {
+ Line 3154  sub extract_embedded_items {
  			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') {
  	    my ($tagname) = ($t->[1]);
  	    if ($javafiles{'codebase'} ne '') {
- Line 2758  sub extract_embedded_items {
+ Line 3183  sub extract_embedded_items {
  	    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';
  }
- Line 2772  sub add_filetype {
+ Line 3214  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 {
      my ($url)=@_;
      my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
- Line 2898  sub flushcourselogs {
+ Line 3355  sub flushcourselogs {
              my $result = &inc('nohist_accesscount',\%temphash,$dom,$name);
              if ($result eq 'ok') {
                  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 {
              my ($dom,$name) = ($entry=~m{___($match_domain)/($match_name)/(.*)___(\w+)$});
+             if (($dom eq 'uploaded') || ($dom eq 'adm')) { next; }
              my %temphash=($entry => $accesshash{$entry});
              if (&put('nohist_resevaldata',\%temphash,$dom,$name) eq 'ok') {
                  delete $accesshash{$entry};
- Line 2985  sub courseacclog {
+ Line 3437  sub courseacclog {
      my $fnsymb=shift;
      unless ($env{'request.course.id'}) { return ''; }
      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';
          # FIXME: Probably ought to escape things....
  	foreach my $key (keys(%env)) {
- Line 3017  sub countacc {
+ Line 3469  sub countacc {
      my $url=&declutter(shift);
      return if (! defined($url) || $url eq '');
      unless ($env{'request.course.id'}) { return ''; }
+ #
+ # Mark that this url was used in this course
+ #
      $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';
      $accesshash{$key}++;
  }
- Line 3029  sub linklog {
+ Line 3487  sub linklog {
      $accesshash{$from.'___'.$to.'___comefrom'}=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 {
      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);
         $userrolehash
           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                      =$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
           {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                      =$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);
         $domainrolehash
           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
- Line 3161  sub get_my_roles {
+ Line 3625  sub get_my_roles {
      unless (defined($uname)) { $uname=$env{'user.name'}; }
      unless (defined($udom)) { $udom=$env{'user.domain'}; }
      my (%dumphash,%nothide);
      if ($context eq 'userroles') {
-         my $extra = &freeze_escape({'skipcheck' => 1});
+         %dumphash = &dump('roles',$udom,$uname);
-         %dumphash = &dump('roles',$udom,$uname,'.',undef,$extra);
      } else {
          %dumphash=
              &dump('nohist_userroles',$udom,$uname);
- Line 3184  sub get_my_roles {
+ Line 3647  sub get_my_roles {
      foreach my $entry (keys(%dumphash)) {
          my ($role,$tend,$tstart);
          if ($context eq 'userroles') {
+             next if ($entry =~ /^rolesdef/);
  	    ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
          } else {
              ($tend,$tstart)=split(/\:/,$dumphash{$entry});
- Line 3223  sub get_my_roles {
+ Line 3687  sub get_my_roles {
                      if (!grep(/^cr$/,@{$roles})) {
                          next;
                      }
+                 } elsif ($role =~ /^gr\//) {
+                     if (!grep(/^gr$/,@{$roles})) {
+                         next;
+                     }
                  } else {
                      next;
                  }
- Line 3491  sub get_domain_roles {
+ Line 3959  sub get_domain_roles {
      return %personnel;
  }
- # ----------------------------------------------------------- Check out an item
+ # ----------------------------------------------------------- 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 {
-     my ($type,$argsymb)=@_;
+     my ($type,$argsymb,$argmap)=@_;
      my ($symb,$courseid,$udom,$uname)=&whichuser();
      if ($argsymb) { $symb=$argsymb; }
      my ($map,$id,$res)=&decode_symb($symb);
+     if ($argmap) { $map = $argmap; }
      if ($type eq 'course') {
  	$res='course';
      } elsif ($type eq 'map') {
- Line 3505  sub get_first_access {
+ Line 3996  sub get_first_access {
      } else {
  	$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 {
-     my ($type)=@_;
+     my ($type,$interval)=@_;
      my ($symb,$courseid,$udom,$uname)=&whichuser();
      my ($map,$id,$res)=&decode_symb($symb);
      if ($type eq 'course') {
- Line 3520  sub set_first_access {
+ Line 4011  sub set_first_access {
      } else {
  	$res=$symb;
      }
-     my $firstaccess=&get_first_access($type,$symb);
+     $cachedkey='';
+     my $firstaccess=&get_first_access($type,$symb,$map);
      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';
  }
- sub checkout {
-     my ($symb,$tuname,$tudom,$tcrsid)=@_;
-     my $now=time;
-     my $lonhost=$perlvar{'lonHostID'};
-     my $infostr=&escape(
-                  'CHECKOUTTOKEN&'.
-                  $tuname.'&'.
-                  $tudom.'&'.
-                  $tcrsid.'&'.
-                  $symb.'&'.
- 		 $now.'&'.$ENV{'REMOTE_ADDR'});
-     my $token=&reply('tmpput:'.$infostr,$lonhost);
-     if ($token=~/^error\:/) {
-         &logthis("<font color=\"blue\">WARNING: ".
-                 "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
-                  "</font>");
-         return '';
-     }
-     $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
-     $token=~tr/a-z/A-Z/;
-     my %infohash=('resource.0.outtoken' => $token,
-                   'resource.0.checkouttime' => $now,
-                   'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
-     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
-        return '';
-     } else {
-         &logthis("<font color=\"blue\">WARNING: ".
-                 "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
-                  "</font>");
-     }
-     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
-                          &escape('Checkout '.$infostr.' - '.
-                                                  $token)) ne 'ok') {
- 	return '';
-     } else {
-         &logthis("<font color=\"blue\">WARNING: ".
-                 "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
-                  "</font>");
-     }
-     return $token;
  }
- # ------------------------------------------------------------ Check in an item
- sub checkin {
-     my $token=shift;
-     my $now=time;
-     my ($ta,$tb,$lonhost)=split(/\*/,$token);
-     $lonhost=~tr/A-Z/a-z/;
-     my $dtoken=$ta.'_'.&hostname($lonhost).'_'.$tb;
-     $dtoken=~s/\W/\_/g;
-     my ($dummy,$tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
-                  split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
-     unless (($tuname) && ($tudom)) {
-         &logthis('Check in '.$token.' ('.$dtoken.') failed');
-         return '';
-     }
-     unless (&allowed('mgr',$tcrsid)) {
-         &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
-                  $env{'user.name'}.' - '.$env{'user.domain'});
-         return '';
-     }
-     my %infohash=('resource.0.intoken' => $token,
-                   'resource.0.checkintime' => $now,
-                   'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
-     unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
-        return '';
-     }
-     if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
-                          &escape('Checkin - '.$token)) ne 'ok') {
- 	return '';
-     }
-     return ($symb,$tuname,$tudom,$tcrsid);
- }
  # --------------------------------------------- Set Expire Date for Spreadsheet
  sub expirespread {
- Line 3716  sub hashref2str {
+ Line 4136  sub hashref2str {
        $result.='=';
        #print("Got a ref of ".(ref($key))." skipping.");
      } else {
-         if (defined($key)) {$result.=&escape($key).'=';} else { last; }
+ 	if (defined($key)) {$result.=&escape($key).'=';} else { last; }
      }
      if(ref($hashref->{$key}) eq 'ARRAY') {
- Line 3868  sub tmpreset {
+ Line 4288  sub tmpreset {
    if ($domain eq 'public' && $stuname eq 'public') {
        $stuname=$ENV{'REMOTE_ADDR'};
    }
-   my $path=$perlvar{'lonDaemons'}.'/tmp';
+   my $path=LONCAPA::tempdir();
    my %hash;
    if (tie(%hash,'GDBM_File',
  	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
- Line 3907  sub tmpstore {
+ Line 4327  sub tmpstore {
    }
    my $now=time;
    my %hash;
-   my $path=$perlvar{'lonDaemons'}.'/tmp';
+   my $path=LONCAPA::tempdir();
    if (tie(%hash,'GDBM_File',
  	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
  	  &GDBM_WRCREAT(),0640)) {
- Line 3953  sub tmprestore {
+ Line 4373  sub tmprestore {
    $namespace=~s/\//\_/g;
    $namespace=~s/\W//g;
    my %hash;
-   my $path=$perlvar{'lonDaemons'}.'/tmp';
+   my $path=LONCAPA::tempdir();
    if (tie(%hash,'GDBM_File',
  	  $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
  	  &GDBM_READER(),0640)) {
- Line 4090  sub restore {
+ Line 4510  sub restore {
  }
  # ---------------------------------------------------------- Course Description
+ #
+ #
  sub coursedescription {
      my ($courseid,$args)=@_;
- Line 4119  sub coursedescription {
+ Line 4541  sub coursedescription {
  	return %returnhash;
      }
-     # get the data agin
+     # get the data again
      if (!$args->{'one_time'}) {
  	$envhash{'course.'.$normalid.'.last_cache'}=time;
      }
- Line 4127  sub coursedescription {
+ Line 4550  sub coursedescription {
      if ($chome ne 'no_host') {
         %returnhash=&dump('environment',$cdomain,$cnum);
         if (!exists($returnhash{'con_lost'})) {
+ 	   my $username = $env{'user.name'}; # Defult username
+ 	   if(defined $args->{'user'}) {
+ 	       $username = $args->{'user'};
+ 	   }
             $returnhash{'home'}= $chome;
  	   $returnhash{'domain'} = $cdomain;
  	   $returnhash{'num'} = $cnum;
- Line 4137  sub coursedescription {
+ Line 4564  sub coursedescription {
                 $envhash{'course.'.$normalid.'.'.$name}=$value;
             }
             $returnhash{'url'}=&clutter($returnhash{'url'});
-            $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
+            $returnhash{'fn'}=LONCAPA::tempdir() .
- 	       $env{'user.name'}.'_'.$cdomain.'_'.$cnum;
+ 	       $username.'_'.$cdomain.'_'.$cnum;
             $envhash{'course.'.$normalid.'.home'}=$chome;
             $envhash{'course.'.$normalid.'.domain'}=$cdomain;
             $envhash{'course.'.$normalid.'.num'}=$cnum;
- Line 4192  sub update_released_required {
+ Line 4619  sub update_released_required {
  sub privileged {
      my ($username,$domain)=@_;
-     my $rolesdump=&reply("dump:$domain:$username:roles",
- 			&homeserver($username,$domain));
+     my %rolesdump = &dump("roles", $domain, $username) or return 0;
-     if (($rolesdump eq 'con_lost') || ($rolesdump eq '') ||
+     my $now = time;
-         ($rolesdump =~ /^error:/)) {
-         return 0;
+     for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
-     }
+             my ($trole, $tend, $tstart) = split(/_/, $role);
-     my $now=time;
+             if (($trole eq 'dc') || ($trole eq 'su')) {
-     if ($rolesdump ne '') {
+                 return 1 unless ($tend && $tend < $now)
-         foreach my $entry (split(/&/,$rolesdump)) {
+                     or ($tstart && $tstart > $now);
- 	    if ($entry!~/^rolesdef_/) {
+             }
- 		my ($area,$role)=split(/=/,$entry);
- 		$area=~s/\_\w\w$//;
- 		my ($trole,$tend,$tstart)=split(/_/,$role);
- 		if (($trole eq 'dc') || ($trole eq 'su')) {
- 		    my $active=1;
- 		    if ($tend) {
- 			if ($tend<$now) { $active=0; }
- 		    }
- 		    if ($tstart) {
- 			if ($tstart>$now) { $active=0; }
- 		    }
- 		    if ($active) { return 1; }
- 		}
- 	    }
  	}
-     }
      return 0;
  }
  # -------------------------------------------------------- Get user privileges
  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 %allgroups=();
-     my $group_privs;
-     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);
-                 ($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 {
- Line 4356  sub set_userprivs {
+ Line 4815  sub set_userprivs {
      my $adv=0;
      my %grouproles = ();
      if (keys(%{$allgroups}) > 0) {
          my @groupkeys;
          foreach my $role (keys(%{$allroles})) {
              push(@groupkeys,$role);
          }
- Line 4404  sub set_userprivs {
+ Line 4863  sub set_userprivs {
              }
          }
          my $thesestr='';
-         foreach my $priv (keys(%thesepriv)) {
+         foreach my $priv (sort(keys(%thesepriv))) {
  	    $thesestr.=':'.$priv.'&'.$thesepriv{$priv};
  	}
          $userroles->{'user.priv.'.$role} = $thesestr;
- Line 4413  sub set_userprivs {
+ Line 4872  sub set_userprivs {
  }
  sub role_status {
-     my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
+     my ($rolekey,$update,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
      my @pwhere = ();
      if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
          (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
- Line 4422  sub role_status {
+ Line 4881  sub role_status {
              $$trolecode=$$role.'.'.$$where;
              ($$tstart,$$tend)=split(/\./,$env{$rolekey});
              $$tstatus='is';
-             if ($$tstart && $$tstart>$then) {
+             if ($$tstart && $$tstart>$update) {
                  $$tstatus='future';
                  if ($$tstart<$now) {
                      if ($$tstart && $$tstart>$refresh) {
- Line 4432  sub role_status {
+ Line 4891  sub role_status {
                              my %userroles = (
                                  'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
                              );
                              @rolecodes = ('cm');
                              my $spec=$$role.'.'.$$where;
                              my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
                              if ($$role =~ /^cr\//) {
- Line 4447  sub role_status {
+ Line 4906  sub role_status {
                                  $group_privs = &unescape($group_privs);
                                  &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
                                  my %course_roles = &get_my_roles($env{'user.name'},$env{'user.domain'},'userroles',['active'],['cc','co','in','ta','ep','ad','st','cr'],[$tdomain],1);
-                                 if (keys(%course_roles) > 0) {
+                                 &get_groups_roles($tdomain,$trest,
-                                     my ($tnum) = ($trest =~ /^($match_courseid)/);
+                                                   \%course_roles,\@rolecodes,
-                                     if ($tdomain ne '' && $tnum ne '') {
+                                                   \%groups_roles);
-                                         foreach my $key (keys(%course_roles)) {
-                                             if ($key =~ /^\Q$tnum\E:\Q$tdomain\E:([^:]+):?([^:]*)/) {
-                                                 my $crsrole = $1;
-                                                 my $crssec = $2;
-                                                 if ($crsrole =~ /^cr/) {
-                                                     unless (grep(/^cr$/,@rolecodes)) {
-                                                         push(@rolecodes,'cr');
-                                                     }
-                                                 } else {
-                                                     unless(grep(/^\Q$crsrole\E$/,@rolecodes)) {
-                                                         push(@rolecodes,$crsrole);
-                                                     }
-                                                 }
-                                                 my $rolekey = $crsrole.'./'.$tdomain.'/'.$tnum;
-                                                 if ($crssec ne '') {
-                                                     $rolekey .= '/'.$crssec;
-                                                 }
-                                                 $rolekey .= './';
-                                                 $groups_roles{$rolekey} = \@rolecodes;
-                                             }
-                                         }
-                                     }
-                                 }
                              } else {
                                  push(@rolecodes,$$role);
                                  &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
- Line 4486  sub role_status {
+ Line 4922  sub role_status {
                  }
              }
              if ($$tend) {
-                 if ($$tend<$then) {
+                 if ($$tend<$update) {
                      $$tstatus='expired';
                  } elsif ($$tend<$now) {
                      $$tstatus='will_not';
- Line 4496  sub role_status {
+ Line 4932  sub role_status {
      }
  }
+ sub get_groups_roles {
+     my ($cdom,$rest,$cdom_courseroles,$rolecodes,$groups_roles) = @_;
+     return unless((ref($cdom_courseroles) eq 'HASH') &&
+                   (ref($rolecodes) eq 'ARRAY') &&
+                   (ref($groups_roles) eq 'HASH'));
+     if (keys(%{$cdom_courseroles}) > 0) {
+         my ($cnum) = ($rest =~ /^($match_courseid)/);
+         if ($cdom ne '' && $cnum ne '') {
+             foreach my $key (keys(%{$cdom_courseroles})) {
+                 if ($key =~ /^\Q$cnum\E:\Q$cdom\E:([^:]+):?([^:]*)/) {
+                     my $crsrole = $1;
+                     my $crssec = $2;
+                     if ($crsrole =~ /^cr/) {
+                         unless (grep(/^cr$/,@{$rolecodes})) {
+                             push(@{$rolecodes},'cr');
+                         }
+                     } else {
+                         unless(grep(/^\Q$crsrole\E$/,@{$rolecodes})) {
+                             push(@{$rolecodes},$crsrole);
+                         }
+                     }
+                     my $rolekey = "$crsrole./$cdom/$cnum";
+                     if ($crssec ne '') {
+                         $rolekey .= "/$crssec";
+                     }
+                     $rolekey .= './';
+                     $groups_roles->{$rolekey} = $rolecodes;
+                 }
+             }
+         }
+     }
+     return;
+ }
+ sub delete_env_groupprivs {
+     my ($where,$courseroles,$possroles) = @_;
+     return unless((ref($courseroles) eq 'HASH') && (ref($possroles) eq 'ARRAY'));
+     my ($dummy,$udom,$uname,$group) = split(/\//,$where);
+     unless (ref($courseroles->{$udom}) eq 'HASH') {
+         %{$courseroles->{$udom}} =
+             &get_my_roles('','','userroles',['active'],
+                           $possroles,[$udom],1);
+     }
+     if (ref($courseroles->{$udom}) eq 'HASH') {
+         foreach my $item (keys(%{$courseroles->{$udom}})) {
+             my ($cnum,$cdom,$crsrole,$crssec) = split(/:/,$item);
+             my $area = '/'.$cdom.'/'.$cnum;
+             my $privkey = "user.priv.$crsrole.$area";
+             if ($crssec ne '') {
+                 $privkey .= '/'.$crssec;
+             }
+             $privkey .= ".$area/$group";
+             &Apache::lonnet::delenv($privkey,undef,[$crsrole]);
+         }
+     }
+     return;
+ }
  sub check_adhoc_privs {
-     my ($cdom,$cnum,$then,$refresh,$now,$checkrole,$caller) = @_;
+     my ($cdom,$cnum,$update,$refresh,$now,$checkrole,$caller) = @_;
      my $cckey = 'user.role.'.$checkrole.'./'.$cdom.'/'.$cnum;
      if ($env{$cckey}) {
          my ($role,$where,$trolecode,$tstart,$tend,$tremark,$tstatus,$tpstart,$tpend);
-         &role_status($cckey,$then,$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')) {
              &set_adhoc_privileges($cdom,$cnum,$checkrole,$caller);
          }
- Line 4580  sub del {
+ Line 5074  sub del {
  # -------------------------------------------------------------- dump interface
  sub dump {
-     my ($namespace,$udomain,$uname,$regexp,$range,$extra)=@_;
+     my ($namespace,$udomain,$uname,$regexp,$range)=@_;
      if (!$udomain) { $udomain=$env{'user.domain'}; }
      if (!$uname) { $uname=$env{'user.name'}; }
      my $uhome=&homeserver($uname,$udomain);
      if ($regexp) {
  	$regexp=&escape($regexp);
      } else {
  	$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 %returnhash=();
-     foreach my $item (@pairs) {
+     if (!($rep =~ /^error/ )) {
- 	my ($key,$value)=split(/=/,$item,2);
+ 	foreach my $item (@pairs) {
- 	$key = &unescape($key);
+ 	    my ($key,$value)=split(/=/,$item,2);
- 	next if ($key =~ /^error: 2 /);
+ 	    $key = &unescape($key);
- 	$returnhash{$key}=&thaw_unescape($value);
+ 	    next if ($key =~ /^error: 2 /);
+ 	    $returnhash{$key}=&thaw_unescape($value);
+ 	}
      }
      return %returnhash;
  }
  # --------------------------------------------------------- dumpstore interface
  sub dumpstore {
- Line 4883  sub tmpget {
+ Line 5381  sub tmpget {
      return %returnhash;
  }
- # ------------------------------------------------------------ tmpget interface
+ # ------------------------------------------------------------ tmpdel interface
  sub tmpdel {
      my ($token,$server)=@_;
      if (!defined($server)) { $server = $perlvar{'lonHostID'}; }
- Line 5134  sub is_portfolio_file {
+ Line 5632  sub is_portfolio_file {
  }
  sub usertools_access {
-     my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref) = @_;
+     my ($uname,$udom,$tool,$action,$context,$userenvref,$domdefref,$is_advref)=@_;
      my ($access,%tools);
      if ($context eq '') {
          $context = 'tools';
- Line 5281  sub is_advanced_user {
+ Line 5779  sub is_advanced_user {
      my ($udom,$uname) = @_;
      if ($udom ne '' && $uname ne '') {
          if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
-             return $env{'user.adv'};
+             if (wantarray) {
+                 return ($env{'user.adv'},$env{'user.author'});
+             } else {
+                 return $env{'user.adv'};
+             }
          }
      }
      my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
      my %allroles;
-     my $is_adv;
+     my ($is_adv,$is_author);
      foreach my $role (keys(%roleshash)) {
          my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
          my $area = '/'.$tdomain.'/'.$trest;
- Line 5300  sub is_advanced_user {
+ Line 5802  sub is_advanced_user {
              } elsif ($trole ne 'gr') {
                  &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
              }
+             if ($trole eq 'au') {
+                 $is_author = 1;
+             }
          }
      }
      foreach my $role (keys(%allroles)) {
- Line 5314  sub is_advanced_user {
+ Line 5819  sub is_advanced_user {
              }
          }
      }
+     if (wantarray) {
+         return ($is_adv,$is_author);
+     }
      return $is_adv;
  }
- Line 5584  sub allowed {
+ Line 6092  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
      my $courseuri=$uri;
      $courseuri=~s/\_(\d)/\/$1/;
- Line 5604  sub allowed {
+ Line 6121  sub allowed {
          if ($match) {
              if ($env{'user.priv.'.$env{'request.role'}.'./'}
                    =~/\Q$priv\E\&([^\:]*)/) {
-                 $thisallowed.=$1;
+                 my @blockers = &has_comm_blocking($priv,$symb,$uri);
+                 if (@blockers > 0) {
+                     $thisallowed = 'B';
+                 } else {
+                     $thisallowed.=$1;
+                 }
              }
          } else {
              my $refuri = $env{'httpref.'.$orguri} || $env{'httpref.'.$ver_orguri};
- Line 5615  sub allowed {
+ Line 6137  sub allowed {
                      $refuri=&declutter($refuri);
                      my ($match) = &is_on_map($refuri);
                      if ($match) {
-                         $thisallowed='F';
+                         my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+                         if (@blockers > 0) {
+                             $thisallowed = 'B';
+                         } else {
+                             $thisallowed='F';
+                         }
                      }
                  }
              }
- Line 5667  sub allowed {
+ Line 6194  sub allowed {
             $statecond=$cond;
             if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                 =~/\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;
             }
         }
- Line 5695  sub allowed {
+ Line 6232  sub allowed {
                my $refstatecond=$cond;
                if ($env{'user.priv.'.$env{'request.role'}.'./'.$courseprivid}
                    =~/\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;
                    $statecond=$refstatecond;
                }
- Line 5799  sub allowed {
+ Line 6346  sub allowed {
         my $unamedom=$env{'user.name'}.':'.$env{'user.domain'};
         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.roles.denied'}
  	   =~/\Q$rolecode\E/) {
-            if (($priv ne 'pch') && ($priv ne 'plc')) {
+ 	   if (($priv ne 'pch') && ($priv ne 'plc')) {
  	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
  			$env{'request.course.id'});
- Line 5809  sub allowed {
+ Line 6356  sub allowed {
         if ($env{'course.'.$env{'request.course.id'}.'.'.$priv.'.users.denied'}
  	   =~/\Q$unamedom\E/) {
-            if (($priv ne 'pch') && ($priv ne 'plc')) {
+ 	   if (($priv ne 'pch') && ($priv ne 'plc')) {
  	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.
  			'Denied by user: '.$priv.' for '.$uri.' as '.$unamedom.' in '.
  			$env{'request.course.id'});
- Line 5823  sub allowed {
+ Line 6370  sub allowed {
     if ($thisallowed=~/R/) {
         my $rolecode=(split(/\./,$env{'request.role'}))[0];
         if (&metadata($uri,'roledeny')=~/\Q$rolecode\E/) {
-            if (($priv ne 'pch') && ($priv ne 'plc')) {
+ 	   if (($priv ne 'pch') && ($priv ne 'plc')) {
  	       &logthis($env{'user.domain'}.':'.$env{'user.name'}.':'.$env{'user.home'}.':'.
  			'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
  	   }
- Line 5855  sub allowed {
+ Line 6402  sub allowed {
     return 'F';
  }
+ 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
+ #   splits it in to its filename and path to the filename.
+ #   Seems like File::Basename could have done this more clearly.
+ #   Parameters:
+ #      $uri   - input URI
+ #   Returns:
+ #     Two element list consisting of
+ #     $pathname  - the URI up to and excluding the trailing /
+ #     $filename  - The part of the URI following the last /
+ #  NOTE:
+ #    Another realization of this is simply:
+ #    use File::Basename;
+ #    ...
+ #    $uri = shift;
+ #    $filename = basename($uri);
+ #    $path     = dirname($uri);
+ #    return ($filename, $path);
+ #
+ #     The implementation below is probably faster however.
+ #
  sub split_uri_for_cond {
      my $uri=&deversion(&declutter(shift));
      my @uriparts=split(/\//,$uri);
- Line 6050  sub fetch_enrollment_query {
+ Line 6775  sub fetch_enrollment_query {
                  $$replyref{$key} = $value;
              }
          } else {
-             my $pathname = $perlvar{'lonDaemons'}.'/tmp';
+             my $pathname = LONCAPA::tempdir();
              foreach my $line (@responses) {
                  my ($key,$value) = split(/=/,$line);
                  $$replyref{$key} = $value;
- Line 6080  sub fetch_enrollment_query {
+ Line 6805  sub fetch_enrollment_query {
  sub get_query_reply {
      my $queryid=shift;
-     my $replyfile=$perlvar{'lonDaemons'}.'/tmp/'.$queryid;
+     my $replyfile=LONCAPA::tempdir().$queryid;
      my $reply='';
      for (1..100) {
  	sleep 2;
- Line 6569  sub get_users_groups {
+ Line 7294  sub get_users_groups {
      } else {
          $grouplist = '';
          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.
                                '.default_enrollment_end_date'};
          my $now = time;
- Line 6931  sub modifyuser {
+ Line 7655  sub modifyuser {
      }
      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
               $umode.', '.$first.', '.$middle.', '.
-              $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
+ 	     $last.', '.$gene.'(forceid: '.$forceid.'; candelete: '.$showcandelete.')'.
               (defined($desiredhome) ? ' desiredhome = '.$desiredhome :
                                       ' desiredhome not specified').
               ' by '.$env{'user.name'}.' at '.$env{'user.domain'}.
- Line 7077  sub modifyuser {
+ Line 7801  sub modifyuser {
          return 'ok';
      }
      my $reply = &put('environment', \%names, $udom,$uname);
      if ($reply ne 'ok') {
          return 'error: '.$reply;
      }
      if ($names{'permanentemail'} ne $oldnames{'permanentemail'}) {
- Line 7158  sub modify_student_enrollment {
+ Line 7882  sub modify_student_enrollment {
          $uid    = $tmp{'id'}         if (!defined($uid)    || $uid  eq '');
      }
      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',
- 		   {"$uname:$udom" =>
+ 		   {$user =>
  			join(':',$end,$start,$uid,$usec,$fullname,$type,$locktype) },
  		   $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;
-     } else {
- 	&devalidate_getsection_cache($udom,$uname,$cid);
      }
      # Add student role to user
      my $uurl='/'.$cid;
- Line 7173  sub modify_student_enrollment {
+ Line 7899  sub modify_student_enrollment {
      if ($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 {
- Line 7372  sub generate_coursenum {
+ Line 8107  sub generate_coursenum {
  }
  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 {
- Line 7459  sub is_locked {
+ Line 8197  sub is_locked {
      my ($file_name, $domain, $user, $which) = @_;
      my @check;
      my $is_locked;
-     push(@check,$file_name);
+     push (@check,$file_name);
      my %locked = &get('file_permissions',\@check,
  		      $env{'user.domain'},$env{'user.name'});
      my ($tmp)=keys(%locked);
- Line 7524  sub save_selected_files {
+ Line 8262  sub save_selected_files {
  sub clear_selected_files {
      my ($user) = @_;
      my $filename = $user."savedfiles";
-     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+     open (OUT, '>'.LONCAPA::tempdir().$filename);
      print (OUT undef);
      close (OUT);
      return ("ok");
- Line 7534  sub files_in_path {
+ Line 8272  sub files_in_path {
      my ($user, $path) = @_;
      my $filename = $user."savedfiles";
      my %return_files;
-     open (IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+     open (IN, '<'.LONCAPA::tempdir().$filename);
      while (my $line_in = <IN>) {
          chomp ($line_in);
          my @paths_and_file = split (m!/!, $line_in);
- Line 7556  sub files_not_in_path {
+ Line 8294  sub files_not_in_path {
      my $filename = $user."savedfiles";
      my @return_files;
      my $path_part;
-     open(IN, '<'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);
+     open(IN, '<'.LONCAPA::.$filename);
      while (my $line = <IN>) {
          #ok, I know it's clunky, but I want it to work
          my @paths_and_file = split(m|/|, $line);
- Line 7904  sub dirlist {
+ Line 8642  sub dirlist {
      if($udom) {
          if($uname) {
+             my $uhome = &homeserver($uname,$udom);
+             if ($uhome eq 'no_host') {
+                 return ([],'no_host');
+             }
              $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
                                .$getuserdir.':'.&escape($dirRoot)
-                               .':'.&escape($uname).':'.&escape($udom),
+                               .':'.&escape($uname).':'.&escape($udom),$uhome);
-                               &homeserver($uname,$udom));
              if ($listing eq 'unknown_cmd') {
-                 $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
+                 $listing = &reply('ls2:'.$dirRoot.'/'.$uri,$uhome);
-                                   &homeserver($uname,$udom));
              } else {
                  @listing_results = map { &unescape($_); } split(/:/,$listing);
              }
              if ($listing eq 'unknown_cmd') {
-                 $listing = &reply('ls:'.$dirRoot.'/'.$uri,
+                 $listing = &reply('ls:'.$dirRoot.'/'.$uri,$uhome);
- 				  &homeserver($uname,$udom));
                  @listing_results = split(/:/,$listing);
              } else {
                  @listing_results = map { &unescape($_); } split(/:/,$listing);
              }
-             return @listing_results;
+             if (($listing eq 'no_such_host') || ($listing eq 'con_lost') ||
+                 ($listing eq 'rejected') || ($listing eq 'refused') ||
+                 ($listing eq 'no_such_dir') || ($listing eq 'empty')) {
+                 return ([],$listing);
+             } else {
+                 return (\@listing_results);
+             }
          } elsif(!$alternateRoot) {
-             my %allusers;
+             my (%allusers,%listerror);
  	    my %servers = &get_servers($udom,'library');
   	    foreach my $tryserver (keys(%servers)) {
                  $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
- Line 7942  sub dirlist {
+ Line 8687  sub dirlist {
  		    @listing_results =
  			map { &unescape($_); } split(/:/,$listing);
  		}
- 		if ($listing_results[0] ne 'no_such_dir' &&
+                 if (($listing eq 'no_such_host') || ($listing eq 'con_lost') ||
- 		    $listing_results[0] ne 'empty'       &&
+                     ($listing eq 'rejected') || ($listing eq 'refused') ||
- 		    $listing_results[0] ne 'con_lost') {
+                     ($listing eq 'no_such_dir') || ($listing eq 'empty')) {
+                     $listerror{$tryserver} = $listing;
+                 } else {
  		    foreach my $line (@listing_results) {
  			my ($entry) = split(/&/,$line,2);
  			$allusers{$entry} = 1;
  		    }
  		}
              }
-             my $alluserstr='';
+             my @alluserslist=();
              foreach my $user (sort(keys(%allusers))) {
-                 $alluserstr.=$user.'&user:';
+                 push(@alluserslist,$user.'&user');
              }
-             $alluserstr=~s/:$//;
+             return (\@alluserslist);
-             return split(/:/,$alluserstr);
          } else {
-             return ('missing user name');
+             return ([],'missing username');
          }
      } elsif(!defined($getpropath)) {
-         my @all_domains = sort(&all_domains());
+         my $path = $perlvar{'lonDocRoot'}.'/res/';
-         foreach my $domain (@all_domains) {
+         my @all_domains = map { $path.$_.'/&domain'; } (sort(&all_domains()));
-             $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
+         return (\@all_domains);
-         }
-         return @all_domains;
      } else {
-         return ('missing domain');
+         return ([],'missing domain');
      }
  }
- Line 7980  sub GetFileTimestamp {
+ Line 8724  sub GetFileTimestamp {
      my ($studentDomain,$studentName,$filename,$getuserdir)=@_;
      $studentDomain = &LONCAPA::clean_domain($studentDomain);
      $studentName   = &LONCAPA::clean_username($studentName);
-     my ($fileStat) =
+     my ($fileref,$error) = &dirlist($filename,$studentDomain,$studentName,
-         &Apache::lonnet::dirlist($filename,$studentDomain,$studentName,
+                                     undef,$getuserdir);
-                                  undef,$getuserdir);
+     if (($error eq 'empty') || ($error eq 'no_such_dir')) {
-     my @stats = split('&', $fileStat);
+         return -1;
-     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
+     }
+     if (ref($fileref) eq 'ARRAY') {
+         my @stats = split('&',$fileref->[0]);
          # @stats contains first the filename, then the stat output
          return $stats[10]; # so this is 10 instead of 9.
      } else {
- Line 8016  sub stat_file {
+ Line 8762  sub stat_file {
      if ($file =~ /^userfiles\//) {
          $getpropath = 1;
      }
-     my ($result) = &dirlist($file,$udom,$uname,$getpropath);
+     my ($listref,$error) = &dirlist($file,$udom,$uname,$getpropath);
-     my @stats = split('&', $result);
+     if (($error eq 'empty') || ($error eq 'no_such_dir')) {
+         return ();
-     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
+     } else {
- 	shift(@stats); #filename is first
+         if (ref($listref) eq 'ARRAY') {
- 	return @stats;
+             my @stats = split('&',$listref->[0]);
+ 	    shift(@stats); #filename is first
+ 	    return @stats;
+         }
      }
      return ();
  }
- Line 8342  sub EXT {
+ Line 9091  sub EXT {
     } elsif ($realm eq 'request') {
  # ------------------------------------------------------------- request.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
          } else {
              return $env{'request.'.$spacequalifierrest};
- Line 8623  sub add_prefix_and_part {
+ Line 9364  sub add_prefix_and_part {
  # ---------------------------------------------------------------- Get metadata
  my %metaentry;
+ my %importedpartids;
  sub metadata {
      my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
      $uri=&declutter($uri);
- Line 8633  sub metadata {
+ Line 9375  sub metadata {
          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
  	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)$/) {
  	return undef;
      }
- Line 8649  sub metadata {
+ Line 9391  sub metadata {
  	if (defined($cached)) { return $result->{':'.$what}; }
      }
      {
+ # Imported parts would go here
+         my %importedids=();
+         my @origfileimportpartids=();
+         my $importedparts=0;
  #
  # Is this a recursive call for a library?
  #
- Line 8666  sub metadata {
+ Line 9412  sub metadata {
          my %metathesekeys=();
          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  	my $metastring;
- 	if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) {
+ 	if ($uri =~ /^priv/ || $uri=~/home\/httpd\/html\/priv/) {
  	    my $which = &hreflocation('','/'.($liburi || $uri));
  	    $metastring =
  		&Apache::lonnet::ssi_body($which,
- Line 8733  sub metadata {
+ Line 9479  sub metadata {
  # This is not a package - some other kind of start tag
  #
  		    my $entry=$token->[1];
- 		    my $unikey;
+ 		    my $unikey='';
- 		    if ($entry eq 'import') {
- 			$unikey='';
- 		    } else {
- 			$unikey=$entry;
- 		    }
- 		    $unikey.=&add_prefix_and_part($prefix,$token->[2]->{'part'});
- 		    if (defined($token->[2]->{'id'})) {
- 			$unikey.='_'.$token->[2]->{'id'};
- 		    }
  		    if ($entry eq 'import') {
  #
  # Importing a library here
  #
+                         my $location=$parser->get_text('/import');
+                         my $dir=$filename;
+                         $dir=~s|[^/]*$||;
+                         $location=&filelocation($dir,$location);
+                         my $importmode=$token->[2]->{'importmode'};
+                         if ($importmode eq 'problem') {
+ # Import as problem/response
+                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
+                         } elsif ($importmode eq 'part') {
+ # Import as part(s)
+                            $importedparts=1;
+ # We need to get the original file and the imported file to get the part order correct
+ # Good news: we do not need to worry about nested libraries, since parts cannot be nested
+ # Load and inspect original file
+                            if ($#origfileimportpartids<0) {
+                               undef(%importedpartids);
+                               my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+                               my $origfile=&getfile($origfilelocation);
+                               @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+                            }
+ # Load and inspect imported file
+                            my $impfile=&getfile($location);
+                            my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+                            if ($#impfilepartids>=0) {
+ # This problem had parts
+                                $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
+                            } else {
+ # Importing by turning a single problem into a problem part
+ # It gets the import-tags ID as part-ID
+                                $unikey=&add_prefix_and_part($prefix,$token->[2]->{'id'});
+                                $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
+                            }
+                         } else {
+ # Normal import
+                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
+                            if (defined($token->[2]->{'id'})) {
+                               $unikey.='_'.$token->[2]->{'id'};
+                            }
+                         }
  			if ($depthcount<20) {
- 			    my $location=$parser->get_text('/import');
- 			    my $dir=$filename;
- 			    $dir=~s|[^/]*$||;
- 			    $location=&filelocation($dir,$location);
  			    my $metadata =
  				&metadata($uri,'keys', $location,$unikey,
  					  $depthcount+1);
- Line 8761  sub metadata {
+ Line 9535  sub metadata {
  				$metaentry{':'.$meta}=$metaentry{':'.$meta};
  				$metathesekeys{$meta}=1;
  			    }
- 			}
- 		    } else {
+                         }
+ 		    } else {
+ #
+ # Not importing, some other kind of non-package, non-library start tag
+ #
+                         $unikey=$entry.&add_prefix_and_part($prefix,$token->[2]->{'part'});
+                         if (defined($token->[2]->{'id'})) {
+                             $unikey.='_'.$token->[2]->{'id'};
+                         }
  			if (defined($token->[2]->{'name'})) {
  			    $unikey.='_'.$token->[2]->{'name'};
  			}
- Line 8836  sub metadata {
+ Line 9618  sub metadata {
  	    grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
  	$metaentry{':packages'} = join(',',@uniq_packages);
+         if ($importedparts) {
+ # We had imported parts and need to rebuild partorder
+            $metaentry{':partorder'}='';
+            $metathesekeys{'partorder'}=1;
+            for (my $index=0;$index<$#origfileimportpartids;$index+=2) {
+                if ($origfileimportpartids[$index] eq 'part') {
+ # original part, part of the problem
+                   $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];
+                } else {
+ # we have imported parts at this position
+                   $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};
+                }
+            }
+            $metaentry{':partorder'}=~s/^\,//;
+         }
  	$metaentry{':keys'} = join(',',keys(%metathesekeys));
  	&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  	$metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
- Line 8938  sub gettitle {
+ Line 9736  sub gettitle {
  	}
  	$title=~s/\&colon\;/\:/gs;
  	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);
  	}
  	$urlsymb=$url;
- Line 8970  sub get_slot {
+ Line 9772  sub get_slot {
      }
      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) {
+             &Apache::lonnet::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);
+ }
  # ------------------------------------------------- Update symbolic store links
  sub symblist {
- Line 9020  sub symbverify {
+ Line 9865  sub symbverify {
              $thisurl =~ s/\?.+$//;
          }
          my $ids=$bighash{'ids_'.&clutter($thisurl)};
          unless ($ids) {
-            my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
+             my $idkey = 'ids_'.($thisurl =~ m{^/}? '' : '/').$thisurl;
-            $ids=$bighash{$idkey};
+             $ids=$bighash{$idkey};
          }
          if ($ids) {
  # ------------------------------------------------------------------- Has ID(s)
- Line 9036  sub symbverify {
+ Line 9881  sub symbverify {
     eq $symb) {
  		   if (($env{'request.role.adv'}) ||
  		       ($bighash{'encrypted_'.$id} eq $env{'request.enc'}) ||
- 		       ($thisurl eq '/adm/navmaps')) {
+                        ($thisurl eq '/adm/navmaps')) {
  		       $okay=1;
  		   }
  	       }
- Line 9311  sub getCODE {
+ Line 10156  sub getCODE {
      }
      return undef;
  }
+ #
+ #  Determines the random seed for a specific context:
+ #
+ # parameters:
+ #   symb      - in course context the symb for the seed.
+ #   course_id - The course id of the form domain_coursenum.
+ #   domain    - Domain for the user.
+ #   course    - Course for the user.
+ #   cenv      - environment of the course.
+ #
+ # NOTE:
+ #   All parameters are picked out of the environment if missing
+ #   or not defined.
+ #   If a symb cannot be determined the current time is used instead.
+ #
+ #  For a given well defined symb, courside, domain, username,
+ #  and course environment, the seed is reproducible.
+ #
  sub rndseed {
-     my ($symb,$courseid,$domain,$username)=@_;
+     my ($symb,$courseid,$domain,$username, $cenv)=@_;
      my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
      if (!defined($symb)) {
  	unless ($symb=$wsymb) { return time; }
      }
-     if (!$courseid) { $courseid=$wcourseid; }
+     if (!defined $courseid) {
-     if (!$domain) { $domain=$wdomain; }
+ 	$courseid=$wcourseid;
-     if (!$username) { $username=$wusername }
+     }
-     my $which=&get_rand_alg();
+     if (!defined $domain) { $domain=$wdomain; }
+     if (!defined $username) { $username=$wusername }
+     my $which;
+     if (defined($cenv->{'rndseed'})) {
+ 	$which = $cenv->{'rndseed'};
+     } else {
+ 	$which =&get_rand_alg($courseid);
+     }
      if (defined(&getCODE())) {
  	if ($which eq '64bit5') {
  	    return &rndseed_CODE_64bit5($symb,$courseid,$domain,$username);
  	} elsif ($which eq '64bit4') {
- Line 9647  sub getfile {
+ Line 10517  sub getfile {
  sub repcopy_userfile {
      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) =
  	($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
      my $uri="/uploaded/$cdom/$cnum/$filename";
- Line 9777  sub filelocation {
+ Line 10648  sub filelocation {
  	$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;
      } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
          my ($udom,$uname,$filename)=
- Line 9793  sub filelocation {
+ Line 10658  sub filelocation {
          my @ids=&current_machine_ids();
          foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
          if ($is_me) {
-   	    $location=&propath($udom,$uname).'/userfiles/'.$filename;
+   	    $location=propath($udom,$uname).'/userfiles/'.$filename;
          } else {
    	  $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
    	      $udom.'/'.$uname.'/'.$filename;
- Line 9802  sub filelocation {
+ Line 10667  sub filelocation {
  	$location = $perlvar{'lonDocRoot'}.'/'.$file;
      } else {
          $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
-         $file=~s:^/res/:/:;
+         $file=~s:^/(res|priv)/:/:;
+         my $space=$1;
          if ( !( $file =~ m:^/:) ) {
              $location = $dir. '/'.$file;
          } else {
-             $location = '/home/httpd/html/res'.$file;
+             $location = $perlvar{'lonDocRoot'}.'/'.$space.$file;
          }
      }
      $location=~s://+:/:g; # remove duplicate /
- Line 9831  sub hreflocation {
+ Line 10697  sub hreflocation {
      }
      if ($file=~m-^\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-) {
- 	$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/}) {
  	$file =~ s{^/userfiles/}{/uploaded/};
- Line 9843  sub hreflocation {
+ Line 10707  sub hreflocation {
      return $file;
  }
  sub current_machine_domains {
      return &machine_domains(&hostname($perlvar{'lonHostID'}));
  }
- Line 9908  sub declutter {
+ Line 10776  sub declutter {
      $thisfn=~s|^adm/wrapper/||;
      $thisfn=~s|^adm/coursedocs/showdoc/||;
      $thisfn=~s/^res\///;
+     $thisfn=~s/^priv\///;
      unless (($thisfn =~ /^ext/) || ($thisfn =~ /\.(page|sequence)___\d+___ext/)) {
          $thisfn=~s/\?.+$//;
      }
- Line 10123  sub get_dns {
+ Line 10992  sub get_dns {
  	foreach my $configline (@$file) {
  	    next if ($configline =~ /^(\#|\s*$ )/x);
              chomp($configline);
-             if ($configline =~ /^\^/) {
+ 	    if ($configline =~ /^\^/) {
                  if ($configline =~ /^\^([\w.\-]+)/) {
                      $LC_dns_serv{$1} = 1;
                  }
- Line 10210  sub get_dns {
+ Line 11079  sub get_dns {
      }
      sub unique_library {
-         #2x reverse removes all hostnames that appear more than once
+ 	#2x reverse removes all hostnames that appear more than once
          my %unique = reverse &all_library();
          return reverse %unique;
      }
- Line 10240  sub get_dns {
+ Line 11109  sub get_dns {
      sub get_unique_servers {
          my %unique = reverse &get_servers(@_);
-         return reverse %unique;
+ 	return reverse %unique;
      }
      sub host_domain {
- Line 10565  BEGIN {
+ Line 11434  BEGIN {
  # ------------- set up temporary directory
  {
-     $tmpdir = $perlvar{'lonDaemons'}.'/tmp/';
+     $tmpdir = LONCAPA::tempdir();
  }
- Line 10800  $checkdefauth is optional (value is 1 if
+ Line 11669  $checkdefauth is optional (value is 1 if
     authenticate user using default authentication method, and allow
     account creation if username does not have account in the domain).
  $clientcancheckhost is optional (value is 1 if checking whether the
     server can host will occur on the client side in lonauth.pm).
  =item *
  X<homeserver()>
- Line 10826  B<idput($udom,%ids)>: store away a list
+ Line 11695  B<idput($udom,%ids)>: store away a list
  =item *
  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 *
  X<getsection()>
- Line 11059  revokecustomrole($udom,$uname,$url,$role
+ Line 11934  revokecustomrole($udom,$uname,$url,$role
  =item *
- coursedescription($courseid) : returns a hash of information about the
+ coursedescription($courseid,$options) : returns a hash of information about the
  specified course id, including all environment settings for the
  course, the description of the course will be in the hash under the
  key 'description'
+ $options is an optional parameter that if supplied is a hash reference that controls
+ what how this function works.  It has the following key/values:
+ =over 4
+ =item freshen_cache
+ If defined, and the environment cache for the course is valid, it is
+ returned in the returned hash.
+ =item one_time
+ If defined, the last cache time is set to _now_
+ =item user
+ If defined, the supplied username is used instead of the current user.
+ =back
  =item *
  resdata($name,$domain,$type,@which) : request for current parameter
- Line 11098  createcourse($udom,$description,$url,$co
+ Line 11994  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).
+ =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
  =head2 Resource Subroutines
- Line 11394  or lonTabs/domain.tab.
+ Line 12303  or lonTabs/domain.tab.
  =item *
- dirlist($uri) : return directory list based on URI
+ dirlist() : return directory list based on URI (first arg).
+ Inputs: 1 required, 5 optional.
+ =over
+ =item
+ $uri - path to file in filesystem (starts: /res or /userfiles/). Required.
+ =item
+ $userdomain - domain of user/course to be listed. Extracted from $uri if absent.
+ =item
+ $username -  username of user/course to be listed. Extracted from $uri if absent.
+ =item
+ $getpropath - boolean: 1 if prepend path using &propath().
+ =item
+ $getuserdir - boolean: 1 if prepend path for "userfiles".
+ =item
+ $alternateRoot - path to prepend in place of path from $uri.
+ =back
+ Returns: Array of up to two items.
+ =over
+ a reference to an array of files/subdirectories
+ =over
+ Each element in the array of files/subdirectories is a & separated list of
+ item name and the result of running stat on the item.  If dirlist was requested
+ for a file instead of a directory, the item name will be ''. For a directory
+ listing, if the item is a metadata file, the element will end &N&M
+ (where N amd M are either 0 or 1, corresponding to obsolete set (1), or
+ default copyright set (1).
+ =back
+ a scalar containing error condition (if encountered).
+ =over
+ =item
+ no_host (no homeserver identified for $username:$domain).
+ =item
+ no_such_host (server contacted for listing not identified as valid host).
+ =item
+ con_lost (connection to remote server failed).
+ =item
+ refused (invalid $username:$domain received on lond side).
+ =item
+ no_such_dir (directory at specified path on lond side does not exist).
+ =item
+ empty (directory at specified path on lond side is empty).
+ =over
+ This is currently not encountered because the &ls3, &ls2,
+ &ls (_handler) routines on the lond side do not filter out
+ . and .. from a directory listing.
+ =back
+ =back
+ =back
  =item *
- Line 11456  splitting on '&', supports elements that
+ Line 12440  splitting on '&', supports elements that
  =head2 Logging Routines
  These routines allow one to make log messages in the lonnet.log and
  lonnet.perm logfiles.
- Line 11476  logperm() : append a permanent message t
+ Line 12461  logperm() : append a permanent message t
  file never gets deleted by any automated portion of the system, only
  messages of critical importance should go in here.
  =back
  =head2 General File Helper Routines
- Line 11550  userfileupload(): main rotine for puttin
+ Line 12536  userfileupload(): main rotine for puttin
             the filename is in $env{'form.'.$formname.'.filename'} and the
             contents of the file is located in $env{'form.'.$formname}
   context - if coursedoc, store the file in the course of the active role
               of the current user;
             if 'existingfile': store in 'overwrites' in /home/httpd/perl/tmp
             if 'canceloverwrite': delete file in tmp/overwrites directory
   subdir - required - subdirectory to put the file in under ../userfiles/
- Line 11596  userspace, probably shouldn't be called
+ Line 12582  userspace, probably shouldn't be called
   returns either the url of the uploaded file (/uploaded/....) if successful
   and /adm/notfound.html if unsuccessful (or an error message if context
   was 'overwrite').
  =item *

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

Removed from v.1.1056.4.35
changed lines
	Added in v.1.1176