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

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.860 and 1.1017

version 1.860, 2007/04/03 18:47:29 version 1.1017, 2009/08/15 00:25:53
Line 27 Line 27
 #  #
 ###  ###
   
 package Apache::lonnet;  =pod
   
 use strict;  
 use LWP::UserAgent();  
 use HTTP::Headers;  
 use HTTP::Date;  
 # use Date::Parse;  
 use vars   
 qw(%perlvar %badServerCache %spareid   
    %pr %prp $memcache %packagetab   
    %courselogs %accesshash %userrolehash %domainrolehash $processmarker $dumpcount   
    %coursedombuf %coursenumbuf %coursehombuf %coursedescrbuf %courseinstcodebuf %courseownerbuf %coursetypebuf  
    $tmpdir $_64bit %env);  
   
 use IO::Socket;  =head1 NAME
 use GDBM_File;  
 use HTML::LCParser;  
 use HTML::Parser;  
 use Fcntl qw(:flock);  
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);  
 use Time::HiRes qw( gettimeofday tv_interval );  
 use Cache::Memcached;  
 use Digest::MD5;  
 use Math::Random;  
 use LONCAPA qw(:DEFAULT :match);  
 use LONCAPA::Configuration;  
   
 my $readit;  Apache::lonnet.pm
 my $max_connection_retries = 10;     # Or some such value.  
   
 require Exporter;  =head1 SYNOPSIS
   
 our @ISA = qw (Exporter);  This file is an interface to the lonc processes of
 our @EXPORT = qw(%env);  the LON-CAPA network as well as set of elaborated functions for handling information
   necessary for navigating through a given cluster of LON-CAPA machines within a
   domain. There are over 40 specialized functions in this module which handle the
   reading and transmission of metadata, user information (ids, names, environments, roles,
   logs), file information (storage, reading, directories, extensions, replication, embedded
   styles and descriptors), educational resources (course descriptions, section names and
   numbers), url hashing (to assign roles on a url basis), and translating abbreviated symbols to
   and from more descriptive phrases or explanations.
   
 =pod  This is part of the LearningOnline Network with CAPA project
   described at http://www.lon-capa.org.
   
 =head1 Package Variables  =head1 Package Variables
   
Line 84  delayed. Line 68  delayed.
   
 =cut  =cut
   
   package Apache::lonnet;
   
   use strict;
   use LWP::UserAgent();
   use HTTP::Date;
   use Image::Magick;
   
   use vars qw(%perlvar %spareid %pr %prp $memcache %packagetab $tmpdir
               $_64bit %env %protocol);
   
   my (%badServerCache, $memcache, %courselogs, %accesshash, %domainrolehash,
       %userrolehash, $processmarker, $dumpcount, %coursedombuf,
       %coursenumbuf, %coursehombuf, %coursedescrbuf, %courseinstcodebuf,
       %courseownerbuf, %coursetypebuf,$locknum);
   
   use IO::Socket;
   use GDBM_File;
   use HTML::LCParser;
   use Fcntl qw(:flock);
   use Storable qw(thaw nfreeze);
   use Time::HiRes qw( gettimeofday tv_interval );
   use Cache::Memcached;
   use Digest::MD5;
   use Math::Random;
   use LONCAPA qw(:DEFAULT :match);
   use LONCAPA::Configuration;
   
   my $readit;
   my $max_connection_retries = 10;     # Or some such value.
   
   my $upload_photo_form = 0; #Variable to check  when user upload a photo 0=not 1=true
   
   require Exporter;
   
   our @ISA = qw (Exporter);
   our @EXPORT = qw(%env);
   
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
 {  {
     my $logid;      my $logid;
     sub instructor_log {      sub instructor_log {
  my ($hash_name,$storehash,$delflag,$uname,$udom)=@_;   my ($hash_name,$storehash,$delflag,$uname,$udom,$cnum,$cdom)=@_;
           if (($cnum eq '') || ($cdom eq '')) {
               $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
               $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
           }
  $logid++;   $logid++;
  my $id=time().'00000'.$$.'00000'.$logid;          my $now = time();
    my $id=$now.'00000'.$$.'00000'.$logid;
  return &Apache::lonnet::put('nohist_'.$hash_name,   return &Apache::lonnet::put('nohist_'.$hash_name,
     { $id => {      { $id => {
  'exe_uname' => $env{'user.name'},   'exe_uname' => $env{'user.name'},
  'exe_udom'  => $env{'user.domain'},   'exe_udom'  => $env{'user.domain'},
  'exe_time'  => time(),   'exe_time'  => $now,
  'exe_ip'    => $ENV{'REMOTE_ADDR'},   'exe_ip'    => $ENV{'REMOTE_ADDR'},
  'delflag'   => $delflag,   'delflag'   => $delflag,
  'logentry'  => $storehash,   'logentry'  => $storehash,
  'uname'     => $uname,   'uname'     => $uname,
  'udom'      => $udom,   'udom'      => $udom,
     }      }
   },    },$cdom,$cnum);
     $env{'course.'.$env{'request.course.id'}.'.domain'},  
     $env{'course.'.$env{'request.course.id'}.'.num'}  
     );  
     }      }
 }  }
   
Line 126  sub logthis { Line 149  sub logthis {
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     if (open(my $fh,">>$execdir/logs/lonnet.log")) {      if (open(my $fh,">>$execdir/logs/lonnet.log")) {
  print $fh "$local ($$): $message\n";   my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
    print $fh $logstring;
  close($fh);   close($fh);
     }      }
     return 1;      return 1;
Line 150  sub create_connection { Line 174  sub create_connection {
      Type    => SOCK_STREAM,       Type    => SOCK_STREAM,
      Timeout => 10);       Timeout => 10);
     return 0 if (!$client);      return 0 if (!$client);
     print $client (join(':',$hostname,$lonid,&machine_ids($lonid))."\n");      print $client (join(':',$hostname,$lonid,&machine_ids($hostname))."\n");
     my $result = <$client>;      my $result = <$client>;
     chomp($result);      chomp($result);
     return 1 if ($result eq 'done');      return 1 if ($result eq 'done');
     return 0;      return 0;
 }  }
   
   sub get_server_timezone {
       my ($cnum,$cdom) = @_;
       my $home=&homeserver($cnum,$cdom);
       if ($home ne 'no_host') {
           my $cachetime = 24*3600;
           my ($timezone,$cached)=&is_cached_new('servertimezone',$home);
           if (defined($cached)) {
               return $timezone;
           } else {
               my $timezone = &reply('servertimezone',$home);
               return &do_cache_new('servertimezone',$home,$timezone,$cachetime);
           }
       }
   }
   
   sub get_server_loncaparev {
       my ($dom,$lonhost) = @_;
       if (defined($lonhost)) {
           if (!defined(&hostname($lonhost))) {
               undef($lonhost);
           }
       }
       if (!defined($lonhost)) {
           if (defined(&domain($dom,'primary'))) {
               $lonhost=&domain($dom,'primary');
               if ($lonhost eq 'no_host') {
                   undef($lonhost);
               }
           }
       }
       if (defined($lonhost)) {
           my $cachetime = 24*3600;
           my ($loncaparev,$cached)=&is_cached_new('serverloncaparev',$lonhost);
           if (defined($cached)) {
               return $loncaparev;
           } else {
               my $loncaparev = &reply('serverloncaparev',$lonhost);
               return &do_cache_new('serverloncaparev',$lonhost,$loncaparev,$cachetime);
           }
       }
   }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------- Non-critical communication
 sub subreply {  sub subreply {
Line 182  sub subreply { Line 247  sub subreply {
  $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",   $client=IO::Socket::UNIX->new(Peer    =>"$peerfile",
       Type    => SOCK_STREAM,        Type    => SOCK_STREAM,
       Timeout => 10);        Timeout => 10);
  if($client) {   if ($client) {
     last; # Connected!      last; # Connected!
  } else {   } else {
     &create_connection(&hostname($server),$server);      &create_connection(&hostname($server),$server);
Line 215  sub reply { Line 280  sub reply {
 # ----------------------------------------------------------- Send USR1 to lonc  # ----------------------------------------------------------- Send USR1 to lonc
   
 sub reconlonc {  sub reconlonc {
       my ($lonid) = @_;
       my $hostname = &hostname($lonid);
       if ($lonid) {
    my $peerfile="$perlvar{'lonSockDir'}/$hostname";
    if ($hostname && -e $peerfile) {
       &logthis("Trying to reconnect lonc for $lonid ($hostname)");
       my $client=IO::Socket::UNIX->new(Peer    => $peerfile,
        Type    => SOCK_STREAM,
        Timeout => 10);
       if ($client) {
    print $client ("reset_retries\n");
    my $answer=<$client>;
    #reset just this one.
       }
    }
    return;
       }
   
     &logthis("Trying to reconnect lonc");      &logthis("Trying to reconnect lonc");
     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";      my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
     if (open(my $fh,"<$loncfile")) {      if (open(my $fh,"<$loncfile")) {
Line 303  sub convert_and_load_session_env { Line 386  sub convert_and_load_session_env {
     my ($lonidsdir,$handle)=@_;      my ($lonidsdir,$handle)=@_;
     my @profile;      my @profile;
     {      {
  open(my $idf,"$lonidsdir/$handle.id");   my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
    if (!$opened) {
       return 0;
    }
  flock($idf,LOCK_SH);   flock($idf,LOCK_SH);
  @profile=<$idf>;   @profile=<$idf>;
  close($idf);   close($idf);
Line 342  sub transfer_profile_to_env { Line 428  sub transfer_profile_to_env {
   
     my $convert;      my $convert;
     {      {
     open(my $idf,"$lonidsdir/$handle.id");      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
    if (!$opened) {
       return;
    }
  flock($idf,LOCK_SH);   flock($idf,LOCK_SH);
  if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",   if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
  &GDBM_READER(),0640)) {   &GDBM_READER(),0640)) {
Line 374  sub transfer_profile_to_env { Line 463  sub transfer_profile_to_env {
     }      }
 }  }
   
   # ---------------------------------------------------- Check for valid session 
   sub check_for_valid_session {
       my ($r) = @_;
       my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
       my $lonid=$cookies{'lonID'};
       return undef if (!$lonid);
   
       my $handle=&LONCAPA::clean_handle($lonid->value);
       my $lonidsdir=$r->dir_config('lonIDsDir');
       return undef if (!-e "$lonidsdir/$handle.id");
   
       my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
       return undef if (!$opened);
   
       flock($idf,LOCK_SH);
       my %disk_env;
       if (!tie(%disk_env,'GDBM_File',"$lonidsdir/$handle.id",
       &GDBM_READER(),0640)) {
    return undef;
       }
   
       if (!defined($disk_env{'user.name'})
    || !defined($disk_env{'user.domain'})) {
    return undef;
       }
       return $handle;
   }
   
 sub timed_flock {  sub timed_flock {
     my ($file,$lock_type) = @_;      my ($file,$lock_type) = @_;
     my $failed=0;      my $failed=0;
Line 397  sub timed_flock { Line 514  sub timed_flock {
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------------- Append Environment
   
 sub appenv {  sub appenv {
     my %newenv=@_;      my ($newenv,$roles) = @_;
     foreach my $key (keys(%newenv)) {      if (ref($newenv) eq 'HASH') {
  if (($newenv{$key}=~/^user\.role/) || ($newenv{$key}=~/^user\.priv/)) {          foreach my $key (keys(%{$newenv})) {
             &logthis("<font color=\"blue\">WARNING: ".              my $refused = 0;
                 "Attempt to modify environment ".$key." to ".$newenv{$key}      if (($key =~ /^user\.role/) || ($key =~ /^user\.priv/)) {
                 .'</font>');                  $refused = 1;
     delete($newenv{$key});                  if (ref($roles) eq 'ARRAY') {
         } else {                      my ($type,$role) = ($key =~ /^user\.(role|priv)\.([^.]+)\./);
             $env{$key}=$newenv{$key};                      if (grep(/^\Q$role\E$/,@{$roles})) {
                           $refused = 0;
                       }
                   }
               }
               if ($refused) {
                   &logthis("<font color=\"blue\">WARNING: ".
                            "Attempt to modify environment ".$key." to ".$newenv->{$key}
                            .'</font>');
           delete($newenv->{$key});
               } else {
                   $env{$key}=$newenv->{$key};
               }
           }
           my $opened = open(my $env_file,'+<',$env{'user.environment'});
           if ($opened
       && &timed_flock($env_file,LOCK_EX)
       &&
       tie(my %disk_env,'GDBM_File',$env{'user.environment'},
           (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
       while (my ($key,$value) = each(%{$newenv})) {
           $disk_env{$key} = $value;
       }
       untie(%disk_env);
         }          }
     }  
     open(my $env_file,$env{'user.environment'});  
     if (&timed_flock($env_file,LOCK_EX)  
  &&  
  tie(my %disk_env,'GDBM_File',$env{'user.environment'},  
     (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {  
  while (my ($key,$value) = each(%newenv)) {  
     $disk_env{$key} = $value;  
  }  
  untie(%disk_env);  
     }      }
     return 'ok';      return 'ok';
 }  }
 # ----------------------------------------------------- Delete from Environment  # ----------------------------------------------------- Delete from Environment
   
 sub delenv {  sub delenv {
     my $delthis=shift;      my ($delthis,$regexp) = @_;
     if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {      if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
         &logthis("<font color=\"blue\">WARNING: ".          &logthis("<font color=\"blue\">WARNING: ".
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
         return 'error';          return 'error';
     }      }
     open(my $env_file,$env{'user.environment'});      my $opened = open(my $env_file,'+<',$env{'user.environment'});
     if (&timed_flock($env_file,LOCK_EX)      if ($opened
    && &timed_flock($env_file,LOCK_EX)
  &&   &&
  tie(my %disk_env,'GDBM_File',$env{'user.environment'},   tie(my %disk_env,'GDBM_File',$env{'user.environment'},
     (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {      (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  foreach my $key (keys(%disk_env)) {   foreach my $key (keys(%disk_env)) {
     if ($key=~/^$delthis/) {       if ($regexp) {
                 delete($env{$key});                  if ($key=~/^$delthis/) {
                 delete($disk_env{$key});                      delete($env{$key});
                       delete($disk_env{$key});
                   } 
               } else {
                   if ($key=~/^\Q$delthis\E/) {
       delete($env{$key});
       delete($disk_env{$key});
           }
             }              }
  }   }
  untie(%disk_env);   untie(%disk_env);
Line 459  sub get_env_multiple { Line 597  sub get_env_multiple {
     return(@values);      return(@values);
 }  }
   
   # ------------------------------------------------------------------- Locking
   
   sub set_lock {
       my ($text)=@_;
       $locknum++;
       my $id=$$.'-'.$locknum;
       &appenv({'session.locks' => $env{'session.locks'}.','.$id,
                'session.lock.'.$id => $text});
       return $id;
   }
   
   sub get_locks {
       my $num=0;
       my %texts=();
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if ($lock=~/\w/) {
             $num++;
             $texts{$lock}=$env{'session.lock.'.$lock};
          }
      }
      return ($num,%texts);
   }
   
   sub remove_lock {
       my ($id)=@_;
       my $newlocks='';
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if (($lock=~/\w/) && ($lock ne $id)) {
             $newlocks.=','.$lock;
          }
       }
       &appenv({'session.locks' => $newlocks});
       &delenv('session.lock.'.$id);
   }
   
   sub remove_all_locks {
       my $activelocks=$env{'session.locks'};
       foreach my $lock (split(/\,/,$env{'session.locks'})) {
          if ($lock=~/\w/) {
             &remove_lock($lock);
          }
       }
   }
   
   
 # ------------------------------------------ Find out current server userload  # ------------------------------------------ Find out current server userload
 # there is a copy in lond  
 sub userload {  sub userload {
     my $numusers=0;      my $numusers=0;
     {      {
Line 468  sub userload { Line 650  sub userload {
  my $filename;   my $filename;
  my $curtime=time;   my $curtime=time;
  while ($filename=readdir(LONIDS)) {   while ($filename=readdir(LONIDS)) {
     if ($filename eq '.' || $filename eq '..') {next;}      next if ($filename eq '.' || $filename eq '..');
       next if ($filename =~ /publicuser_\d+\.id/);
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];      my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
     if ($curtime-$mtime < 1800) { $numusers++; }      if ($curtime-$mtime < 1800) { $numusers++; }
  }   }
Line 531  sub spareserver { Line 714  sub spareserver {
     }      }
   
     if (!$want_server_name) {      if (!$want_server_name) {
  $spare_server="http://".&hostname($spare_server);          my $protocol = 'http';
           if ($protocol{$spare_server} eq 'https') {
               $protocol = $protocol{$spare_server};
           }
           if (defined($spare_server)) {
               my $hostname = &hostname($spare_server);
               if (defined($hostname)) {  
           $spare_server = $protocol.'://'.$hostname;
               }
           }
     }      }
     return $spare_server;      return $spare_server;
 }  }
Line 565  sub compare_server_load { Line 757  sub compare_server_load {
     }      }
     return ($spare_server,$lowest_load);      return ($spare_server,$lowest_load);
 }  }
   
   # --------------------------- ask offload servers if user already has a session
   sub find_existing_session {
       my ($udom,$uname) = @_;
       foreach my $try_server (@{ $spareid{'primary'} },
       @{ $spareid{'default'} }) {
    return $try_server if (&has_user_session($try_server, $udom, $uname));
       }
       return;
   }
   
   # -------------------------------- ask if server already has a session for user
   sub has_user_session {
       my ($lonid,$udom,$uname) = @_;
       my $result = &reply(join(':','userhassession',
        map {&escape($_)} ($udom,$uname)),$lonid);
       return 1 if ($result eq 'ok');
   
       return 0;
   }
   
 # --------------------------------------------- Try to change a user's password  # --------------------------------------------- Try to change a user's password
   
 sub changepass {  sub changepass {
Line 619  sub queryauthenticate { Line 832  sub queryauthenticate {
 # --------- Try to authenticate user from domain's lib servers (first this one)  # --------- Try to authenticate user from domain's lib servers (first this one)
   
 sub authenticate {  sub authenticate {
     my ($uname,$upass,$udom)=@_;      my ($uname,$upass,$udom,$checkdefauth)=@_;
     $upass=&escape($upass);      $upass=&escape($upass);
     $uname= &LONCAPA::clean_username($uname);      $uname= &LONCAPA::clean_username($uname);
     my $uhome=&homeserver($uname,$udom,1);      my $uhome=&homeserver($uname,$udom,1);
       my $newhome;
     if ((!$uhome) || ($uhome eq 'no_host')) {      if ((!$uhome) || ($uhome eq 'no_host')) {
 # Maybe the machine was offline and only re-appeared again recently?  # Maybe the machine was offline and only re-appeared again recently?
         &reconlonc();          &reconlonc();
 # One more  # One more
  my $uhome=&homeserver($uname,$udom,1);   $uhome=&homeserver($uname,$udom,1);
           if (($uhome eq 'no_host') && $checkdefauth) {
               if (defined(&domain($udom,'primary'))) {
                   $newhome=&domain($udom,'primary');
               }
               if ($newhome ne '') {
                   $uhome = $newhome;
               }
           }
  if ((!$uhome) || ($uhome eq 'no_host')) {   if ((!$uhome) || ($uhome eq 'no_host')) {
     &logthis("User $uname at $udom is unknown in authenticate");      &logthis("User $uname at $udom is unknown in authenticate");
  }      return 'no_host';
  return 'no_host';          }
     }      }
     my $answer=reply("encrypt:auth:$udom:$uname:$upass",$uhome);      my $answer=reply("encrypt:auth:$udom:$uname:$upass:$checkdefauth",$uhome);
     if ($answer eq 'authorized') {      if ($answer eq 'authorized') {
  &logthis("User $uname at $udom authorized by $uhome");           if ($newhome) {
  return $uhome;               &logthis("User $uname at $udom authorized by $uhome, but needs account");
               return 'no_account_on_host'; 
           } else {
               &logthis("User $uname at $udom authorized by $uhome");
               return $uhome;
           }
     }      }
     if ($answer eq 'non_authorized') {      if ($answer eq 'non_authorized') {
  &logthis("User $uname at $udom rejected by $uhome");   &logthis("User $uname at $udom rejected by $uhome");
Line 671  sub homeserver { Line 898  sub homeserver {
     return 'no_host';      return 'no_host';
 }  }
   
 # ---------------------- Get domain configuration for a domain  
 sub get_domainconf {  
     my ($udom) = @_;  
     my $cachetime=1800;  
     my ($result,$cached)=&is_cached_new('domainconfig',$udom);  
     if (defined($cached)) { return %{$result}; }  
   
     if ($udom eq '') {  
         $udom = &Apache::loncommon::determinedomain();  
     }  
     my %domconfig = &get_dom('configuration',['login','rolecolors'],$udom);  
     my %designhash;  
     if (keys(%domconfig) > 0) {  
         if (ref($domconfig{'login'}) eq 'HASH') {  
             foreach my $key (keys(%{$domconfig{'login'}})) {  
                 $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};  
             }  
         }  
         if (ref($domconfig{'rolecolors'}) eq 'HASH') {  
             foreach my $role (keys(%{$domconfig{'rolecolors'}})) {  
                 if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {  
                     foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {  
                         $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};  
                     }  
                 }  
             }  
         }  
     } else {  
         my $designdir=$perlvar{'lonTabDir'}.'/lonDomColors';  
         my $designfile =  $designdir.'/'.$udom.'.tab';  
         if (-e $designfile) {  
             if ( open (my $fh,"<$designfile") ) {  
                 while (my $line = <$fh>) {  
                     next if ($line =~ /^\#/);  
                     chomp($line);  
                     my ($key,$val)=(split(/\=/,$line));  
                     if ($val) { $designhash{$udom.'.'.$key}=$val; }  
                 }  
                 close($fh);  
             }  
         }  
         if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {  
             $designhash{$udom.'.login.domlogo'} =   
                 &lonhttpdurl("/adm/lonDomLogos/$udom.gif");   
         }  
     }  
     &do_cache_new('domainconfig',$udom,\%designhash,$cachetime);  
     return %designhash;  
 }  
   
 sub devalidate_domconfig_cache {  
     my ($udom)=@_;  
     &devalidate_cache_new('domainconfig',$udom);  
 }  
   
 # ------------------------------------- Find the usernames behind a list of IDs  # ------------------------------------- Find the usernames behind a list of IDs
   
 sub idget {  sub idget {
Line 786  sub idput { Line 958  sub idput {
     }      }
 }  }
   
   # ------------------------------------------------ dump from domain db files
   
   sub dump_dom {
       my ($namespace,$udom,$uhome,$regexp,$range)=@_;
       if (!$udom) {
           $udom=$env{'user.domain'};
           if (defined(&domain($udom,'primary'))) {
               $uhome=&domain($udom,'primary');
           } else {
               undef($uhome);
           }
       } else {
           if (!$uhome) {
               if (defined(&domain($udom,'primary'))) {
                   $uhome=&domain($udom,'primary');
               }
           }
       }
       my %returnhash;
       if ($udom && $uhome && ($uhome ne 'no_host')) {
           if ($regexp) {
               $regexp=&escape($regexp);
           } else {
               $regexp='.';
           }
           my $rep=&reply("dumpdom:$udom:$namespace:$regexp:$range",$uhome);
           my @pairs=split(/\&/,$rep);
           foreach my $item (@pairs) {
               my ($key,$value)=split(/=/,$item,2);
               $key = &unescape($key);
               next if ($key =~ /^error: 2 /);
               $returnhash{$key}=&thaw_unescape($value);
           }
       }
       return %returnhash;
   }
   
 # ------------------------------------------- get items from domain db files     # ------------------------------------------- get items from domain db files   
   
 sub get_dom {  sub get_dom {
Line 800  sub get_dom { Line 1009  sub get_dom {
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
             $uhome=&domain($udom,'primary');              $uhome=&domain($udom,'primary');
         } else {          } else {
             $uhome eq '';              undef($uhome);
         }          }
     } else {      } else {
         if (!$uhome) {          if (!$uhome) {
Line 811  sub get_dom { Line 1020  sub get_dom {
     }      }
     if ($udom && $uhome && ($uhome ne 'no_host')) {      if ($udom && $uhome && ($uhome ne 'no_host')) {
         my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);          my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
           my %returnhash;
           if ($rep eq '' || $rep =~ /^error: 2 /) {
               return %returnhash;
           }
         my @pairs=split(/\&/,$rep);          my @pairs=split(/\&/,$rep);
         if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {          if ( $#pairs==0 && $pairs[0] =~ /^(con_lost|error|no_such_host)/i) {
             return @pairs;              return @pairs;
         }          }
         my %returnhash=();  
         my $i=0;          my $i=0;
         foreach my $item (@$storearr) {          foreach my $item (@$storearr) {
             $returnhash{$item}=&thaw_unescape($pairs[$i]);              $returnhash{$item}=&thaw_unescape($pairs[$i]);
Line 823  sub get_dom { Line 1035  sub get_dom {
         }          }
         return %returnhash;          return %returnhash;
     } else {      } else {
         &logthis("get_dom failed - no homeserver and/or domain");          &logthis("get_dom failed - no homeserver and/or domain ($udom) ($uhome)");
     }      }
 }  }
   
Line 836  sub put_dom { Line 1048  sub put_dom {
         if (defined(&domain($udom,'primary'))) {          if (defined(&domain($udom,'primary'))) {
             $uhome=&domain($udom,'primary');              $uhome=&domain($udom,'primary');
         } else {          } else {
             $uhome eq '';              undef($uhome);
         }          }
     } else {      } else {
         if (!$uhome) {          if (!$uhome) {
Line 857  sub put_dom { Line 1069  sub put_dom {
     }      }
 }  }
   
   # -------------------------------------- newput for items in domain db files
   
   sub newput_dom {
       my ($namespace,$storehash,$udom,$uhome) = @_;
       my $result;
       if (!$udom) {
           $udom=$env{'user.domain'};
           if (defined(&domain($udom,'primary'))) {
               $uhome=&domain($udom,'primary');
           } else {
               undef($uhome);
           }
       } else {
           if (!$uhome) {
               if (defined(&domain($udom,'primary'))) {
                   $uhome=&domain($udom,'primary');
               }
           }
       }
       if ($udom && $uhome && ($uhome ne 'no_host')) {
           my $items='';
           if (ref($storehash) eq 'HASH') {
               foreach my $key (keys(%$storehash)) {
                   $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
               }
               $items=~s/\&$//;
               $result = &reply("newputdom:$udom:$namespace:$items",$uhome);
           }
       } else {
           &logthis("put_dom failed - no homeserver and/or domain");
       }
       return $result;
   }
   
   sub del_dom {
       my ($namespace,$storearr,$udom,$uhome)=@_;
       if (ref($storearr) eq 'ARRAY') {
           my $items='';
           foreach my $item (@$storearr) {
               $items.=&escape($item).'&';
           }
           $items=~s/\&$//;
           if (!$udom) {
               $udom=$env{'user.domain'};
               if (defined(&domain($udom,'primary'))) {
                   $uhome=&domain($udom,'primary');
               } else {
                   undef($uhome);
               }
           } else {
               if (!$uhome) {
                   if (defined(&domain($udom,'primary'))) {
                       $uhome=&domain($udom,'primary');
                   }
               }
           }
           if ($udom && $uhome && ($uhome ne 'no_host')) {
               return &reply("deldom:$udom:$namespace:$items",$uhome);
           } else {
               &logthis("del_dom failed - no homeserver and/or domain");
           }
       }
   }
   
 sub retrieve_inst_usertypes {  sub retrieve_inst_usertypes {
     my ($udom) = @_;      my ($udom) = @_;
     my (%returnhash,@order);      my (%returnhash,@order);
     if (defined(&domain($udom,'primary'))) {      my %domdefs = &Apache::lonnet::get_domain_defaults($udom);
         my $uhome=&domain($udom,'primary');      if ((ref($domdefs{'inststatustypes'}) eq 'HASH') && 
         my $rep=&reply("inst_usertypes:$udom",$uhome);          (ref($domdefs{'inststatusorder'}) eq 'ARRAY')) {
         my ($hashitems,$orderitems) = split(/:/,$rep);           %returnhash = %{$domdefs{'inststatustypes'}};
         my @pairs=split(/\&/,$hashitems);          @order = @{$domdefs{'inststatusorder'}};
         foreach my $item (@pairs) {  
             my ($key,$value)=split(/=/,$item,2);  
             $key = &unescape($key);  
             next if ($key =~ /^error: 2 /);  
             $returnhash{$key}=&thaw_unescape($value);  
         }  
         my @esc_order = split(/\&/,$orderitems);  
         foreach my $item (@esc_order) {  
             push(@order,&unescape($item));  
         }  
     } else {      } else {
         &logthis("get_dom failed - no primary domain server for $udom");          if (defined(&domain($udom,'primary'))) {
               my $uhome=&domain($udom,'primary');
               my $rep=&reply("inst_usertypes:$udom",$uhome);
               if ($rep =~ /^(con_lost|error|no_such_host|refused)/) {
                   &logthis("get_dom failed - $rep returned from $uhome in domain: $udom");
                   return (\%returnhash,\@order);
               }
               my ($hashitems,$orderitems) = split(/:/,$rep); 
               my @pairs=split(/\&/,$hashitems);
               foreach my $item (@pairs) {
                   my ($key,$value)=split(/=/,$item,2);
                   $key = &unescape($key);
                   next if ($key =~ /^error: 2 /);
                   $returnhash{$key}=&thaw_unescape($value);
               }
               my @esc_order = split(/\&/,$orderitems);
               foreach my $item (@esc_order) {
                   push(@order,&unescape($item));
               }
           } else {
               &logthis("get_dom failed - no primary domain server for $udom");
           }
     }      }
     return (\%returnhash,\@order);      return (\%returnhash,\@order);
 }  }
   
   sub is_domainimage {
       my ($url) = @_;
       if ($url=~m-^/+res/+($match_domain)/+\1\-domainconfig/+(img|logo|domlogo)/+-) {
           if (&domain($1) ne '') {
               return '1';
           }
       }
       return;
   }
   
   sub inst_directory_query {
       my ($srch) = @_;
       my $udom = $srch->{'srchdomain'};
       my %results;
       my $homeserver = &domain($udom,'primary');
       my $outcome;
       if ($homeserver ne '') {
    my $queryid=&reply("querysend:instdirsearch:".
      &escape($srch->{'srchby'}).':'.
      &escape($srch->{'srchterm'}).':'.
      &escape($srch->{'srchtype'}),$homeserver);
    my $host=&hostname($homeserver);
    if ($queryid !~/^\Q$host\E\_/) {
       &logthis('instituional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
       return;
    }
    my $response = &get_query_reply($queryid);
    my $maxtries = 5;
    my $tries = 1;
    while (($response=~/^timeout/) && ($tries < $maxtries)) {
       $response = &get_query_reply($queryid);
       $tries ++;
    }
   
           if (!&error($response) && $response ne 'refused') {
               if ($response eq 'unavailable') {
                   $outcome = $response;
               } else {
                   $outcome = 'ok';
                   my @matches = split(/\n/,$response);
                   foreach my $match (@matches) {
                       my ($key,$value) = split(/=/,$match);
                       $results{&unescape($key).':'.$udom} = &thaw_unescape($value);
                   }
               }
           }
       }
       return ($outcome,%results);
   }
   
   sub usersearch {
       my ($srch) = @_;
       my $dom = $srch->{'srchdomain'};
       my %results;
       my %libserv = &all_library();
       my $query = 'usersearch';
       foreach my $tryserver (keys(%libserv)) {
           if (&host_domain($tryserver) eq $dom) {
               my $host=&hostname($tryserver);
               my $queryid=
                   &reply("querysend:".&escape($query).':'.
                          &escape($srch->{'srchby'}).':'.
                          &escape($srch->{'srchtype'}).':'.
                          &escape($srch->{'srchterm'}),$tryserver);
               if ($queryid !~/^\Q$host\E\_/) {
                   &logthis('usersearch: invalid queryid: '.$queryid.' for host: '.$host.'in domain '.$dom.' and server: '.$tryserver);
                   next;
               }
               my $reply = &get_query_reply($queryid);
               my $maxtries = 1;
               my $tries = 1;
               while (($reply=~/^timeout/) && ($tries < $maxtries)) {
                   $reply = &get_query_reply($queryid);
                   $tries ++;
               }
               if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
                   &logthis('usersrch error: '.$reply.' for '.$dom.' - searching for : '.$srch->{'srchterm'}.' by '.$srch->{'srchby'}.' ('.$srch->{'srchtype'}.') -  maxtries: '.$maxtries.' tries: '.$tries);
               } else {
                   my @matches;
                   if ($reply =~ /\n/) {
                       @matches = split(/\n/,$reply);
                   } else {
                       @matches = split(/\&/,$reply);
                   }
                   foreach my $match (@matches) {
                       my ($uname,$udom,%userhash);
                       foreach my $entry (split(/:/,$match)) {
                           my ($key,$value) =
                               map {&unescape($_);} split(/=/,$entry);
                           $userhash{$key} = $value;
                           if ($key eq 'username') {
                               $uname = $value;
                           } elsif ($key eq 'domain') {
                               $udom = $value;
                           }
                       }
                       $results{$uname.':'.$udom} = \%userhash;
                   }
               }
           }
       }
       return %results;
   }
   
   sub get_instuser {
       my ($udom,$uname,$id) = @_;
       my $homeserver = &domain($udom,'primary');
       my ($outcome,%results);
       if ($homeserver ne '') {
           my $queryid=&reply("querysend:getinstuser:".&escape($uname).':'.
                              &escape($id).':'.&escape($udom),$homeserver);
           my $host=&hostname($homeserver);
           if ($queryid !~/^\Q$host\E\_/) {
               &logthis('get_instuser invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
               return;
           }
           my $response = &get_query_reply($queryid);
           my $maxtries = 5;
           my $tries = 1;
           while (($response=~/^timeout/) && ($tries < $maxtries)) {
               $response = &get_query_reply($queryid);
               $tries ++;
           }
           if (!&error($response) && $response ne 'refused') {
               if ($response eq 'unavailable') {
                   $outcome = $response;
               } else {
                   $outcome = 'ok';
                   my @matches = split(/\n/,$response);
                   foreach my $match (@matches) {
                       my ($key,$value) = split(/=/,$match);
                       $results{&unescape($key)} = &thaw_unescape($value);
                   }
               }
           }
       }
       my %userinfo;
       if (ref($results{$uname}) eq 'HASH') {
           %userinfo = %{$results{$uname}};
       } 
       return ($outcome,%userinfo);
   }
   
   sub inst_rulecheck {
       my ($udom,$uname,$id,$item,$rules) = @_;
       my %returnhash;
       if ($udom ne '') {
           if (ref($rules) eq 'ARRAY') {
               @{$rules} = map {&escape($_);} (@{$rules});
               my $rulestr = join(':',@{$rules});
               my $homeserver=&domain($udom,'primary');
               if (($homeserver ne '') && ($homeserver ne 'no_host')) {
                   my $response;
                   if ($item eq 'username') {                
                       $response=&unescape(&reply('instrulecheck:'.&escape($udom).
                                                 ':'.&escape($uname).':'.$rulestr,
                                                 $homeserver));
                   } elsif ($item eq 'id') {
                       $response=&unescape(&reply('instidrulecheck:'.&escape($udom).
                                                 ':'.&escape($id).':'.$rulestr,
                                                 $homeserver));
                   } elsif ($item eq 'selfcreate') {
                       $response=&unescape(&reply('instselfcreatecheck:'.
                                                  &escape($udom).':'.&escape($uname).
                                                 ':'.$rulestr,$homeserver));
                   }
                   if ($response ne 'refused') {
                       my @pairs=split(/\&/,$response);
                       foreach my $item (@pairs) {
                           my ($key,$value)=split(/=/,$item,2);
                           $key = &unescape($key);
                           next if ($key =~ /^error: 2 /);
                           $returnhash{$key}=&thaw_unescape($value);
                       }
                   }
               }
           }
       }
       return %returnhash;
   }
   
   sub inst_userrules {
       my ($udom,$check) = @_;
       my (%ruleshash,@ruleorder);
       if ($udom ne '') {
           my $homeserver=&domain($udom,'primary');
           if (($homeserver ne '') && ($homeserver ne 'no_host')) {
               my $response;
               if ($check eq 'id') {
                   $response=&reply('instidrules:'.&escape($udom),
                                    $homeserver);
               } elsif ($check eq 'email') {
                   $response=&reply('instemailrules:'.&escape($udom),
                                    $homeserver);
               } else {
                   $response=&reply('instuserrules:'.&escape($udom),
                                    $homeserver);
               }
               if (($response ne 'refused') && ($response ne 'error') && 
                   ($response ne 'unknown_cmd') && 
                   ($response ne 'no_such_host')) {
                   my ($hashitems,$orderitems) = split(/:/,$response);
                   my @pairs=split(/\&/,$hashitems);
                   foreach my $item (@pairs) {
                       my ($key,$value)=split(/=/,$item,2);
                       $key = &unescape($key);
                       next if ($key =~ /^error: 2 /);
                       $ruleshash{$key}=&thaw_unescape($value);
                   }
                   my @esc_order = split(/\&/,$orderitems);
                   foreach my $item (@esc_order) {
                       push(@ruleorder,&unescape($item));
                   }
               }
           }
       }
       return (\%ruleshash,\@ruleorder);
   }
   
   # ------------- Get Authentication, Language and User Tools Defaults for Domain
   
   sub get_domain_defaults {
       my ($domain) = @_;
       my $cachetime = 60*60*24;
       my ($result,$cached)=&is_cached_new('domdefaults',$domain);
       if (defined($cached)) {
           if (ref($result) eq 'HASH') {
               return %{$result};
           }
       }
       my %domdefaults;
       my %domconfig =
            &Apache::lonnet::get_dom('configuration',['defaults','quotas',
                                     'requestcourses','inststatus'],$domain);
       if (ref($domconfig{'defaults'}) eq 'HASH') {
           $domdefaults{'lang_def'} = $domconfig{'defaults'}{'lang_def'}; 
           $domdefaults{'auth_def'} = $domconfig{'defaults'}{'auth_def'};
           $domdefaults{'auth_arg_def'} = $domconfig{'defaults'}{'auth_arg_def'};
           $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'};
           $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'};
       } else {
           $domdefaults{'lang_def'} = &domain($domain,'lang_def');
           $domdefaults{'auth_def'} = &domain($domain,'auth_def');
           $domdefaults{'auth_arg_def'} = &domain($domain,'auth_arg_def');
       }
       if (ref($domconfig{'quotas'}) eq 'HASH') {
           if (ref($domconfig{'quotas'}{'defaultquota'}) eq 'HASH') {
               $domdefaults{'defaultquota'} = $domconfig{'quotas'}{'defaultquota'};
           } else {
               $domdefaults{'defaultquota'} = $domconfig{'quotas'};
           } 
           my @usertools = ('aboutme','blog','portfolio');
           foreach my $item (@usertools) {
               if (ref($domconfig{'quotas'}{$item}) eq 'HASH') {
                   $domdefaults{$item} = $domconfig{'quotas'}{$item};
               }
           }
       }
       if (ref($domconfig{'requestcourses'}) eq 'HASH') {
           foreach my $item ('official','unofficial','community') {
               $domdefaults{$item} = $domconfig{'requestcourses'}{$item};
           }
       }
       if (ref($domconfig{'inststatus'}) eq 'HASH') {
           foreach my $item ('inststatustypes','inststatusorder') {
               $domdefaults{$item} = $domconfig{'inststatus'}{$item};
           }
       }
       &Apache::lonnet::do_cache_new('domdefaults',$domain,\%domdefaults,
                                     $cachetime);
       return %domdefaults;
   }
   
 # --------------------------------------------------- Assign a key to a student  # --------------------------------------------------- Assign a key to a student
   
 sub assign_access_key {  sub assign_access_key {
Line 913  sub assign_access_key { Line 1473  sub assign_access_key {
 # key now belongs to user  # key now belongs to user
     my $envkey='key.'.$cdom.'_'.$cnum;      my $envkey='key.'.$cdom.'_'.$cnum;
             if (&put('environment',{$envkey => $ckey}) eq 'ok') {              if (&put('environment',{$envkey => $ckey}) eq 'ok') {
                 &appenv('environment.'.$envkey => $ckey);                  &appenv({'environment.'.$envkey => $ckey});
                 return 'ok';                  return 'ok';
             } else {              } else {
                 return                   return 
Line 1107  my $kicks=0; Line 1667  my $kicks=0;
 my $hits=0;  my $hits=0;
 sub make_key {  sub make_key {
     my ($name,$id) = @_;      my ($name,$id) = @_;
     if (length($id) > 200) { $id=length($id).':'.&Digest::MD5::md5_hex($id); }      if (length($id) > 65 
    && length(&escape($id)) > 200) {
    $id=length($id).':'.&Digest::MD5::md5_hex($id);
       }
     return &escape($name.':'.$id);      return &escape($name.':'.$id);
 }  }
   
Line 1154  sub do_cache_new { Line 1717  sub do_cache_new {
  $time=600;   $time=600;
     }      }
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }      if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
     $memcache->set($id,$setvalue,$time);      my $result = $memcache->set($id,$setvalue,$time);
       if (! $result) {
    &logthis("caching of id -> $id  failed");
    $memcache->disconnect_all();
       }
     # need to make a copy of $value      # need to make a copy of $value
     #&make_room($id,$value,$debug);      &make_room($id,$value,$debug);
     return $value;      return $value;
 }  }
   
 sub make_room {  sub make_room {
     my ($id,$value,$debug)=@_;      my ($id,$value,$debug)=@_;
     $remembered{$id}=$value;  
       $remembered{$id}= (ref($value)) ? &Storable::dclone($value)
                                       : $value;
     if ($to_remember<0) { return; }      if ($to_remember<0) { return; }
     $accessed{$id}=[&gettimeofday()];      $accessed{$id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
Line 1191  sub purge_remembered { Line 1760  sub purge_remembered {
   
 sub userenvironment {  sub userenvironment {
     my ($udom,$unam,@what)=@_;      my ($udom,$unam,@what)=@_;
       my $items;
       foreach my $item (@what) {
           $items.=&escape($item).'&';
       }
       $items=~s/\&$//;
     my %returnhash=();      my %returnhash=();
     my @answer=split(/\&/,      my $uhome = &homeserver($unam,$udom);
                 &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),      unless ($uhome eq 'no_host') {
                       &homeserver($unam,$udom)));          my @answer=split(/\&/, 
     my $i;              &reply('get:'.$udom.':'.$unam.':environment:'.$items,$uhome));
     for ($i=0;$i<=$#what;$i++) {          my $i;
  $returnhash{$what[$i]}=&unescape($answer[$i]);          for ($i=0;$i<=$#what;$i++) {
       $returnhash{$what[$i]}=&unescape($answer[$i]);
           }
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 1388  sub ssi_body { Line 1964  sub ssi_body {
     if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {      if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
         $form{'LONCAPA_INTERNAL_no_discussion'}='true';          $form{'LONCAPA_INTERNAL_no_discussion'}='true';
     }      }
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output='';
                                      &ssi($filelink,%form));      my $response;
       if ($filelink=~/^https?\:/) {
          ($output,$response)=&externalssi($filelink);
       } else {
          $filelink .= $filelink=~/\?/ ? '&' : '?';
          $filelink .= 'inhibitmenu=yes';
          ($output,$response)=&ssi($filelink,%form);
       }
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+?// END LON-CAPA Internal\s*(-->)?\s||gs;
     $output=~s/^.*?\<body[^\>]*\>//si;      $output=~s/^.*?\<body[^\>]*\>//si;
     $output=~s/(.*)\<\/body\s*\>.*?$/$1/si;      $output=~s/\<\/body\s*\>.*?$//si;
     return $output;      if (wantarray) {
           return ($output, $response);
       } else {
           return $output;
       }
 }  }
   
 # --------------------------------------------------------- Server Side Include  # --------------------------------------------------------- Server Side Include
Line 1407  sub absolute_url { Line 1994  sub absolute_url {
     return $protocol.$host_name;      return $protocol.$host_name;
 }  }
   
   #
   #   Server side include.
   # Parameters:
   #  fn     Possibly encrypted resource name/id.
   #  form   Hash that describes how the rendering should be done
   #         and other things.
   # Returns:
   #   Scalar context: The content of the response.
   #   Array context:  2 element list of the content and the full response object.
   #     
 sub ssi {  sub ssi {
   
     my ($fn,%form)=@_;      my ($fn,%form)=@_;
   
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
       
     my $request;      my $request;
   
     $form{'no_update_last_known'}=1;      $form{'no_update_last_known'}=1;
       &Apache::lonenc::check_encrypt(\$fn);
     if (%form) {      if (%form) {
       $request=new HTTP::Request('POST',&absolute_url().$fn);        $request=new HTTP::Request('POST',&absolute_url().$fn);
       $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys %form));        $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));
     } else {      } else {
       $request=new HTTP::Request('GET',&absolute_url().$fn);        $request=new HTTP::Request('GET',&absolute_url().$fn);
     }      }
Line 1427  sub ssi { Line 2022  sub ssi {
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $response=$ua->request($request);      my $response=$ua->request($request);
   
     return $response->content;      if (wantarray) {
    return ($response->content, $response);
       } else {
    return $response->content;
       }
 }  }
   
 sub externalssi {  sub externalssi {
Line 1435  sub externalssi { Line 2034  sub externalssi {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',$url);      my $request=new HTTP::Request('GET',$url);
     my $response=$ua->request($request);      my $response=$ua->request($request);
     return $response->content;      if (wantarray) {
           return ($response->content, $response);
       } else {
           return $response->content;
       }
 }  }
   
 # -------------------------------- Allow a /uploaded/ URI to be vouched for  # -------------------------------- Allow a /uploaded/ URI to be vouched for
Line 1448  sub allowuploaded { Line 2051  sub allowuploaded {
     my %httpref=();      my %httpref=();
     my $httpurl=&hreflocation('',$url);      my $httpurl=&hreflocation('',$url);
     $httpref{'httpref.'.$httpurl}=$srcurl;      $httpref{'httpref.'.$httpurl}=$srcurl;
     &Apache::lonnet::appenv(%httpref);      &Apache::lonnet::appenv(\%httpref);
 }  }
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
Line 1509  sub process_coursefile { Line 2112  sub process_coursefile {
             print $fh $env{'form.'.$source};              print $fh $env{'form.'.$source};
             close($fh);              close($fh);
             if ($parser eq 'parse') {              if ($parser eq 'parse') {
                 my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);                  my $parse_result = &extract_embedded_items($filepath.'/'.$fname,$allfiles,$codebase);
                 unless ($parse_result eq 'ok') {                  unless ($parse_result eq 'ok') {
                     &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);                      &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
                 }                  }
Line 1588  sub clean_filename { Line 2191  sub clean_filename {
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/g;
     return $fname;      return $fname;
 }  }
   #This Function check if a Image max 400px width and height 500px. If not then scale the image down
   sub resizeImage {
    my($img_url) = @_;
    my $ima = Image::Magick->new;                       
           $ima->Read($img_url);
    if($ima->Get('width') > 400)
    {
    my $factor = $ima->Get('width')/400;
                 $ima->Scale( width=>400, height=>$ima->Get('height')/$factor );
    }
    if($ima->Get('height') > 500)
           {
           my $factor = $ima->Get('height')/500;
                   $ima->Scale( width=>$ima->Get('width')/$factor, height=>500);
           } 
   
    $ima->Write($img_url);
   }
   
   #Wrapper function for userphotoupload
   sub userphotoupload
   {
    my($formname,$subdir) = @_;
    $upload_photo_form = 1;
    return &userfileupload($formname,undef,$subdir);
   }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: $formname - the contents of the file are in $env{"form.$formname"}  # input: $formname - the contents of the file are in $env{"form.$formname"}
Line 1647  sub userfileupload { Line 2276  sub userfileupload {
         close($fh);          close($fh);
         return $fullpath.'/'.$fname;          return $fullpath.'/'.$fname;
     }      }
           if ($subdir eq 'scantron') {
           $fname = 'scantron_orig_'.$fname;
       } else {   
 # Create the directory if not present  # Create the directory if not present
     $fname="$subdir/$fname";          $fname="$subdir/$fname";
       }
     if ($coursedoc) {      if ($coursedoc) {
  my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};   my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
  my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};   my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
Line 1688  sub finishuserfileupload { Line 2320  sub finishuserfileupload {
         $thumbwidth,$thumbheight) = @_;          $thumbwidth,$thumbheight) = @_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
     
     my ($fnamepath,$file,$fetchthumb);      my ($fnamepath,$file,$fetchthumb);
     $file=$fname;      $file=$fname;
     if ($fname=~m|/|) {      if ($fname=~m|/|) {
Line 1702  sub finishuserfileupload { Line 2335  sub finishuserfileupload {
     mkdir($filepath,0777);      mkdir($filepath,0777);
         }          }
     }      }
   
 # Save the file  # Save the file
     {      {
  if (!open(FH,'>'.$filepath.'/'.$file)) {   if (!open(FH,'>'.$filepath.'/'.$file)) {
Line 1715  sub finishuserfileupload { Line 2349  sub finishuserfileupload {
     return '/adm/notfound.html';      return '/adm/notfound.html';
  }   }
  close(FH);   close(FH);
    if($upload_photo_form==1)
    {
    resizeImage($filepath.'/'.$file);
    $upload_photo_form = 0;
    }
     }      }
     if ($parser eq 'parse') {      if ($parser eq 'parse') {
         my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,          my $parse_result = &extract_embedded_items($filepath.'/'.$file,$allfiles,
    $codebase);     $codebase);
         unless ($parse_result eq 'ok') {          unless ($parse_result eq 'ok') {
             &logthis('Failed to parse '.$filepath.$file.              &logthis('Failed to parse '.$filepath.$file.
Line 1736  sub finishuserfileupload { Line 2375  sub finishuserfileupload {
     
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
     my $docuhome=&homeserver($docuname,$docudom);      my $docuhome=&homeserver($docuname,$docudom);
     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
         if ($fetchthumb) {          if ($fetchthumb) {
Line 1757  sub finishuserfileupload { Line 2396  sub finishuserfileupload {
 }  }
   
 sub extract_embedded_items {  sub extract_embedded_items {
     my ($filepath,$file,$allfiles,$codebase,$content) = @_;      my ($fullpath,$allfiles,$codebase,$content) = @_;
     my @state = ();      my @state = ();
     my %javafiles = (      my %javafiles = (
                       codebase => '',                        codebase => '',
Line 1772  sub extract_embedded_items { Line 2411  sub extract_embedded_items {
     if ($content) {      if ($content) {
         $p = HTML::LCParser->new($content);          $p = HTML::LCParser->new($content);
     } else {      } else {
         $p = HTML::LCParser->new($filepath.'/'.$file);          $p = HTML::LCParser->new($fullpath);
     }      }
     while (my $t=$p->get_token()) {      while (my $t=$p->get_token()) {
  if ($t->[0] eq 'S') {   if ($t->[0] eq 'S') {
     my ($tagname, $attr) = ($t->[1],$t->[2]);      my ($tagname, $attr) = ($t->[1],$t->[2]);
     push (@state, $tagname);      push(@state, $tagname);
             if (lc($tagname) eq 'allow') {              if (lc($tagname) eq 'allow') {
                 &add_filetype($allfiles,$attr->{'src'},'src');                  &add_filetype($allfiles,$attr->{'src'},'src');
             }              }
     if (lc($tagname) eq 'img') {      if (lc($tagname) eq 'img') {
  &add_filetype($allfiles,$attr->{'src'},'src');   &add_filetype($allfiles,$attr->{'src'},'src');
     }      }
       if (lc($tagname) eq 'a') {
    &add_filetype($allfiles,$attr->{'href'},'href');
       }
             if (lc($tagname) eq 'script') {              if (lc($tagname) eq 'script') {
                 if ($attr->{'archive'} =~ /\.jar$/i) {                  if ($attr->{'archive'} =~ /\.jar$/i) {
                     &add_filetype($allfiles,$attr->{'archive'},'archive');                      &add_filetype($allfiles,$attr->{'archive'},'archive');
Line 1865  sub add_filetype { Line 2507  sub add_filetype {
 }  }
   
 sub removeuploadedurl {  sub removeuploadedurl {
     my ($url)=@_;      my ($url)=@_;
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);      my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);    
     return &removeuserfile($uname,$udom,$fname);      return &removeuserfile($uname,$udom,$fname);
 }  }
   
 sub removeuserfile {  sub removeuserfile {
     my ($docuname,$docudom,$fname)=@_;      my ($docuname,$docudom,$fname)=@_;
     my $home=&homeserver($docuname,$docudom);      my $home=&homeserver($docuname,$docudom);    
     my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);      my $result = &reply("removeuserfile:$docudom/$docuname/$fname",$home);
     if ($result eq 'ok') {      if ($result eq 'ok') {
         if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {          if (($fname !~ /\.meta$/) && (&is_portfolio_file($fname))) {
             my $metafile = $fname.'.meta';              my $metafile = $fname.'.meta';
             my $metaresult = &removeuserfile($docuname,$docudom,$metafile);               my $metaresult = &removeuserfile($docuname,$docudom,$metafile); 
     my $url = "/uploaded/$docudom/$docuname/$fname";      my $url = "/uploaded/$docudom/$docuname/$fname";
             my ($file,$group) = (&parse_portfolio_url($url))[3,4];              my ($file,$group) = (&parse_portfolio_url($url))[3,4];   
             my $sqlresult =               my $sqlresult = 
                 &update_portfolio_table($docuname,$docudom,$file,                  &update_portfolio_table($docuname,$docudom,$file,
                                         'portfolio_metadata',$group,                                          'portfolio_metadata',$group,
Line 1940  sub flushcourselogs { Line 2582  sub flushcourselogs {
 # times and course titles for all courseids  # times and course titles for all courseids
 #  #
     my %courseidbuffer=();      my %courseidbuffer=();
     foreach my $crsid (keys %courselogs) {      foreach my $crsid (keys(%courselogs)) {
         if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.          if (&reply('log:'.$coursedombuf{$crsid}.':'.$coursenumbuf{$crsid}.':'.
           &escape($courselogs{$crsid}),            &escape($courselogs{$crsid}),
           $coursehombuf{$crsid}) eq 'ok') {            $coursehombuf{$crsid}) eq 'ok') {
Line 1953  sub flushcourselogs { Line 2595  sub flushcourselogs {
                delete $courselogs{$crsid};                 delete $courselogs{$crsid};
             }              }
         }          }
         if ($courseidbuffer{$coursehombuf{$crsid}}) {          $courseidbuffer{$coursehombuf{$crsid}}{$crsid} = {
            $courseidbuffer{$coursehombuf{$crsid}}.='&'.              'description' => $coursedescrbuf{$crsid},
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).              'inst_code'    => $courseinstcodebuf{$crsid},
                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});              'type'        => $coursetypebuf{$crsid},
         } else {              'owner'       => $courseownerbuf{$crsid},
            $courseidbuffer{$coursehombuf{$crsid}}=          };
  &escape($crsid).'='.&escape($coursedescrbuf{$crsid}).  
                          ':'.&escape($courseinstcodebuf{$crsid}).':'.&escape($courseownerbuf{$crsid}).':'.&escape($coursetypebuf{$crsid});  
         }  
     }      }
 #  #
 # Write course id database (reverse lookup) to homeserver of courses   # Write course id database (reverse lookup) to homeserver of courses 
 # Is used in pickcourse  # Is used in pickcourse
 #  #
     foreach my $crs_home (keys(%courseidbuffer)) {      foreach my $crs_home (keys(%courseidbuffer)) {
         &courseidput(&host_domain($crs_home),$courseidbuffer{$crs_home},          my $response = &courseidput(&host_domain($crs_home),
      $crs_home);                                      $courseidbuffer{$crs_home},
                                       $crs_home,'timeonly');
     }      }
 #  #
 # File accesses  # File accesses
Line 2024  sub flushcourselogs { Line 2664  sub flushcourselogs {
 # Reverse lookup of domain roles (dc, ad, li, sc, au)  # Reverse lookup of domain roles (dc, ad, li, sc, au)
 #  #
     my %domrolebuffer = ();      my %domrolebuffer = ();
     foreach my $entry (keys %domainrolehash) {      foreach my $entry (keys(%domainrolehash)) {
         my ($role,$uname,$udom,$runame,$rudom,$rsec)=split/:/,$entry;          my ($role,$uname,$udom,$runame,$rudom,$rsec)=split(/:/,$entry);
         if ($domrolebuffer{$rudom}) {          if ($domrolebuffer{$rudom}) {
             $domrolebuffer{$rudom}.='&'.&escape($entry).              $domrolebuffer{$rudom}.='&'.&escape($entry).
                       '='.&escape($domainrolehash{$entry});                        '='.&escape($domainrolehash{$entry});
Line 2084  sub courseacclog { Line 2724  sub courseacclog {
         # FIXME: Probably ought to escape things....          # FIXME: Probably ought to escape things....
  foreach my $key (keys(%env)) {   foreach my $key (keys(%env)) {
             if ($key=~/^form\.(.*)/) {              if ($key=~/^form\.(.*)/) {
  $what.=':'.$1.'='.$env{$key};                  my $formitem = $1;
                   if ($formitem =~ /^HWFILE(?:SIZE|TOOBIG)/) {
                       $what.=':'.$formitem.'='.$env{$key};
                   } elsif ($formitem !~ /^HWFILE(?:[^.]+)$/) {
                       $what.=':'.$formitem.'='.$env{$key};
                   }
             }              }
         }          }
     } elsif ($fnsymb =~ m:^/adm/searchcat:) {      } elsif ($fnsymb =~ m:^/adm/searchcat:) {
Line 2130  sub userrolelog { Line 2775  sub userrolelog {
          {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}           {$trole.':'.$username.':'.$domain.':'.$runame.':'.$rudom.':'.$rsec}
                     =$tend.':'.$tstart;                      =$tend.':'.$tstart;
     }      }
       if (($env{'request.role'} =~ /dc\./) &&
    (($trole=~/^au/) || ($trole=~/^in/) ||
    ($trole=~/^cc/) || ($trole=~/^ep/) ||
    ($trole=~/^cr/) || ($trole=~/^ta/))) {
          $userrolehash
            {$trole.':'.$username.':'.$domain.':'.$env{'user.name'}.':'.$env{'user.domain'}.':'}
                       =$tend.':'.$tstart;
       }
     if (($trole=~/^dc/) || ($trole=~/^ad/) ||      if (($trole=~/^dc/) || ($trole=~/^ad/) ||
         ($trole=~/^li/) || ($trole=~/^li/) ||          ($trole=~/^li/) || ($trole=~/^li/) ||
         ($trole=~/^au/) || ($trole=~/^dg/) ||          ($trole=~/^au/) || ($trole=~/^dg/) ||
Line 2141  sub userrolelog { Line 2794  sub userrolelog {
     }      }
 }  }
   
   sub courserolelog {
       my ($trole,$username,$domain,$area,$tstart,$tend,$delflag,$selfenroll,$context)=@_;
       if (($trole eq 'cc') || ($trole eq 'in') ||
           ($trole eq 'ep') || ($trole eq 'ad') ||
           ($trole eq 'ta') || ($trole eq 'st') ||
           ($trole=~/^cr/) || ($trole eq 'gr')) {
           if ($area =~ m-^/($match_domain)/($match_courseid)/?([^/]*)-) {
               my $cdom = $1;
               my $cnum = $2;
               my $sec = $3;
               my $namespace = 'rolelog';
               my %storehash = (
                                  role    => $trole,
                                  start   => $tstart,
                                  end     => $tend,
                                  selfenroll => $selfenroll,
                                  context    => $context,
                               );
               if ($trole eq 'gr') {
                   $namespace = 'groupslog';
                   $storehash{'group'} = $sec;
               } else {
                   $storehash{'section'} = $sec;
               }
               &instructor_log($namespace,\%storehash,$delflag,$username,$domain,$cnum,$cdom);
               if (($trole ne 'st') || ($sec ne '')) {
                   &devalidate_cache_new('getcourseroles',$cdom.'_'.$cnum);
               }
           }
       }
       return;
   }
   
 sub get_course_adv_roles {  sub get_course_adv_roles {
     my $cid=shift;      my ($cid,$codes) = @_;
     $cid=$env{'request.course.id'} unless (defined($cid));      $cid=$env{'request.course.id'} unless (defined($cid));
     my %coursehash=&coursedescription($cid);      my %coursehash=&coursedescription($cid);
       my $crstype = &Apache::loncommon::course_type($cid);
     my %nothide=();      my %nothide=();
     foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {      foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
  $nothide{join(':',split(/[\@\:]/,$user))}=1;          if ($user !~ /:/) {
       $nothide{join(':',split(/[\@]/,$user))}=1;
           } else {
               $nothide{$user}=1;
           }
     }      }
     my %returnhash=();      my %returnhash=();
     my %dumphash=      my %dumphash=
             &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});              &dump('nohist_userroles',$coursehash{'domain'},$coursehash{'num'});
     my $now=time;      my $now=time;
     foreach my $entry (keys %dumphash) {      my %privileged;
       foreach my $entry (keys(%dumphash)) {
  my ($tend,$tstart)=split(/\:/,$dumphash{$entry});   my ($tend,$tstart)=split(/\:/,$dumphash{$entry});
         if (($tstart) && ($tstart<0)) { next; }          if (($tstart) && ($tstart<0)) { next; }
         if (($tend) && ($tend<$now)) { next; }          if (($tend) && ($tend<$now)) { next; }
         if (($tstart) && ($now<$tstart)) { next; }          if (($tstart) && ($now<$tstart)) { next; }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);          my ($role,$username,$domain,$section)=split(/\:/,$entry);
  if ($username eq '' || $domain eq '') { next; }   if ($username eq '' || $domain eq '') { next; }
  if ((&privileged($username,$domain)) &&           unless (ref($privileged{$domain}) eq 'HASH') {
     (!$nothide{$username.':'.$domain})) { next; }              my %dompersonnel =
                   &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
               $privileged{$domain} = {};
               foreach my $server (keys(%dompersonnel)) {
                   if (ref($dompersonnel{$server}) eq 'HASH') {
                       foreach my $user (keys(%{$dompersonnel{$server}})) {
                           my ($trole,$uname,$udom) = split(/:/,$user);
                           $privileged{$udom}{$uname} = 1;
                       }
                   }
               }
           }
           if ((exists($privileged{$domain}{$username})) && 
               (!$nothide{$username.':'.$domain})) { next; }
  if ($role eq 'cr') { next; }   if ($role eq 'cr') { next; }
         my $key=&plaintext($role);          if ($codes) {
         if ($section) { $key.=' (Sec/Grp '.$section.')'; }              if ($section) { $role .= ':'.$section; }
         if ($returnhash{$key}) {              if ($returnhash{$role}) {
     $returnhash{$key}.=','.$username.':'.$domain;                  $returnhash{$role}.=','.$username.':'.$domain;
               } else {
                   $returnhash{$role}=$username.':'.$domain;
               }
         } else {          } else {
             $returnhash{$key}=$username.':'.$domain;              my $key=&plaintext($role,$crstype);
               if ($section) { $key.=' ('.&Apache::lonlocal::mt('Section [_1]',$section).')'; }
               if ($returnhash{$key}) {
           $returnhash{$key}.=','.$username.':'.$domain;
               } else {
                   $returnhash{$key}=$username.':'.$domain;
               }
         }          }
      }      }
     return %returnhash;      return %returnhash;
 }  }
   
 sub get_my_roles {  sub get_my_roles {
     my ($uname,$udom,$context,$types,$roles,$roledoms)=@_;      my ($uname,$udom,$context,$types,$roles,$roledoms,$withsec,$hidepriv)=@_;
     unless (defined($uname)) { $uname=$env{'user.name'}; }      unless (defined($uname)) { $uname=$env{'user.name'}; }
     unless (defined($udom)) { $udom=$env{'user.domain'}; }      unless (defined($udom)) { $udom=$env{'user.domain'}; }
     my %dumphash;      my (%dumphash,%nothide);
     if ($context eq 'userroles') {       if ($context eq 'userroles') { 
         %dumphash = &dump('roles',$udom,$uname);          %dumphash = &dump('roles',$udom,$uname);
     } else {      } else {
         %dumphash=          %dumphash=
             &dump('nohist_userroles',$udom,$uname);              &dump('nohist_userroles',$udom,$uname);
           if ($hidepriv) {
               my %coursehash=&coursedescription($udom.'_'.$uname);
               foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
                   if ($user !~ /:/) {
                       $nothide{join(':',split(/[\@]/,$user))} = 1;
                   } else {
                       $nothide{$user} = 1;
                   }
               }
           }
     }      }
     my %returnhash=();      my %returnhash=();
     my $now=time;      my $now=time;
       my %privileged;
     foreach my $entry (keys(%dumphash)) {      foreach my $entry (keys(%dumphash)) {
  my ($tend,$tstart)=split(/\:/,$dumphash{$entry});          my ($role,$tend,$tstart);
           if ($context eq 'userroles') {
       ($role,$tend,$tstart)=split(/_/,$dumphash{$entry});
           } else {
               ($tend,$tstart)=split(/\:/,$dumphash{$entry});
           }
         if (($tstart) && ($tstart<0)) { next; }          if (($tstart) && ($tstart<0)) { next; }
         my $status = 'active';          my $status = 'active';
         if (($tend) && ($tend<$now)) {          if (($tend) && ($tend<=$now)) {
             $status = 'previous';              $status = 'previous';
         }           } 
         if (($tstart) && ($now<$tstart)) {          if (($tstart) && ($now<$tstart)) {
Line 2206  sub get_my_roles { Line 2936  sub get_my_roles {
                 next;                  next;
             }              }
         }          }
         my ($role,$username,$domain,$section)=split(/\:/,$entry);          my ($rolecode,$username,$domain,$section,$area);
           if ($context eq 'userroles') {
               ($area,$rolecode) = split(/_/,$entry);
               (undef,$domain,$username,$section) = split(/\//,$area);
           } else {
               ($role,$username,$domain,$section) = split(/\:/,$entry);
           }
         if (ref($roledoms) eq 'ARRAY') {          if (ref($roledoms) eq 'ARRAY') {
             if (!grep(/^\Q$domain\E$/,@{$roledoms})) {              if (!grep(/^\Q$domain\E$/,@{$roledoms})) {
                 next;                  next;
Line 2214  sub get_my_roles { Line 2950  sub get_my_roles {
         }          }
         if (ref($roles) eq 'ARRAY') {          if (ref($roles) eq 'ARRAY') {
             if (!grep(/^\Q$role\E$/,@{$roles})) {              if (!grep(/^\Q$role\E$/,@{$roles})) {
                 next;                  if ($role =~ /^cr\//) {
                       if (!grep(/^cr$/,@{$roles})) {
                           next;
                       }
                   } else {
                       next;
                   }
             }              }
         }           }
  $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;          if ($hidepriv) {
               if ($context eq 'userroles') {
                   if ((&privileged($username,$domain)) &&
                       (!$nothide{$username.':'.$domain})) {
                       next;
                   }
               } else {
                   unless (ref($privileged{$domain}) eq 'HASH') {
                       my %dompersonnel =
                           &Apache::lonnet::get_domain_roles($domain,['dc'],$now,$now);
                       $privileged{$domain} = {};
                       if (keys(%dompersonnel)) {
                           foreach my $server (keys(%dompersonnel)) {
                               if (ref($dompersonnel{$server}) eq 'HASH') {
                                   foreach my $user (keys(%{$dompersonnel{$server}})) {
                                       my ($trole,$uname,$udom) = split(/:/,$user);
                                       $privileged{$udom}{$uname} = $trole;
                                   }
                               }
                           }
                       }
                   }
                   if (exists($privileged{$domain}{$username})) {
                       if (!$nothide{$username.':'.$domain}) {
                           next;
                       }
                   }
               }
           }
           if ($withsec) {
               $returnhash{$username.':'.$domain.':'.$role.':'.$section} =
                   $tstart.':'.$tend;
           } else {
               $returnhash{$username.':'.$domain.':'.$role}=$tstart.':'.$tend;
           }
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 2256  sub getannounce { Line 3032  sub getannounce {
 #  #
   
 sub courseidput {  sub courseidput {
     my ($domain,$what,$coursehome)=@_;      my ($domain,$storehash,$coursehome,$caller) = @_;
     return &reply('courseidput:'.$domain.':'.$what,$coursehome);      my $outcome;
       if ($caller eq 'timeonly') {
           my $cids = '';
           foreach my $item (keys(%$storehash)) {
               $cids.=&escape($item).'&';
           }
           $cids=~s/\&$//;
           $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$cids,
                             $coursehome);       
       } else {
           my $items = '';
           foreach my $item (keys(%$storehash)) {
               $items.= &escape($item).'='.
                        &freeze_escape($$storehash{$item}).'&';
           }
           $items=~s/\&$//;
           $outcome = &reply('courseidputhash:'.$domain.':'.$caller.':'.$items,
                             $coursehome);
       }
       if ($outcome eq 'unknown_cmd') {
           my $what;
           foreach my $cid (keys(%$storehash)) {
               $what .= &escape($cid).'=';
               foreach my $item ('description','inst_code','owner','type') {
                   $what .= &escape($storehash->{$cid}{$item}).':';
               }
               $what =~ s/\:$/&/;
           }
           $what =~ s/\&$//;  
           return &reply('courseidput:'.$domain.':'.$what,$coursehome);
       } else {
           return $outcome;
       }
 }  }
   
 sub courseiddump {  sub courseiddump {
     my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok)=@_;      my ($domfilter,$descfilter,$sincefilter,$instcodefilter,$ownerfilter,
     my %returnhash=();          $coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
     unless ($domfilter) { $domfilter=''; }          $selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,$cloneonly)=@_;
       my $as_hash = 1;
       my %returnhash;
       if (!$domfilter) { $domfilter=''; }
     my %libserv = &all_library();      my %libserv = &all_library();
     foreach my $tryserver (keys(%libserv)) {      foreach my $tryserver (keys(%libserv)) {
         if ( (  $hostidflag == 1           if ( (  $hostidflag == 1 
         && grep(/^\Q$tryserver\E$/,@{$hostidref}) )           && grep(/^\Q$tryserver\E$/,@{$hostidref}) ) 
      || (!defined($hostidflag)) ) {       || (!defined($hostidflag)) ) {
   
     if ($domfilter eq ''      if (($domfilter eq '') ||
  || (&host_domain($tryserver) eq $domfilter)) {   (&host_domain($tryserver) eq $domfilter)) {
         foreach my $line (                  my $rep = 
                  split(/\&/,&reply('courseiddump:'.&host_domain($tryserver).':'.                    &reply('courseiddump:'.&host_domain($tryserver).':'.
        $sincefilter.':'.&escape($descfilter).':'.                           $sincefilter.':'.&escape($descfilter).':'.
                                &escape($instcodefilter).':'.&escape($ownerfilter).':'.&escape($coursefilter).':'.&escape($typefilter).':'.&escape($regexp_ok),                           &escape($instcodefilter).':'.&escape($ownerfilter).
                                $tryserver))) {                           ':'.&escape($coursefilter).':'.&escape($typefilter).
     my ($key,$value)=split(/\=/,$line,2);                           ':'.&escape($regexp_ok).':'.$as_hash.':'.
                     if (($key) && ($value)) {                           &escape($selfenrollonly).':'.&escape($catfilter).':'.
         $returnhash{&unescape($key)}=$value;                           $showhidden.':'.$caller.':'.&escape($cloner).':'.
                            &escape($cc_clone).':'.$cloneonly,$tryserver);
                   my @pairs=split(/\&/,$rep);
                   foreach my $item (@pairs) {
                       my ($key,$value)=split(/\=/,$item,2);
                       $key = &unescape($key);
                       next if ($key =~ /^error: 2 /);
                       my $result = &thaw_unescape($value);
                       if (ref($result) eq 'HASH') {
                           $returnhash{$key}=$result;
                       } else {
                           my @responses = split(/:/,$value);
                           my @items = ('description','inst_code','owner','type');
                           for (my $i=0; $i<@responses; $i++) {
                               $returnhash{$key}{$items[$i]} = &unescape($responses[$i]);
                           }
                     }                      }
                 }                  }
             }              }
Line 2326  sub get_domain_roles { Line 3152  sub get_domain_roles {
     if (undef($enddate) || $enddate eq '') {      if (undef($enddate) || $enddate eq '') {
         $enddate = '.';          $enddate = '.';
     }      }
     my $rolelist = join(':',@{$roles});      my $rolelist;
       if (ref($roles) eq 'ARRAY') {
           $rolelist = join(':',@{$roles});
       }
     my %personnel = ();      my %personnel = ();
   
     my %servers = &get_servers($dom,'library');      my %servers = &get_servers($dom,'library');
Line 2352  sub get_first_access { Line 3181  sub get_first_access {
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     if ($argsymb) { $symb=$argsymb; }      if ($argsymb) { $symb=$argsymb; }
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') {      if ($type eq 'course') {
    $res='course';
       } elsif ($type eq 'map') {
  $res=&symbread($map);   $res=&symbread($map);
     } else {      } else {
  $res=$symb;   $res=$symb;
Line 2365  sub set_first_access { Line 3196  sub set_first_access {
     my ($type)=@_;      my ($type)=@_;
     my ($symb,$courseid,$udom,$uname)=&whichuser();      my ($symb,$courseid,$udom,$uname)=&whichuser();
     my ($map,$id,$res)=&decode_symb($symb);      my ($map,$id,$res)=&decode_symb($symb);
     if ($type eq 'map') {      if ($type eq 'course') {
    $res='course';
       } elsif ($type eq 'map') {
  $res=&symbread($map);   $res=&symbread($map);
     } else {      } else {
  $res=$symb;   $res=$symb;
Line 2723  sub tmpreset { Line 3556  sub tmpreset {
   if (tie(%hash,'GDBM_File',    if (tie(%hash,'GDBM_File',
   $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',    $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
   &GDBM_WRCREAT(),0640)) {    &GDBM_WRCREAT(),0640)) {
     foreach my $key (keys %hash) {      foreach my $key (keys(%hash)) {
       if ($key=~ /:$symb/) {        if ($key=~ /:$symb/) {
  delete($hash{$key});   delete($hash{$key});
       }        }
Line 2995  sub coursedescription { Line 3828  sub coursedescription {
        }         }
     }      }
     if (!$args->{'one_time'}) {      if (!$args->{'one_time'}) {
  &appenv(%envhash);   &appenv(\%envhash);
     }      }
     return %returnhash;      return %returnhash;
 }  }
Line 3034  sub privileged { Line 3867  sub privileged {
   
 sub rolesinit {  sub rolesinit {
     my ($domain,$username,$authhost)=@_;      my ($domain,$username,$authhost)=@_;
       my %userroles;
     my $rolesdump=reply("dump:$domain:$username:roles",$authhost);      my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
     if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }      if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return \%userroles; }
     my %allroles=();      my %allroles=();
     my %allgroups=();         my %allgroups=();   
     my $now=time;      my $now=time;
     my %userroles = ('user.login.time' => $now);      %userroles = ('user.login.time' => $now);
     my $group_privs;      my $group_privs;
   
     if ($rolesdump ne '') {      if ($rolesdump ne '') {
Line 3158  sub set_userprivs { Line 3992  sub set_userprivs {
     my $adv=0;      my $adv=0;
     my %grouproles = ();      my %grouproles = ();
     if (keys(%{$allgroups}) > 0) {      if (keys(%{$allgroups}) > 0) {
         foreach my $role (keys %{$allroles}) {          foreach my $role (keys(%{$allroles})) {
             my ($trole,$area,$sec,$extendedarea);              my ($trole,$area,$sec,$extendedarea);
             if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)-) {              if ($role =~ m-^(\w+|cr/$match_domain/$match_username/\w+)\.(/$match_domain/$match_courseid)(/?\w*)\.-) {
                 $trole = $1;                  $trole = $1;
                 $area = $2;                  $area = $2;
                 $sec = $3;                  $sec = $3;
Line 3180  sub set_userprivs { Line 4014  sub set_userprivs {
     }      }
     foreach my $role (keys(%{$allroles})) {      foreach my $role (keys(%{$allroles})) {
         my %thesepriv;          my %thesepriv;
         if (($role=~/^au/) || ($role=~/^ca/)) { $author=1; }          if (($role=~/^au/) || ($role=~/^ca/) || ($role=~/^aa/)) { $author=1; }
         foreach my $item (split(/:/,$$allroles{$role})) {          foreach my $item (split(/:/,$$allroles{$role})) {
             if ($item ne '') {              if ($item ne '') {
                 my ($privilege,$restrictions)=split(/&/,$item);                  my ($privilege,$restrictions)=split(/&/,$item);
Line 3201  sub set_userprivs { Line 4035  sub set_userprivs {
     return ($author,$adv);      return ($author,$adv);
 }  }
   
   sub role_status {
       my ($rolekey,$then,$refresh,$now,$role,$where,$trolecode,$tstatus,$tstart,$tend) = @_;
       my @pwhere = ();
       if (exists($env{$rolekey}) && $env{$rolekey} ne '') {
           (undef,undef,$$role,@pwhere)=split(/\./,$rolekey);
           unless (!defined($$role) || $$role eq '') {
               $$where=join('.',@pwhere);
               $$trolecode=$$role.'.'.$$where;
               ($$tstart,$$tend)=split(/\./,$env{$rolekey});
               $$tstatus='is';
               if ($$tstart && $$tstart>$then) {
                   $$tstatus='future';
                   if ($$tstart && $$tstart>$refresh) {
                       if ($$tstart<$now) {
                           if (($$where ne '') && ($$role ne '')) {
                               my (%allroles,%allgroups,$group_privs);
                               my %userroles = (
                                   'user.role.'.$$role.'.'.$$where => $$tstart.'.'.$$tend
                               );
                               my $spec=$$role.'.'.$$where;
                               my ($tdummy,$tdomain,$trest)=split(/\//,$$where);
                               if ($$role eq 'gr') {
                                   my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
                                                       $env{'user.name'})=@_;
                                   my ($trole) = split('_',$role,1);
                                   (undef,my $group_privs) = split(/\//,$trole);
                                   $group_privs = &unescape($group_privs);
                               }
                               if ($$role =~ /^cr\//) {
                                   &custom_roleprivs(\%allroles,$$role,$tdomain,$trest,$spec,$$where);
                               } elsif ($$role eq 'gr') {
                                   my %rolehash = &get('roles',[$$where.'_'.$$role],$env{'user.domain'},
                                                       $env{'user.name'});
                                   my $trole = split('_',$rolehash{$$where.'_'.$$role},1);
                                   (undef,my $group_privs) = split(/\//,$trole);
                                   $group_privs = &unescape($group_privs);
                                   &group_roleprivs(\%allgroups,$$where,$group_privs,$$tend,$$tstart);
                               } else {
                                   &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where);
                               }
                               my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups);
                               &appenv(\%userroles,[$$role,'cm']);
                               &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
                               $$tstatus = 'is';
                           }
                       }
                   }
               }
               if ($$tend) {
                   if ($$tend<$then) {
                       $$tstatus='expired';
                   } elsif ($$tend<$now) {
                       $$tstatus='will_not';
                   }
               }
           }
       }
   }
   
   sub check_adhoc_privs {
       my ($cdom,$cnum,$then,$refresh,$now,$checkrole) = @_;
       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);
           unless (($tstatus eq 'is') || ($tstatus eq 'will_not')) {
               &set_adhoc_privileges($cdom,$cnum,$checkrole);
           }
       } else {
           &set_adhoc_privileges($cdom,$cnum,$checkrole);
       }
   }
   
   sub set_adhoc_privileges {
   # role can be cc or ca
       my ($dcdom,$pickedcourse,$role) = @_;
       my $area = '/'.$dcdom.'/'.$pickedcourse;
       my $spec = $role.'.'.$area;
       my %userroles = &set_arearole($role,$area,'','',$env{'user.domain'},
                                     $env{'user.name'});
       my %ccrole = ();
       &standard_roleprivs(\%ccrole,$role,$dcdom,$spec,$pickedcourse,$area);
       my ($author,$adv)= &set_userprivs(\%userroles,\%ccrole);
       &appenv(\%userroles,[$role,'cm']);
       &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role);
       &appenv( {'request.role'        => $spec,
                 'request.role.domain' => $dcdom,
                 'request.course.sec'  => ''
                }
              );
       my $tadv=0;
       if (&allowed('adv') eq 'F') { $tadv=1; }
       &appenv({'request.role.adv'    => $tadv});
   }
   
 # --------------------------------------------------------------- get interface  # --------------------------------------------------------------- get interface
   
 sub get {  sub get {
Line 3236  sub del { Line 4165  sub del {
    foreach my $item (@$storearr) {     foreach my $item (@$storearr) {
        $items.=&escape($item).'&';         $items.=&escape($item).'&';
    }     }
   
    $items=~s/\&$//;     $items=~s/\&$//;
    if (!$udomain) { $udomain=$env{'user.domain'}; }     if (!$udomain) { $udomain=$env{'user.domain'}; }
    if (!$uname) { $uname=$env{'user.name'}; }     if (!$uname) { $uname=$env{'user.name'}; }
    my $uhome=&homeserver($uname,$udomain);     my $uhome=&homeserver($uname,$udomain);
   
    return &reply("del:$udomain:$uname:$namespace:$items",$uhome);     return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
 }  }
   
Line 3544  sub tmpget { Line 4473  sub tmpget {
     my %returnhash;      my %returnhash;
     foreach my $item (split(/\&/,$rep)) {      foreach my $item (split(/\&/,$rep)) {
  my ($key,$value)=split(/=/,$item);   my ($key,$value)=split(/=/,$item);
           next if ($key =~ /^error: 2 /);
  $returnhash{&unescape($key)}=&thaw_unescape($value);   $returnhash{&unescape($key)}=&thaw_unescape($value);
     }      }
     return %returnhash;      return %returnhash;
Line 3641  sub get_portfolio_access { Line 4571  sub get_portfolio_access {
             }              }
             if (@users > 0) {              if (@users > 0) {
                 foreach my $userkey (@users) {                  foreach my $userkey (@users) {
                     if (exists($access_hash->{$userkey}{'users'}{$env{'user.name'}.':'.$env{'user.domain'}})) {                      if (ref($access_hash->{$userkey}{'users'}) eq 'ARRAY') {
                         return 'ok';                          foreach my $item (@{$access_hash->{$userkey}{'users'}}) {
                     }                              if (ref($item) eq 'HASH') {
                                   if (($item->{'uname'} eq $env{'user.name'}) &&
                                       ($item->{'udom'} eq $env{'user.domain'})) {
                                       return 'ok';
                                   }
                               }
                           }
                       } 
                 }                  }
             }              }
             my %roleshash;              my %roleshash;
Line 3792  sub is_portfolio_file { Line 4729  sub is_portfolio_file {
     return;      return;
 }  }
   
   sub usertools_access {
       my ($uname,$udom,$tool,$action,$context) = @_;
       my ($access,%tools);
       if ($context eq '') {
           $context = 'tools';
       }
       if ($context eq 'requestcourses') {
           %tools = (
                         official   => 1,
                         unofficial => 1,
                         community  => 1,
                    );
       } else {
           %tools = (
                         aboutme   => 1,
                         blog      => 1,
                         portfolio => 1,
                    );
       }
       return if (!defined($tools{$tool}));
   
       if ((!defined($udom)) || (!defined($uname))) {
           $udom = $env{'user.domain'};
           $uname = $env{'user.name'};
       }
   
       if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
           if ($action ne 'reload') {
               if ($context eq 'requestcourses') {
                   return $env{'environment.canrequest.'.$tool};
               } else {
                   return $env{'environment.availabletools.'.$tool};
               }
           }
       }
   
       my ($toolstatus,$inststatus);
   
       if (($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'}) &&
            ($action ne 'reload')) {
           $toolstatus = $env{'environment.'.$context.'.'.$tool};
           $inststatus = $env{'environment.inststatus'};
       } else {
           my %userenv = &userenvironment($udom,$uname,$context.'.'.$tool);
           $toolstatus = $userenv{$context.'.'.$tool};
           $inststatus = $userenv{'inststatus'};
       }
   
       if ($toolstatus ne '') {
           if ($toolstatus) {
               $access = 1;
           } else {
               $access = 0;
           }
           return $access;
       }
   
       my $is_adv = &is_advanced_user($udom,$uname);
       my %domdef = &get_domain_defaults($udom);
       if (ref($domdef{$tool}) eq 'HASH') {
           if ($is_adv) {
               if ($domdef{$tool}{'_LC_adv'} ne '') {
                   if ($domdef{$tool}{'_LC_adv'}) { 
                       $access = 1;
                   } else {
                       $access = 0;
                   }
                   return $access;
               }
           }
           if ($inststatus ne '') {
               my ($hasaccess,$hasnoaccess);
               foreach my $affiliation (split(/:/,$inststatus)) {
                   if ($domdef{$tool}{$affiliation} ne '') { 
                       if ($domdef{$tool}{$affiliation}) {
                           $hasaccess = 1;
                       } else {
                           $hasnoaccess = 1;
                       }
                   }
               }
               if ($hasaccess || $hasnoaccess) {
                   if ($hasaccess) {
                       $access = 1;
                   } elsif ($hasnoaccess) {
                       $access = 0; 
                   }
                   return $access;
               }
           } else {
               if ($domdef{$tool}{'default'} ne '') {
                   if ($domdef{$tool}{'default'}) {
                       $access = 1;
                   } elsif ($domdef{$tool}{'default'} == 0) {
                       $access = 0;
                   }
                   return $access;
               }
           }
       } else {
           if ($context eq 'tools') {
               $access = 1;
           } else {
               $access = 0;
           }
           return $access;
       }
   }
   
   sub is_advanced_user {
       my ($udom,$uname) = @_;
       my %roleshash = &get_my_roles($uname,$udom,'userroles',undef,undef,undef,1);
       my %allroles;
       my $is_adv;
       foreach my $role (keys(%roleshash)) {
           my ($trest,$tdomain,$trole,$sec) = split(/:/,$role);
           my $area = '/'.$tdomain.'/'.$trest;
           if ($sec ne '') {
               $area .= '/'.$sec;
           }
           if (($area ne '') && ($trole ne '')) {
               my $spec=$trole.'.'.$area;
               if ($trole =~ /^cr\//) {
                   &custom_roleprivs(\%allroles,$trole,$tdomain,$trest,$spec,$area);
               } elsif ($trole ne 'gr') {
                   &standard_roleprivs(\%allroles,$trole,$tdomain,$spec,$trest,$area);
               }
           }
       }
       foreach my $role (keys(%allroles)) {
           last if ($is_adv);
           foreach my $item (split(/:/,$allroles{$role})) {
               if ($item ne '') {
                   my ($privilege,$restrictions)=split(/&/,$item);
                   if ($privilege eq 'adv') {
                       $is_adv = 1;
                       last;
                   }
               }
           }
       }
       return $is_adv;
   }
   
 # ---------------------------------------------- Custom access rule evaluation  # ---------------------------------------------- Custom access rule evaluation
   
Line 3803  sub customaccess { Line 4883  sub customaccess {
     $ucrs = &LONCAPA::clean_username($ucrs);      $ucrs = &LONCAPA::clean_username($ucrs);
     my $access=0;      my $access=0;
     foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {      foreach my $right (split(/\s*\,\s*/,&metadata($uri,'rule_rights'))) {
  my ($effect,$realm,$role)=split(/\:/,$right);   my ($effect,$realm,$role,$type)=split(/\:/,$right);
         if ($role) {   if ($type eq 'user') {
    if ($role ne $urole) { next; }      foreach my $scope (split(/\s*\,\s*/,$realm)) {
         }   my ($tdom,$tuname)=split(m{/},$scope);
         foreach my $scope (split(/\s*\,\s*/,$realm)) {   if ($tdom) {
             my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);      if ($tdom ne $env{'user.domain'}) { next; }
             if ($tdom) {   }
  if ($tdom ne $udom) { next; }   if ($tuname) {
             }      if ($tuname ne $env{'user.name'}) { next; }
             if ($tcrs) {   }
  if ($tcrs ne $ucrs) { next; }   $access=($effect eq 'allow');
             }   last;
             if ($tsec) {      }
  if ($tsec ne $usec) { next; }   } else {
             }      if ($role) {
             $access=($effect eq 'allow');   if ($role ne $urole) { next; }
             last;      }
         }      foreach my $scope (split(/\s*\,\s*/,$realm)) {
  if ($realm eq '' && $role eq '') {   my ($tdom,$tcrs,$tsec)=split(/\_/,$scope);
             $access=($effect eq 'allow');   if ($tdom) {
       if ($tdom ne $udom) { next; }
    }
    if ($tcrs) {
       if ($tcrs ne $ucrs) { next; }
    }
    if ($tsec) {
       if ($tsec ne $usec) { next; }
    }
    $access=($effect eq 'allow');
    last;
       }
       if ($realm eq '' && $role eq '') {
    $access=($effect eq 'allow');
       }
  }   }
     }      }
     return $access;      return $access;
Line 3990  sub allowed { Line 5084  sub allowed {
     }      }
           
 # Full access at system, domain or course-wide level? Exit.  # Full access at system, domain or course-wide level? Exit.
   
     if ($thisallowed=~/F/) {      if ($thisallowed=~/F/) {
  return 'F';   return 'F';
     }      }
Line 4094  sub allowed { Line 5187  sub allowed {
   
     my $envkey;      my $envkey;
     if ($thisallowed=~/L/) {      if ($thisallowed=~/L/) {
         foreach $envkey (keys %env) {          foreach $envkey (keys(%env)) {
            if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {             if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
                my $courseid=$2;                 my $courseid=$2;
                my $roleid=$1.'.'.$2;                 my $roleid=$1.'.'.$2;
Line 4343  sub log_query { Line 5436  sub log_query {
   
 sub update_portfolio_table {  sub update_portfolio_table {
     my ($uname,$udom,$file_name,$query,$group,$action) = @_;      my ($uname,$udom,$file_name,$query,$group,$action) = @_;
       if ($group ne '') {
           $file_name =~s /^\Q$group\E//;
       }
     my $homeserver = &homeserver($uname,$udom);      my $homeserver = &homeserver($uname,$udom);
     my $queryid=      my $queryid=
         &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).          &reply("querysend:".$query.':'.&escape($uname.':'.$udom.':'.$group).
Line 4351  sub update_portfolio_table { Line 5447  sub update_portfolio_table {
     return $reply;      return $reply;
 }  }
   
   # -------------------------- Update MySQL allusers table
   
   sub update_allusers_table {
       my ($uname,$udom,$names) = @_;
       my $homeserver = &homeserver($uname,$udom);
       my $queryid=
           &reply('querysend:allusers:'.&escape($uname).':'.&escape($udom).':'.
                  'lastname='.&escape($names->{'lastname'}).'%%'.
                  'firstname='.&escape($names->{'firstname'}).'%%'.
                  'middlename='.&escape($names->{'middlename'}).'%%'.
                  'generation='.&escape($names->{'generation'}).'%%'.
                  'permanentemail='.&escape($names->{'permanentemail'}).'%%'.
                  'id='.&escape($names->{'id'}),$homeserver);
       my $reply = &get_query_reply($queryid);
       return $reply;
   }
   
 # ------- Request retrieval of institutional classlists for course(s)  # ------- Request retrieval of institutional classlists for course(s)
   
 sub fetch_enrollment_query {  sub fetch_enrollment_query {
Line 4365  sub fetch_enrollment_query { Line 5478  sub fetch_enrollment_query {
     }      }
     my $host=&hostname($homeserver);      my $host=&hostname($homeserver);
     my $cmd = '';      my $cmd = '';
     foreach my $affiliate (keys %{$affiliatesref}) {      foreach my $affiliate (keys(%{$affiliatesref})) {
         $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';          $cmd .= $affiliate.'='.join(",",@{$$affiliatesref{$affiliate}}).'%%';
     }      }
     $cmd =~ s/%%$//;      $cmd =~ s/%%$//;
Line 4385  sub fetch_enrollment_query { Line 5498  sub fetch_enrollment_query {
     if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {      if ( ($reply =~/^timeout/) || ($reply =~/^error/) ) {
         &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);          &logthis('fetch_enrollment_query error: '.$reply.' for '.$dom.' '.$env{'user.name'}.' for '.$queryid.' context: '.$context.' '.$cnum.' maxtries: '.$maxtries.' tries: '.$tries);
     } else {      } else {
         my @responses = split/:/,$reply;          my @responses = split(/:/,$reply);
         if ($homeserver eq $perlvar{'lonHostID'}) {          if ($homeserver eq $perlvar{'lonHostID'}) {
             foreach my $line (@responses) {              foreach my $line (@responses) {
                 my ($key,$value) = split(/=/,$line,2);                  my ($key,$value) = split(/=/,$line,2);
Line 4428  sub get_query_reply { Line 5541  sub get_query_reply {
  sleep 2;   sleep 2;
         if (-e $replyfile.'.end') {          if (-e $replyfile.'.end') {
     if (open(my $fh,$replyfile)) {      if (open(my $fh,$replyfile)) {
                $reply.=<$fh>;   $reply = join('',<$fh>);
                close($fh);   close($fh);
    } else { return 'error: reply_file_error'; }     } else { return 'error: reply_file_error'; }
            return &unescape($reply);             return &unescape($reply);
  }   }
Line 4474  sub userlog_query { Line 5587  sub userlog_query {
   
 sub auto_run {  sub auto_run {
     my ($cnum,$cdom) = @_;      my ($cnum,$cdom) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $response = 0;
     my $response = &reply('autorun:'.$cdom,$homeserver);      my $settings;
       my %domconfig = &get_dom('configuration',['autoenroll'],$cdom);
       if (ref($domconfig{'autoenroll'}) eq 'HASH') {
           $settings = $domconfig{'autoenroll'};
           if ($settings->{'run'} eq '1') {
               $response = 1;
           }
       } else {
           my $homeserver;
           if (&is_course($cdom,$cnum)) {
               $homeserver = &homeserver($cnum,$cdom);
           } else {
               $homeserver = &domain($cdom,'primary');
           }
           if ($homeserver ne 'no_host') {
               $response = &reply('autorun:'.$cdom,$homeserver);
           }
       }
     return $response;      return $response;
 }  }
   
 sub auto_get_sections {  sub auto_get_sections {
     my ($cnum,$cdom,$inst_coursecode) = @_;      my ($cnum,$cdom,$inst_coursecode) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver;
     my @secs = ();      if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) { 
     my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));          $homeserver = &homeserver($cnum,$cdom);
     unless ($response eq 'refused') {      }
         @secs = split/:/,$response;      if (!defined($homeserver)) { 
           if ($cdom =~ /^$match_domain$/) {
               $homeserver = &domain($cdom,'primary');
           }
       }
       my @secs;
       if (defined($homeserver)) {
           my $response=&unescape(&reply('autogetsections:'.$inst_coursecode.':'.$cdom,$homeserver));
           unless ($response eq 'refused') {
               @secs = split(/:/,$response);
           }
     }      }
     return @secs;      return @secs;
 }  }
Line 4504  sub auto_validate_courseID { Line 5644  sub auto_validate_courseID {
     return $response;      return $response;
 }  }
   
   sub auto_validate_instcode {
       my ($cnum,$cdom,$instcode,$owner) = @_;
       my ($homeserver,$response);
       if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
           $homeserver = &homeserver($cnum,$cdom);
       }
       if (!defined($homeserver)) {
           if ($cdom =~ /^$match_domain$/) {
               $homeserver = &domain($cdom,'primary');
           }
       }
       my $response=&unescape(&reply('autovalidateinstcode:'.$cdom.':'.
                              &escape($instcode).':'.&escape($owner),$homeserver));
       return $response;
   }
   
 sub auto_create_password {  sub auto_create_password {
     my ($cnum,$cdom,$authparam) = @_;      my ($cnum,$cdom,$authparam,$udom) = @_;
     my $homeserver = &homeserver($cnum,$cdom);       my ($homeserver,$response);
     my $create_passwd = 0;      my $create_passwd = 0;
     my $authchk = '';      my $authchk = '';
     my $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));      if ($udom =~ /^$match_domain$/) {
     if ($response eq 'refused') {          $homeserver = &domain($udom,'primary');
         $authchk = 'refused';      }
       if ($homeserver eq '') {
           if (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/)) {
               $homeserver = &homeserver($cnum,$cdom);
           }
       }
       if ($homeserver eq '') {
           $authchk = 'nodomain';
     } else {      } else {
         ($authparam,$create_passwd,$authchk) = split/:/,$response;          $response=&unescape(&reply('autocreatepassword:'.$authparam.':'.$cdom,$homeserver));
           if ($response eq 'refused') {
               $authchk = 'refused';
           } else {
               ($authparam,$create_passwd,$authchk) = split(/:/,$response);
           }
     }      }
     return ($authparam,$create_passwd,$authchk);      return ($authparam,$create_passwd,$authchk);
 }  }
Line 4620  sub auto_instcode_format { Line 5788  sub auto_instcode_format {
         $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);          $response=&reply('autoinstcodeformat:'.$codedom.':'.$courses,$server);
         if ($response !~ /(con_lost|error|no_such_host|refused)/) {          if ($response !~ /(con_lost|error|no_such_host|refused)/) {
             my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) =               my ($codes_str,$codetitles_str,$cat_titles_str,$cat_order_str) = 
  split/:/,$response;   split(/:/,$response);
             %{$codes} = (%{$codes},&str2hash($codes_str));              %{$codes} = (%{$codes},&str2hash($codes_str));
             push(@{$codetitles},&str2array($codetitles_str));              push(@{$codetitles},&str2array($codetitles_str));
             %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));              %{$cat_titles} = (%{$cat_titles},&str2hash($cat_titles_str));
Line 4663  sub auto_instcode_defaults { Line 5831  sub auto_instcode_defaults {
     }      }
   
     return $response;      return $response;
 }   }
   
   sub auto_possible_instcodes {
       my ($domain,$codetitles,$cat_titles,$cat_orders,$code_order) = @_;
       unless ((ref($codetitles) eq 'ARRAY') && (ref($cat_titles) eq 'HASH') && 
               (ref($cat_orders) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
           return;
       }
       my (@homeservers,$uhome);
       if (defined(&domain($domain,'primary'))) {
           $uhome=&domain($domain,'primary');
           push(@homeservers,&domain($domain,'primary'));
       } else {
           my %servers = &get_servers($domain,'library');
           foreach my $tryserver (keys(%servers)) {
               if (!grep(/^\Q$tryserver\E$/,@homeservers)) {
                   push(@homeservers,$tryserver);
               }
           }
       }
       my $response;
       foreach my $server (@homeservers) {
           $response=&reply('autopossibleinstcodes:'.$domain,$server);
           next if ($response =~ /(con_lost|error|no_such_host|refused)/);
           my ($codetitlestr,$codeorderstr,$cat_title,$cat_order) = 
               split(':',$response);
           @{$codetitles} = map { &unescape($_); } (split('&',$codetitlestr));
           @{$code_order} = map { &unescape($_); } (split('&',$codeorderstr));
           foreach my $item (split('&',$cat_title)) {   
               my ($name,$value)=split('=',$item);
               $cat_titles->{&unescape($name)}=&thaw_unescape($value);
           }
           foreach my $item (split('&',$cat_order)) {
               my ($name,$value)=split('=',$item);
               $cat_orders->{&unescape($name)}=&thaw_unescape($value);
           }
           return 'ok';
       }
       return $response;
   }
   
   sub auto_courserequest_checks {
       my ($dom) = @_;
       my %validations;
       return %validations; 
   }
   
   sub auto_courserequest_validation {
       my ($dom,$details,$inststatuses,$message) = @_;
       return 'pending';
   }
   
 sub auto_validate_class_sec {  sub auto_validate_class_sec {
     my ($cdom,$cnum,$owner,$inst_class) = @_;      my ($cdom,$cnum,$owners,$inst_class) = @_;
     my $homeserver = &homeserver($cnum,$cdom);      my $homeserver = &homeserver($cnum,$cdom);
       my $ownerlist;
       if (ref($owners) eq 'ARRAY') {
           $ownerlist = join(',',@{$owners});
       } else {
           $ownerlist = $owners;
       }
     my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.      my $response=&reply('autovalidateclass_sec:'.$inst_class.':'.
                         &escape($owner).':'.$cdom,$homeserver);                          &escape($ownerlist).':'.$cdom,$homeserver);
     return $response;      return $response;
 }  }
   
Line 4717  sub toggle_coursegroup_status { Line 5941  sub toggle_coursegroup_status {
 }  }
   
 sub modify_group_roles {  sub modify_group_roles {
     my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs) = @_;      my ($cdom,$cnum,$group_id,$user,$end,$start,$userprivs,$selfenroll,$context) = @_;
     my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;      my $url = '/'.$cdom.'/'.$cnum.'/'.$group_id;
     my $role = 'gr/'.&escape($userprivs);      my $role = 'gr/'.&escape($userprivs);
     my ($uname,$udom) = split(/:/,$user);      my ($uname,$udom) = split(/:/,$user);
     my $result = &assignrole($udom,$uname,$url,$role,$end,$start);      my $result = &assignrole($udom,$uname,$url,$role,$end,$start,'',$selfenroll,$context);
     if ($result eq 'ok') {      if ($result eq 'ok') {
         &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);          &devalidate_getgroups_cache($udom,$uname,$cdom,$cnum);
     }      }
Line 4810  sub devalidate_getgroups_cache { Line 6034  sub devalidate_getgroups_cache {
 # ------------------------------------------------------------------ Plain Text  # ------------------------------------------------------------------ Plain Text
   
 sub plaintext {  sub plaintext {
     my ($short,$type,$cid) = @_;      my ($short,$type,$cid,$forcedefault) = @_;
     if ($short =~ /^cr/) {      if ($short =~ /^cr/) {
  return (split('/',$short))[-1];   return (split('/',$short))[-1];
     }      }
     if (!defined($cid)) {      if (!defined($cid)) {
         $cid = $env{'request.course.id'};          $cid = $env{'request.course.id'};
     }      }
     if (defined($cid) && defined($env{'course.'.$cid.'.'.$short.'.plaintext'})) {      if (defined($cid) && ($env{'course.'.$cid.'.'.$short.'.plaintext'} ne '')) {
         return &Apache::lonlocal::mt($env{'course.'.$cid.'.'.$short.          unless ($forcedefault) {
                                           '.plaintext'});              my $roletext = $env{'course.'.$cid.'.'.$short.'.plaintext'}; 
               &Apache::lonlocal::mt_escape(\$roletext);
               return &Apache::lonlocal::mt($roletext);
           }
     }      }
     my %rolenames = (      my %rolenames = (
                       Course => 'std',                        Course    => 'std',
                       Group => 'alt1',                        Community => 'alt1',
                     );                      );
     if (defined($type) &&       if (defined($type) && 
          defined($rolenames{$type}) &&            defined($rolenames{$type}) && 
Line 4837  sub plaintext { Line 6064  sub plaintext {
 # ----------------------------------------------------------------- Assign Role  # ----------------------------------------------------------------- Assign Role
   
 sub assignrole {  sub assignrole {
     my ($udom,$uname,$url,$role,$end,$start,$deleteflag)=@_;      my ($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,
           $context)=@_;
     my $mrole;      my $mrole;
     if ($role =~ /^cr\//) {      if ($role =~ /^cr\//) {
         my $cwosec=$url;          my $cwosec=$url;
Line 4862  sub assignrole { Line 6090  sub assignrole {
     } else {      } else {
         my $cwosec=$url;          my $cwosec=$url;
         $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;          $cwosec=~s/^\/($match_domain)\/($match_courseid)\/.*/$1\/$2/;
         unless ((&allowed('c'.$role,$cwosec)) || &allowed('c'.$role,$udom)) {           if (!(&allowed('c'.$role,$cwosec)) && !(&allowed('c'.$role,$udom))) {
            &logthis('Refused assignrole: '.              my $refused;
              $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.              if (($env{'request.course.sec'}  ne '') && ($role eq 'st')) {
     $env{'user.name'}.' at '.$env{'user.domain'});                  if (!(&allowed('c'.$role,$url))) {
            return 'refused';                       $refused = 1;
                   }
               } else {
                   $refused = 1;
               }
               if ($refused) {
                   if (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
                       $refused = '';
                   } elsif ($context eq 'requestcourses') {
                       if (($role eq 'cc') && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
                           my ($cdom,$cnum) = ($cwosec =~ m{^/($match_domain)/($match_courseid)$});
                           my %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
                           if ($crsenv{'internal.courseowner'} eq 
                                $env{'user.name'}.':'.$env{'user.domain'}) {
                               $refused = '';
                           }
                       }
                   }
                   if ($refused) {
                       &logthis('Refused assignrole: '.$udom.' '.$uname.' '.$url.
                                ' '.$role.' '.$end.' '.$start.' by '.
                  $env{'user.name'}.' at '.$env{'user.domain'});
                       return 'refused';
                   }
               }
         }          }
         $mrole=$role;          $mrole=$role;
     }      }
Line 4882  sub assignrole { Line 6134  sub assignrole {
     }      }
     my $origstart = $start;      my $origstart = $start;
     my $origend = $end;      my $origend = $end;
       my $delflag;
 # actually delete  # actually delete
     if ($deleteflag) {      if ($deleteflag) {
  if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {   if ((&allowed('dro',$udom)) || (&allowed('dro',$url))) {
Line 4892  sub assignrole { Line 6145  sub assignrole {
 # set start and finish to negative values for userrolelog  # set start and finish to negative values for userrolelog
            $start=-1;             $start=-1;
            $end=-1;             $end=-1;
              $delflag = 1;
         }          }
     }      }
 # send command  # send command
Line 4900  sub assignrole { Line 6154  sub assignrole {
     if ($answer eq 'ok') {      if ($answer eq 'ok') {
  &userrolelog($role,$uname,$udom,$url,$start,$end);   &userrolelog($role,$uname,$udom,$url,$start,$end);
 # for course roles, perform group memberships changes triggered by role change.  # for course roles, perform group memberships changes triggered by role change.
           &courserolelog($role,$uname,$udom,$url,$origstart,$origend,$delflag,$selfenroll,$context);
         unless ($role =~ /^gr/) {          unless ($role =~ /^gr/) {
             &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,              &Apache::longroup::group_changes($udom,$uname,$url,$role,$origend,
                                              $origstart);                                               $origstart,$selfenroll,$context);
         }          }
     }      }
     return $answer;      return $answer;
Line 4940  sub modifyuser { Line 6195  sub modifyuser {
     my ($udom,    $uname, $uid,      my ($udom,    $uname, $uid,
         $umode,   $upass, $first,          $umode,   $upass, $first,
         $middle,  $last,  $gene,          $middle,  $last,  $gene,
         $forceid, $desiredhome, $email)=@_;          $forceid, $desiredhome, $email, $inststatus)=@_;
     $udom= &LONCAPA::clean_domain($udom);      $udom= &LONCAPA::clean_domain($udom);
     $uname=&LONCAPA::clean_username($uname);      $uname=&LONCAPA::clean_username($uname);
     &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.      &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
Line 5000  sub modifyuser { Line 6255  sub modifyuser {
     }      }
 # -------------------------------------------------------------- Add names, etc  # -------------------------------------------------------------- Add names, etc
     my @tmp=&get('environment',      my @tmp=&get('environment',
    ['firstname','middlename','lastname','generation'],     ['firstname','middlename','lastname','generation','id',
                       'permanentemail','inststatus'],
    $udom,$uname);     $udom,$uname);
     my %names;      my %names;
     if ($tmp[0] =~ m/^error:.*/) {       if ($tmp[0] =~ m/^error:.*/) { 
Line 5018  sub modifyuser { Line 6274  sub modifyuser {
     if (defined($gene))   { $names{'generation'} = $gene; }      if (defined($gene))   { $names{'generation'} = $gene; }
     if ($email) {      if ($email) {
        $email=~s/[^\w\@\.\-\,]//gs;         $email=~s/[^\w\@\.\-\,]//gs;
        if ($email=~/\@/) { $names{'notification'} = $email;         if ($email=~/\@/) { $names{'permanentemail'} = $email; }
    $names{'critnotification'} = $email;      }
    $names{'permanentemail'} = $email; }      if ($uid) { $names{'id'}  = $uid; }
       if (defined($inststatus)) {
           $names{'inststatus'} = '';
           my ($usertypes,$typesorder) = &retrieve_inst_usertypes($udom);
           if (ref($usertypes) eq 'HASH') {
               my @okstatuses; 
               foreach my $item (split(/:/,$inststatus)) {
                   if (defined($usertypes->{$item})) {
                       push(@okstatuses,$item);  
                   }
               }
               if (@okstatuses) {
                   $names{'inststatus'} = join(':', map { &escape($_); } @okstatuses);
               }
           }
     }      }
     my $reply = &put('environment', \%names, $udom,$uname);      my $reply = &put('environment', \%names, $udom,$uname);
     if ($reply ne 'ok') { return 'error: '.$reply; }      if ($reply ne 'ok') { return 'error: '.$reply; }
       my $sqlresult = &update_allusers_table($uname,$udom,\%names);
     &devalidate_cache_new('namescache',$uname.':'.$udom);      &devalidate_cache_new('namescache',$uname.':'.$udom);
     &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.      my $logmsg = 'Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
              $umode.', '.$first.', '.$middle.', '.                   $umode.', '.$first.', '.$middle.', '.
      $last.', '.$gene.' by '.           $last.', '.$gene.', '.$email.', '.$inststatus;
              $env{'user.name'}.' at '.$env{'user.domain'});      if ($env{'user.name'} ne '' && $env{'user.domain'}) {
           $logmsg .= ' by '.$env{'user.name'}.' at '.$env{'user.domain'};
       } else {
           $logmsg .= ' during self creation';
       }
       &logthis($logmsg);
     return 'ok';      return 'ok';
 }  }
   
Line 5036  sub modifyuser { Line 6312  sub modifyuser {
   
 sub modifystudent {  sub modifystudent {
     my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,      my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
         $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid)=@_;          $end,$start,$forceid,$desiredhome,$email,$type,$locktype,$cid,
           $selfenroll,$context,$inststatus)=@_;
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
     return 'not_in_class';      return 'not_in_class';
Line 5045  sub modifystudent { Line 6322  sub modifystudent {
 # --------------------------------------------------------------- Make the user  # --------------------------------------------------------------- Make the user
     my $reply=&modifyuser      my $reply=&modifyuser
  ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,   ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$forceid,
          $desiredhome,$email);           $desiredhome,$email,$inststatus);
     unless ($reply eq 'ok') { return $reply; }      unless ($reply eq 'ok') { return $reply; }
     # This will cause &modify_student_enrollment to get the uid from the      # This will cause &modify_student_enrollment to get the uid from the
     # students environment      # students environment
     $uid = undef if (!$forceid);      $uid = undef if (!$forceid);
     $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,      $reply = &modify_student_enrollment($udom,$uname,$uid,$first,$middle,$last,
  $gene,$usec,$end,$start,$type,$locktype,$cid);   $gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context);
     return $reply;      return $reply;
 }  }
   
 sub modify_student_enrollment {  sub modify_student_enrollment {
     my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid) = @_;      my ($udom,$uname,$uid,$first,$middle,$last,$gene,$usec,$end,$start,$type,$locktype,$cid,$selfenroll,$context) = @_;
     my ($cdom,$cnum,$chome);      my ($cdom,$cnum,$chome);
     if (!$cid) {      if (!$cid) {
  unless ($cid=$env{'request.course.id'}) {   unless ($cid=$env{'request.course.id'}) {
Line 5114  sub modify_student_enrollment { Line 6391  sub modify_student_enrollment {
     if ($usec) {      if ($usec) {
  $uurl.='/'.$usec;   $uurl.='/'.$usec;
     }      }
     return &assignrole($udom,$uname,$uurl,'st',$end,$start);      return &assignrole($udom,$uname,$uurl,'st',$end,$start,undef,$selfenroll,$context);
 }  }
   
 sub format_name {  sub format_name {
Line 5159  sub writecoursepref { Line 6436  sub writecoursepref {
   
 sub createcourse {  sub createcourse {
     my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,      my ($udom,$description,$url,$course_server,$nonstandard,$inst_code,
         $course_owner,$crstype)=@_;          $course_owner,$crstype,$cnum,$context,$category)=@_;
     $url=&declutter($url);      $url=&declutter($url);
     my $cid='';      my $cid='';
     unless (&allowed('ccc',$udom)) {      unless (&allowed('ccc',$udom)) {
         return 'refused';          if ($context eq 'requestcourses') {
               unless (&usertools_access($course_owner,$udom,$category,undef,$context)) {
                   return 'refused';
               }
           } else {
               return 'refused';
           }
     }      }
 # ------------------------------------------------------------------- Create ID  # --------------------------------------------------------------- Get Unique ID
    my $uname=int(1+rand(9)).      my $uname;
        ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].      if ($cnum =~ /^$match_courseid$/) {
        substr($$.time,0,5).unpack("H8",pack("I32",time)).          my $chome=&homeserver($cnum,$udom,'true');
        unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};          if (($chome eq '') || ($chome eq 'no_host')) {
 # ----------------------------------------------- Make sure that does not exist              $uname = $cnum;
    my $uhome=&homeserver($uname,$udom,'true');          } else {
    unless (($uhome eq '') || ($uhome eq 'no_host')) {              $uname = &generate_coursenum($udom);
        $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).          }
         unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};      } else {
        $uhome=&homeserver($uname,$udom,'true');                 $uname = &generate_coursenum($udom);
        unless (($uhome eq '') || ($uhome eq 'no_host')) {      }
            return 'error: unable to generate unique course-ID';      return $uname if ($uname =~ /^error/);
        }   # -------------------------------------------------- Check supplied server name
    }  
 # ------------------------------------------------ Check supplied server name  
     $course_server = $env{'user.homeserver'} if (! defined($course_server));      $course_server = $env{'user.homeserver'} if (! defined($course_server));
     if (! &is_library($course_server)) {      if (! &is_library($course_server)) {
         return 'error:bad server name '.$course_server;          return 'error:bad server name '.$course_server;
Line 5189  sub createcourse { Line 6470  sub createcourse {
     my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',      my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
                       $course_server);                        $course_server);
     unless ($reply eq 'ok') { return 'error: '.$reply; }      unless ($reply eq 'ok') { return 'error: '.$reply; }
     $uhome=&homeserver($uname,$udom,'true');      my $uhome=&homeserver($uname,$udom,'true');
     if (($uhome eq '') || ($uhome eq 'no_host')) {       if (($uhome eq '') || ($uhome eq 'no_host')) { 
  return 'error: no such course';   return 'error: no such course';
     }      }
 # ----------------------------------------------------------------- Course made  # ----------------------------------------------------------------- Course made
 # log existence  # log existence
     &courseidput($udom,&escape($udom.'_'.$uname).'='.&escape($description).      my $newcourse = {
                  ':'.&escape($inst_code).':'.&escape($course_owner).':'.                      $udom.'_'.$uname => {
                   &escape($crstype),$uhome);                                       description => $description,
     &flushcourselogs();                                       inst_code   => $inst_code,
                                        owner       => $course_owner,
                                        type        => $crstype,
                                                   },
                       };
       &courseidput($udom,$newcourse,$uhome,'notime');
 # set toplevel url  # set toplevel url
     my $topurl=$url;      my $topurl=$url;
     unless ($nonstandard) {      unless ($nonstandard) {
Line 5225  ENDINITMAP Line 6511  ENDINITMAP
     return '/'.$udom.'/'.$uname;      return '/'.$udom.'/'.$uname;
 }  }
   
   # ------------------------------------------------------------------- Create ID
   sub generate_coursenum {
       my ($udom) = @_;
       my $domdesc = &domain($udom);
       return 'error: invalid domain' if ($domdesc eq '');
       my $uname=int(1+rand(9)).
           ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
           substr($$.time,0,5).unpack("H8",pack("I32",time)).
           unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
   # ----------------------------------------------- Make sure that does not exist
       my $uhome=&homeserver($uname,$udom,'true');
       unless (($uhome eq '') || ($uhome eq 'no_host')) {
           $uname=int(1+rand(9)).
                  ('a'..'z','A'..'Z','0'..'9')[int(rand(62))].
                  substr($$.time,0,5).unpack("H8",pack("I32",time)).
                  unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
           $uhome=&homeserver($uname,$udom,'true');
           unless (($uhome eq '') || ($uhome eq 'no_host')) {
               return 'error: unable to generate unique course-ID';
           }
       }
       return $uname;
   }
   
 sub is_course {  sub is_course {
     my ($cdom,$cnum) = @_;      my ($cdom,$cnum) = @_;
     my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,      my %courses = &courseiddump($cdom,'.',1,'.','.',$cnum,undef,
Line 5235  sub is_course { Line 6545  sub is_course {
     return 0;      return 0;
 }  }
   
   sub store_userdata {
       my ($storehash,$datakey,$namespace,$udom,$uname) = @_;
       my $result;
       if ($datakey ne '') {
           if (ref($storehash) eq 'HASH') {
               if ($udom eq '' || $uname eq '') {
                   $udom = $env{'user.domain'};
                   $uname = $env{'user.name'};
               }
               my $uhome=&homeserver($uname,$udom);
               if (($uhome eq '') || ($uhome eq 'no_host')) {
                   $result = 'error: no_host';
               } else {
                   $storehash->{'ip'} = $ENV{'REMOTE_ADDR'};
                   $storehash->{'host'} = $perlvar{'lonHostID'};
   
                   my $namevalue='';
                   foreach my $key (keys(%{$storehash})) {
                       $namevalue.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&';
                   }
                   $namevalue=~s/\&$//;
                   $result =  &reply("store:$env{'user.domain'}:$env{'user.name'}:".
                                     "$namespace:$datakey:$namevalue",$uhome);
               }
           } else {
               $result = 'error: data to store was not a hash reference'; 
           }
       } else {
           $result= 'error: invalid requestkey'; 
       }
       return $result;
   }
   
 # ---------------------------------------------------------- Assign Custom Role  # ---------------------------------------------------------- Assign Custom Role
   
 sub assigncustomrole {  sub assigncustomrole {
     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag)=@_;      my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start,$deleteflag,$selfenroll,$context)=@_;
     return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,      return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
                        $end,$start,$deleteflag);                         $end,$start,$deleteflag,$selfenroll,$context);
 }  }
   
 # ----------------------------------------------------------------- Revoke Role  # ----------------------------------------------------------------- Revoke Role
   
 sub revokerole {  sub revokerole {
     my ($udom,$uname,$url,$role,$deleteflag)=@_;      my ($udom,$uname,$url,$role,$deleteflag,$selfenroll,$context)=@_;
     my $now=time;      my $now=time;
     return &assignrole($udom,$uname,$url,$role,$now,$deleteflag);      return &assignrole($udom,$uname,$url,$role,$now,undef,$deleteflag,$selfenroll,$context);
 }  }
   
 # ---------------------------------------------------------- Revoke Custom Role  # ---------------------------------------------------------- Revoke Custom Role
   
 sub revokecustomrole {  sub revokecustomrole {
     my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag)=@_;      my ($udom,$uname,$url,$rdom,$rnam,$rolename,$deleteflag,$selfenroll,$context)=@_;
     my $now=time;      my $now=time;
     return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,      return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now,
            $deleteflag);             $deleteflag,$selfenroll,$context);
 }  }
   
 # ------------------------------------------------------------ Disk usage  # ------------------------------------------------------------ Disk usage
 sub diskusage {  sub diskusage {
     my ($udom,$uname,$directoryRoot)=@_;      my ($udom,$uname,$directorypath,$getpropath)=@_;
     $directoryRoot =~ s/\/$//;      $directorypath =~ s/\/$//;
     my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));      my $listing=&reply('du2:'.&escape($directorypath).':'
                          .&escape($getpropath).':'.&escape($uname).':'
                          .&escape($udom),homeserver($uname,$udom));
       if ($listing eq 'unknown_cmd') {
           if ($getpropath) {
               $directorypath = &propath($udom,$uname).'/'.$directorypath; 
           }
           $listing = &reply('du:'.$directorypath,homeserver($uname,$udom));
       }
     return $listing;      return $listing;
 }  }
   
Line 5318  sub save_selected_files { Line 6669  sub save_selected_files {
     my ($user, $path, @files) = @_;      my ($user, $path, @files) = @_;
     my $filename = $user."savedfiles";      my $filename = $user."savedfiles";
     my @other_files = &files_not_in_path($user, $path);      my @other_files = &files_not_in_path($user, $path);
     open (OUT, '>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/tmp/'.$filename);      open (OUT, '>'.$tmpdir.$filename);
     foreach my $file (@files) {      foreach my $file (@files) {
         print (OUT $env{'form.currentpath'}.$file."\n");          print (OUT $env{'form.currentpath'}.$file."\n");
     }      }
Line 5505  sub modify_access_controls { Line 6856  sub modify_access_controls {
                 }                  }
             }              }
         }          }
           my ($group);
           if (&is_course($domain,$user)) {
               ($group,my $file) = split(/\//,$file_name,2);
           }
         $deloutcome = &del('file_permissions',\@deletions,$domain,$user);          $deloutcome = &del('file_permissions',\@deletions,$domain,$user);
         $new_values{$file_name."\0".'accesscontrol'} = \%new_control;          $new_values{$file_name."\0".'accesscontrol'} = \%new_control;
         $outcome = &put('file_permissions',\%new_values,$domain,$user);          $outcome = &put('file_permissions',\%new_values,$domain,$user);
         #  remove lock          #  remove lock
         my @del_lock = ($file_name."\0".'locked_access_records');          my @del_lock = ($file_name."\0".'locked_access_records');
         my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);          my $dellockoutcome = &del('file_permissions',\@del_lock,$domain,$user);
         my ($file,$group);  
         if (&is_course($domain,$user)) {  
             ($group,$file) = split(/\//,$file_name,2);  
         } else {  
             $file = $file_name;  
         }  
         my $sqlresult =          my $sqlresult =
             &update_portfolio_table($user,$domain,$file,'portfolio_access',              &update_portfolio_table($user,$domain,$file_name,'portfolio_access',
                                     $group);                                      $group);
     } else {      } else {
         $outcome = "error: could not obtain lockfile\n";            $outcome = "error: could not obtain lockfile\n";  
Line 5681  sub unmark_as_readonly { Line 7030  sub unmark_as_readonly {
 # ------------------------------------------------------------ Directory lister  # ------------------------------------------------------------ Directory lister
   
 sub dirlist {  sub dirlist {
     my ($uri,$userdomain,$username,$alternateDirectoryRoot)=@_;      my ($uri,$userdomain,$username,$getpropath,$getuserdir,$alternateRoot)=@_;
   
     $uri=~s/^\///;      $uri=~s/^\///;
     $uri=~s/\/$//;      $uri=~s/\/$//;
     my ($udom, $uname);      my ($udom, $uname);
     (undef,$udom,$uname)=split(/\//,$uri);      if ($getuserdir) {
     if(defined($userdomain)) {  
         $udom = $userdomain;          $udom = $userdomain;
     }  
     if(defined($username)) {  
         $uname = $username;          $uname = $username;
       } else {
           (undef,$udom,$uname)=split(/\//,$uri);
           if(defined($userdomain)) {
               $udom = $userdomain;
           }
           if(defined($username)) {
               $uname = $username;
           }
     }      }
       my ($dirRoot,$listing,@listing_results);
   
     my $dirRoot = $perlvar{'lonDocRoot'};      $dirRoot = $perlvar{'lonDocRoot'};
     if(defined($alternateDirectoryRoot)) {      if (defined($getpropath)) {
         $dirRoot = $alternateDirectoryRoot;          $dirRoot = &propath($udom,$uname);
         $dirRoot =~ s/\/$//;          $dirRoot =~ s/\/$//;
       } elsif (defined($getuserdir)) {
           my $subdir=$uname.'__';
           $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
           $dirRoot = $Apache::lonnet::perlvar{'lonUsersDir'}
                      ."/$udom/$subdir/$uname";
       } elsif (defined($alternateRoot)) {
           $dirRoot = $alternateRoot;
     }      }
   
     if($udom) {      if($udom) {
         if($uname) {          if($uname) {
             my $listing = &reply('ls2:'.$dirRoot.'/'.$uri,              $listing = &reply('ls3:'.&escape('/'.$uri).':'.$getpropath.':'
  &homeserver($uname,$udom));                                .$getuserdir.':'.&escape($dirRoot)
             my @listing_results;                                .':'.&escape($uname).':'.&escape($udom),
                                 &homeserver($uname,$udom));
               if ($listing eq 'unknown_cmd') {
                   $listing = &reply('ls2:'.$dirRoot.'/'.$uri,
                                     &homeserver($uname,$udom));
               } else {
                   @listing_results = map { &unescape($_); } split(/:/,$listing);
               }
             if ($listing eq 'unknown_cmd') {              if ($listing eq 'unknown_cmd') {
                 $listing = &reply('ls:'.$dirRoot.'/'.$uri,                  $listing = &reply('ls:'.$dirRoot.'/'.$uri,
   &homeserver($uname,$udom));    &homeserver($uname,$udom));
Line 5713  sub dirlist { Line 7081  sub dirlist {
                 @listing_results = map { &unescape($_); } split(/:/,$listing);                  @listing_results = map { &unescape($_); } split(/:/,$listing);
             }              }
             return @listing_results;              return @listing_results;
         } elsif(!defined($alternateDirectoryRoot)) {          } elsif(!$alternateRoot) {
             my %allusers;              my %allusers;
     my %servers = &get_servers($udom,'library');      my %servers = &get_servers($udom,'library');
     foreach my $tryserver (keys(%servers)) {       foreach my $tryserver (keys(%servers)) {
  my $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.                  $listing = &reply('ls3:'.&escape("/res/$udom").':::::'.
      $udom, $tryserver);                                    &escape($udom),$tryserver);
  my @listing_results;                  if ($listing eq 'unknown_cmd') {
       $listing = &reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
         $udom, $tryserver);
                   } else {
                       @listing_results = map { &unescape($_); } split(/:/,$listing);
                   }
  if ($listing eq 'unknown_cmd') {   if ($listing eq 'unknown_cmd') {
     $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.      $listing = &reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
       $udom, $tryserver);        $udom, $tryserver);
Line 5746  sub dirlist { Line 7119  sub dirlist {
         } else {          } else {
             return ('missing user name');              return ('missing user name');
         }          }
     } elsif(!defined($alternateDirectoryRoot)) {      } elsif(!defined($getpropath)) {
         my @all_domains = sort(&all_domains());          my @all_domains = sort(&all_domains());
          foreach my $domain (@all_domains) {          foreach my $domain (@all_domains) {
              $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';              $domain = $perlvar{'lonDocRoot'}.'/res/'.$domain.'/&domain';
          }          }
          return @all_domains;          return @all_domains;
      } else {      } else {
         return ('missing domain');          return ('missing domain');
     }      }
 }  }
Line 5762  sub dirlist { Line 7135  sub dirlist {
 # when it was last modified.  It will also return an error of -1  # when it was last modified.  It will also return an error of -1
 # if an error occurs  # if an error occurs
   
 ##  
 ## FIXME: This subroutine assumes its caller knows something about the  
 ## directory structure of the home server for the student ($root).  
 ## Not a good assumption to make.  Since this is for looking up files  
 ## in user directories, the full path should be constructed by lond, not  
 ## whatever machine we request data from.  
 ##  
 sub GetFileTimestamp {  sub GetFileTimestamp {
     my ($studentDomain,$studentName,$filename,$root)=@_;      my ($studentDomain,$studentName,$filename,$getuserdir)=@_;
     $studentDomain = &LONCAPA::clean_domain($studentDomain);      $studentDomain = &LONCAPA::clean_domain($studentDomain);
     $studentName   = &LONCAPA::clean_username($studentName);      $studentName   = &LONCAPA::clean_username($studentName);
     my $subdir=$studentName.'__';      my ($fileStat) = 
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;          &Apache::lonnet::dirlist($filename,$studentDomain,$studentName, 
     my $proname="$studentDomain/$subdir/$studentName";                                   undef,$getuserdir);
     $proname .= '/'.$filename;  
     my ($fileStat) = &Apache::lonnet::dirlist($proname, $studentDomain,   
                                               $studentName, $root);  
     my @stats = split('&', $fileStat);      my @stats = split('&', $fileStat);
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {      if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
         # @stats contains first the filename, then the stat output          # @stats contains first the filename, then the stat output
Line 5792  sub stat_file { Line 7155  sub stat_file {
     my ($uri) = @_;      my ($uri) = @_;
     $uri = &clutter_with_no_wrapper($uri);      $uri = &clutter_with_no_wrapper($uri);
   
     my ($udom,$uname,$file,$dir);      my ($udom,$uname,$file);
     if ($uri =~ m-^/(uploaded|editupload)/-) {      if ($uri =~ m-^/(uploaded|editupload)/-) {
  ($udom,$uname,$file) =   ($udom,$uname,$file) =
     ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);      ($uri =~ m-/(?:uploaded|editupload)/?($match_domain)/?($match_name)/?(.*)-);
  $file = 'userfiles/'.$file;   $file = 'userfiles/'.$file;
  $dir = &propath($udom,$uname);  
     }      }
     if ($uri =~ m-^/res/-) {      if ($uri =~ m-^/res/-) {
  ($udom,$uname) =    ($udom,$uname) = 
Line 5809  sub stat_file { Line 7171  sub stat_file {
  # unable to handle the uri   # unable to handle the uri
  return ();   return ();
     }      }
       my $getpropath;
     my ($result) = &dirlist($file,$udom,$uname,$dir);      if ($file =~ /^userfiles\//) {
           $getpropath = 1;
       }
       my ($result) = &dirlist($file,$udom,$uname,$getpropath);
     my @stats = split('&', $result);      my @stats = split('&', $result);
           
     if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {      if($stats[0] ne 'empty' && $stats[0] ne 'no_such_dir') {
Line 5843  sub directcondval { Line 7208  sub directcondval {
     untie(%bighash);      untie(%bighash);
  }   }
  my $value = &docondval($sub_condition);   my $value = &docondval($sub_condition);
  &appenv('user.state.'.$env{'request.course.id'}.".$number" => $value);   &appenv({'user.state.'.$env{'request.course.id'}.".$number" => $value});
  return $value;   return $value;
     }      }
     if ($env{'user.state.'.$env{'request.course.id'}}) {      if ($env{'user.state.'.$env{'request.course.id'}}) {
Line 5910  sub devalidatecourseresdata { Line 7275  sub devalidatecourseresdata {
   
   
 # --------------------------------------------------- Course Resourcedata Query  # --------------------------------------------------- Course Resourcedata Query
   #
   #  Parameters:
   #      $coursenum    - Number of the course.
   #      $coursedomain - Domain at which the course was created.
   #  Returns:
   #     A hash of the course parameters along (I think) with timestamps
   #     and version info.
   
 sub get_courseresdata {  sub get_courseresdata {
     my ($coursenum,$coursedomain)=@_;      my ($coursenum,$coursedomain)=@_;
Line 5968  sub get_userresdata { Line 7340  sub get_userresdata {
     }      }
     return $tmp;      return $tmp;
 }  }
   #----------------------------------------------- resdata - return resource data
   #  Purpose:
   #    Return resource data for either users or for a course.
   #  Parameters:
   #     $name      - Course/user name.
   #     $domain    - Name of the domain the user/course is registered on.
   #     $type      - Type of thing $name is (must be 'course' or 'user'
   #     @which     - Array of names of resources desired.
   #  Returns:
   #     The value of the first reasource in @which that is found in the
   #     resource hash.
   #  Exceptional Conditions:
   #     If the $type passed in is not valid (not the string 'course' or 
   #     'user', an undefined  reference is returned.
   #     If none of the resources are found, an undef is returned
 sub resdata {  sub resdata {
     my ($name,$domain,$type,@which)=@_;      my ($name,$domain,$type,@which)=@_;
     my $result;      my $result;
Line 5979  sub resdata { Line 7365  sub resdata {
     }      }
     if (!ref($result)) { return $result; }          if (!ref($result)) { return $result; }    
     foreach my $item (@which) {      foreach my $item (@which) {
  if (defined($result->{$item})) {   if (defined($result->{$item->[0]})) {
     return $result->{$item};      return [$result->{$item->[0]},$item->[1]];
  }   }
     }      }
     return undef;      return undef;
Line 6008  sub EXT_cache_status { Line 7394  sub EXT_cache_status {
 sub EXT_cache_set {  sub EXT_cache_set {
     my ($target_domain,$target_user) = @_;      my ($target_domain,$target_user) = @_;
     my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;      my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
     #&appenv($cachename => time);      #&appenv({$cachename => time});
 }  }
   
 # --------------------------------------------------------- Value of a Variable  # --------------------------------------------------------- Value of a Variable
Line 6146  sub EXT { Line 7532  sub EXT {
     my ($map) = &decode_symb($symbparm);      my ($map) = &decode_symb($symbparm);
     return &symbread($map);      return &symbread($map);
  }   }
    if ($space eq 'filename') {
       if ($symbparm) {
    return &clutter((&decode_symb($symbparm))[2]);
       }
       return &hreflocation('',$env{'request.filename'});
    }
   
  my ($section, $group, @groups);   my ($section, $group, @groups);
  my ($courselevelm,$courselevel);   my ($courselevelm,$courselevel);
Line 6186  sub EXT { Line 7578  sub EXT {
 # ----------------------------------------------------------- first, check user  # ----------------------------------------------------------- first, check user
   
     my $userreply=&resdata($uname,$udom,'user',      my $userreply=&resdata($uname,$udom,'user',
        ($courselevelr,$courselevelm,         ([$courselevelr,'resource'],
  $courselevel));   [$courselevelm,'map'     ],
     if (defined($userreply)) { return $userreply; }   [$courselevel, 'course'  ]));
       if (defined($userreply)) { return &get_reply($userreply); }
   
 # ------------------------------------------------ second, check some of course  # ------------------------------------------------ second, check some of course
             my $coursereply;              my $coursereply;
             if (@groups > 0) {              if (@groups > 0) {
                 $coursereply = &check_group_parms($courseid,\@groups,$symbparm,                  $coursereply = &check_group_parms($courseid,\@groups,$symbparm,
                                        $mapparm,$spacequalifierrest);                                         $mapparm,$spacequalifierrest);
                 if (defined($coursereply)) { return $coursereply; }                  if (defined($coursereply)) { return &get_reply($coursereply); }
             }              }
   
     $coursereply=&resdata($env{'course.'.$courseid.'.num'},      $coursereply=&resdata($env{'course.'.$courseid.'.num'},
      $env{'course.'.$courseid.'.domain'},    $env{'course.'.$courseid.'.domain'},
      'course',    'course',
      ($seclevelr,$seclevelm,$seclevel,    ([$seclevelr,   'resource'],
       $courselevelr));     [$seclevelm,   'map'     ],
     if (defined($coursereply)) { return $coursereply; }     [$seclevel,    'course'  ],
      [$courselevelr,'resource']));
       if (defined($coursereply)) { return &get_reply($coursereply); }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
     my %parmhash=();      my %parmhash=();
Line 6214  sub EXT { Line 7609  sub EXT {
  $thisparm=$parmhash{$symbparm};   $thisparm=$parmhash{$symbparm};
  untie(%parmhash);   untie(%parmhash);
     }      }
     if ($thisparm) { return $thisparm; }      if ($thisparm) { return &get_reply([$thisparm,'resource']); }
  }   }
 # ------------------------------------------ fourth, look in resource metadata  # ------------------------------------------ fourth, look in resource metadata
   
Line 6227  sub EXT { Line 7622  sub EXT {
     $filename=$env{'request.filename'};      $filename=$env{'request.filename'};
  }   }
  my $metadata=&metadata($filename,$spacequalifierrest);   my $metadata=&metadata($filename,$spacequalifierrest);
  if (defined($metadata)) { return $metadata; }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
  $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);   $metadata=&metadata($filename,'parameter_'.$spacequalifierrest);
  if (defined($metadata)) { return $metadata; }   if (defined($metadata)) { return &get_reply([$metadata,'resource']); }
   
 # ---------------------------------------------- fourth, look in rest pf course  # ---------------------------------------------- fourth, look in rest of course
  if ($symbparm && defined($courseid) &&    if ($symbparm && defined($courseid) && 
     $courseid eq $env{'request.course.id'}) {      $courseid eq $env{'request.course.id'}) {
     my $coursereply=&resdata($env{'course.'.$courseid.'.num'},      my $coursereply=&resdata($env{'course.'.$courseid.'.num'},
      $env{'course.'.$courseid.'.domain'},       $env{'course.'.$courseid.'.domain'},
      'course',       'course',
      ($courselevelm,$courselevel));       ([$courselevelm,'map'   ],
     if (defined($coursereply)) { return $coursereply; }        [$courselevel, 'course']));
       if (defined($coursereply)) { return &get_reply($coursereply); }
  }   }
 # ------------------------------------------------------------------ Cascade up  # ------------------------------------------------------------------ Cascade up
  unless ($space eq '0') {   unless ($space eq '0') {
Line 6246  sub EXT { Line 7642  sub EXT {
     my $id=pop(@parts);      my $id=pop(@parts);
     my $part=join('_',@parts);      my $part=join('_',@parts);
     if ($part eq '') { $part='0'; }      if ($part eq '') { $part='0'; }
     my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,      my @partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
  $symbparm,$udom,$uname,$section,1);   $symbparm,$udom,$uname,$section,1);
     if (defined($partgeneral)) { return $partgeneral; }      if (defined($partgeneral[0])) { return &get_reply(\@partgeneral); }
  }   }
  if ($recurse) { return undef; }   if ($recurse) { return undef; }
  my $pack_def=&packages_tab_default($filename,$varname);   my $pack_def=&packages_tab_default($filename,$varname);
  if (defined($pack_def)) { return $pack_def; }   if (defined($pack_def)) { return &get_reply([$pack_def,'resource']); }
   
 # ---------------------------------------------------- Any other user namespace  # ---------------------------------------------------- Any other user namespace
     } elsif ($realm eq 'environment') {      } elsif ($realm eq 'environment') {
 # ----------------------------------------------------------------- environment  # ----------------------------------------------------------------- environment
Line 6281  sub EXT { Line 7676  sub EXT {
     return '';      return '';
 }  }
   
   sub get_reply {
       my ($reply_value) = @_;
       if (ref($reply_value) eq 'ARRAY') {
           if (wantarray) {
       return @$reply_value;
           }
           return $reply_value->[0];
       } else {
           return $reply_value;
       }
   }
   
 sub check_group_parms {  sub check_group_parms {
     my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;      my ($courseid,$groups,$symbparm,$mapparm,$what) = @_;
     my @groupitems = ();      my @groupitems = ();
     my $resultitem;      my $resultitem;
     my @levels = ($symbparm,$mapparm,$what);      my @levels = ([$symbparm,'resource'],[$mapparm,'map'],[$what,'course']);
     foreach my $group (@{$groups}) {      foreach my $group (@{$groups}) {
         foreach my $level (@levels) {          foreach my $level (@levels) {
              my $item = $courseid.'.['.$group.'].'.$level;               my $item = $courseid.'.['.$group.'].'.$level->[0];
              push(@groupitems,$item);               push(@groupitems,[$item,$level->[1]]);
         }          }
     }      }
     my $coursereply = &resdata($env{'course.'.$courseid.'.num'},      my $coursereply = &resdata($env{'course.'.$courseid.'.num'},
Line 6315  sub packages_tab_default { Line 7722  sub packages_tab_default {
     $do_default=1;      $do_default=1;
  } elsif ($pack_type eq 'extension') {   } elsif ($pack_type eq 'extension') {
     push(@extension,[$package,$pack_type,$pack_part]);      push(@extension,[$package,$pack_type,$pack_part]);
  } elsif ($pack_part eq $part) {   } elsif ($pack_part eq $part || $pack_type eq 'part') {
     # only look at packages defaults for packages that this id is      # only look at packages defaults for packages that this id is
     push(@specifics,[$package,$pack_type,$pack_part]);      push(@specifics,[$package,$pack_type,$pack_part]);
  }   }
Line 6382  sub metadata { Line 7789  sub metadata {
     if (($uri eq '') ||       if (($uri eq '') || 
  (($uri =~ m|^/*adm/|) &&    (($uri =~ m|^/*adm/|) && 
      ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||       ($uri !~ m|^adm/includes|) && ($uri !~ m|/bulletinboard$|)) ||
         ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ /^~/) ||          ($uri =~ m|/$|) || ($uri =~ m|/.meta$|) ) {
  ($uri =~ m|home/$match_username/public_html/|)) {   return undef;
       }
       if (($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) 
    && &Apache::lonxml::get_state('target') =~ /^(|meta)$/) {
  return undef;   return undef;
     }      }
     my $filename=$uri;      my $filename=$uri;
Line 6404  sub metadata { Line 7814  sub metadata {
 # if (! exists($metacache{$uri})) {  # if (! exists($metacache{$uri})) {
 #    $metacache{$uri}={};  #    $metacache{$uri}={};
 # }  # }
    my $cachetime = 60*60;
         if ($liburi) {          if ($liburi) {
     $liburi=&declutter($liburi);      $liburi=&declutter($liburi);
             $filename=$liburi;              $filename=$liburi;
Line 6414  sub metadata { Line 7825  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m -^(editupload)/-) {   if ($uri =~ /^~/ || $uri =~ m{home/$match_username/public_html/}) {
       my $which = &hreflocation('','/'.($liburi || $uri));
       $metastring = 
    &Apache::lonnet::ssi_body($which,
     ('grade_target' => 'meta'));
       $cachetime = 1; # only want this cached in the child not long term
    } elsif ($uri !~ m -^(editupload)/-) {
     my $file=&filelocation('',&clutter($filename));      my $file=&filelocation('',&clutter($filename));
     #push(@{$metaentry{$uri.'.file'}},$file);      #push(@{$metaentry{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
Line 6519  sub metadata { Line 7936  sub metadata {
  # only ws inside the tag, and not in default, so use default   # only ws inside the tag, and not in default, so use default
  # as value   # as value
     $metaentry{':'.$unikey}=$default;      $metaentry{':'.$unikey}=$default;
  } else {   } elsif ( $internaltext =~ /\S/ ) {
   # either something interesting inside the tag or default    # something interesting inside the tag
                   # uninteresting  
     $metaentry{':'.$unikey}=$internaltext;      $metaentry{':'.$unikey}=$internaltext;
    } else {
     # no interesting values, don't set a default
  }   }
 # end of not-a-package not-a-library import  # end of not-a-package not-a-library import
     }      }
Line 6532  sub metadata { Line 7950  sub metadata {
     }      }
  }   }
  my ($extension) = ($uri =~ /\.(\w+)$/);   my ($extension) = ($uri =~ /\.(\w+)$/);
    $extension = lc($extension);
    if ($extension eq 'htm') { $extension='html'; }
   
  foreach my $key (keys(%packagetab)) {   foreach my $key (keys(%packagetab)) {
     #no specific packages #how's our extension      #no specific packages #how's our extension
     if ($key!~/^extension_\Q$extension\E&/) { next; }      if ($key!~/^extension_\Q$extension\E&/) { next; }
     &metadata_create_package_def($uri,$key,'extension_'.$extension,      &metadata_create_package_def($uri,$key,'extension_'.$extension,
  \%metathesekeys);   \%metathesekeys);
  }   }
  if (!exists($metaentry{':packages'})) {  
    if (!exists($metaentry{':packages'})
       || $packagetab{"import_defaults&extension_$extension"}) {
     foreach my $key (keys(%packagetab)) {      foreach my $key (keys(%packagetab)) {
  #no specific packages well let's get default then   #no specific packages well let's get default then
  if ($key!~/^default&/) { next; }   if ($key!~/^default&/) { next; }
Line 6575  sub metadata { Line 7998  sub metadata {
  $metaentry{':keys'} = join(',',keys(%metathesekeys));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);   $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
  &do_cache_new('meta',$uri,\%metaentry,60*60);   &do_cache_new('meta',$uri,\%metaentry,$cachetime);
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metaentry{':'.$what};
Line 6644  sub devalidate_title_cache { Line 8067  sub devalidate_title_cache {
     &devalidate_cache_new('title',$key);      &devalidate_cache_new('title',$key);
 }  }
   
   # ------------------------------------------------- Get the title of a course
   
   sub current_course_title {
       return $env{ 'course.' . $env{'request.course.id'} . '.description' };
   }
 # ------------------------------------------------- Get the title of a resource  # ------------------------------------------------- Get the title of a resource
   
 sub gettitle {  sub gettitle {
Line 6657  sub gettitle { Line 8085  sub gettitle {
  }   }
  my ($map,$resid,$url)=&decode_symb($symb);   my ($map,$resid,$url)=&decode_symb($symb);
  my $title='';   my $title='';
  my %bighash;   if (!$map && $resid == 0 && $url =~/default\.sequence$/) {
  if (tie(%bighash,'GDBM_File',$env{'request.course.fn'}.'.db',      $title = $env{'course.'.$env{'request.course.id'}.'.description'};
  &GDBM_READER(),0640)) {   } else {
     my $mapid=$bighash{'map_pc_'.&clutter($map)};      if (tie(my %bighash,'GDBM_File',$env{'request.course.fn'}.'.db',
     $title=$bighash{'title_'.$mapid.'.'.$resid};      &GDBM_READER(),0640)) {
     untie %bighash;   my $mapid=$bighash{'map_pc_'.&clutter($map)};
    $title=$bighash{'title_'.$mapid.'.'.$resid};
    untie(%bighash);
       }
  }   }
  $title=~s/\&colon\;/\:/gs;   $title=~s/\&colon\;/\:/gs;
  if ($title) {   if ($title) {
Line 6707  sub symblist { Line 8138  sub symblist {
     if (($env{'request.course.fn'}) && (%newhash)) {      if (($env{'request.course.fn'}) && (%newhash)) {
         if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$env{'request.course.fn'}.'_symb.db',
                       &GDBM_WRCREAT(),0640)) {                        &GDBM_WRCREAT(),0640)) {
     foreach my $url (keys %newhash) {      foreach my $url (keys(%newhash)) {
  next if ($url eq 'last_known'   next if ($url eq 'last_known'
  && $env{'form.no_update_last_known'});   && $env{'form.no_update_last_known'});
  $hash{declutter($url)}=&encode_symb($mapname,   $hash{declutter($url)}=&encode_symb($mapname,
Line 6870  sub symbread { Line 8301  sub symbread {
         if ($syval) {          if ($syval) {
     #unless ($syval=~/\_\d+$/) {      #unless ($syval=~/\_\d+$/) {
  #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {   #unless ($env{'form.request.prefix'}=~/\.(\d+)\_$/) {
     #&appenv('request.ambiguous' => $thisfn);      #&appenv({'request.ambiguous' => $thisfn});
     #return $env{$cache_str}='';      #return $env{$cache_str}='';
  #}       #}    
  #$syval.=$1;   #$syval.=$1;
Line 6922  sub symbread { Line 8353  sub symbread {
     return $env{$cache_str}=$syval;      return $env{$cache_str}=$syval;
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv({'request.ambiguous' => $thisfn});
     return $env{$cache_str}='';      return $env{$cache_str}='';
 }  }
   
Line 7035  sub getCODE { Line 8466  sub getCODE {
 sub rndseed {  sub rndseed {
     my ($symb,$courseid,$domain,$username)=@_;      my ($symb,$courseid,$domain,$username)=@_;
     my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();      my ($wsymb,$wcourseid,$wdomain,$wusername)=&whichuser();
     if (!$symb) {      if (!defined($symb)) {
  unless ($symb=$wsymb) { return time; }   unless ($symb=$wsymb) { return time; }
     }      }
     if (!$courseid) { $courseid=$wcourseid; }      if (!$courseid) { $courseid=$wcourseid; }
Line 7414  sub repcopy_userfile { Line 8845  sub repcopy_userfile {
     if (-e $transferfile) { return 'ok'; }      if (-e $transferfile) { return 'ok'; }
     my $request;      my $request;
     $uri=~s/^\///;      $uri=~s/^\///;
     $request=new HTTP::Request('GET','http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri);      my $homeserver = &homeserver($cnum,$cdom);
       my $protocol = $protocol{$homeserver};
       $protocol = 'http' if ($protocol ne 'https');
       $request=new HTTP::Request('GET',$protocol.'://'.&hostname($homeserver).'/raw/'.$uri);
     my $response=$ua->request($request,$transferfile);      my $response=$ua->request($request,$transferfile);
 # did it work?  # did it work?
     if ($response->is_error()) {      if ($response->is_error()) {
Line 7429  sub repcopy_userfile { Line 8863  sub repcopy_userfile {
   
 sub tokenwrapper {  sub tokenwrapper {
     my $uri=shift;      my $uri=shift;
     $uri=~s|^http\://([^/]+)||;      $uri=~s|^https?\://([^/]+)||;
     $uri=~s|^/||;      $uri=~s|^/||;
     $env{'user.environment'}=~/\/([^\/]+)\.id/;      $env{'user.environment'}=~/\/([^\/]+)\.id/;
     my $token=$1;      my $token=$1;
     my (undef,$udom,$uname,$file)=split('/',$uri,4);      my (undef,$udom,$uname,$file)=split('/',$uri,4);
     if ($udom && $uname && $file) {      if ($udom && $uname && $file) {
  $file=~s|(\?\.*)*$||;   $file=~s|(\?\.*)*$||;
         &appenv("userfile.$udom/$uname/$file" => $env{'request.course.id'});          &appenv({"userfile.$udom/$uname/$file" => $env{'request.course.id'}});
         return 'http://'.&hostname(&homeserver($uname,$udom)).'/'.$uri.          my $homeserver = &homeserver($uname,$udom);
           my $protocol = $protocol{$homeserver};
           $protocol = 'http' if ($protocol ne 'https');
           return $protocol.'://'.&hostname($homeserver).'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
                                '&tokenissued='.$perlvar{'lonHostID'};                                 '&tokenissued='.$perlvar{'lonHostID'};
     } else {      } else {
Line 7452  sub tokenwrapper { Line 8889  sub tokenwrapper {
 sub getuploaded {  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
     $uri = 'http://'.&hostname(&homeserver($cnum,$cdom)).'/raw/'.$uri;      my $homeserver = &homeserver($cnum,$cdom);
       my $protocol = $protocol{$homeserver};
       $protocol = 'http' if ($protocol ne 'https');
       $uri = $protocol.'://'.&hostname($homeserver).'/raw/'.$uri;
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request($reqtype,$uri);      my $request=new HTTP::Request($reqtype,$uri);
     my $response=$ua->request($request);      my $response=$ua->request($request);
Line 7487  sub filelocation { Line 8927  sub filelocation {
  $file=~s-^/adm/wrapper/-/-;   $file=~s-^/adm/wrapper/-/-;
  $file=~s-^/adm/coursedocs/showdoc/-/-;   $file=~s-^/adm/coursedocs/showdoc/-/-;
     }      }
   
     if ($file=~m:^/~:) { # is a contruction space reference      if ($file=~m:^/~:) { # is a contruction space reference
         $location = $file;          $location = $file;
         $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;          $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
     } elsif ($file=~m{^/home/$match_username/public_html/}) {      } elsif ($file=~m{^/home/$match_username/public_html/}) {
  # is a correct contruction space reference   # is a correct contruction space reference
         $location = $file;          $location = $file;
       } elsif ($file =~ m-^\Q$Apache::lonnet::perlvar{'lonTabDir'}\E/-) {
           $location = $file;
     } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file      } elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
         my ($udom,$uname,$filename)=          my ($udom,$uname,$filename)=
      ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);       ($file=~m -^/+(?:uploaded|editupload)/+($match_domain)/+($match_name)/+(.*)$-);
Line 7501  sub filelocation { Line 8944  sub filelocation {
         my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
         foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }          foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
         if ($is_me) {          if ($is_me) {
      $location=&propath($udom,$uname).       $location=&propath($udom,$uname).'/userfiles/'.$filename;
        '/userfiles/'.$filename;  
         } else {          } else {
    $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
        $udom.'/'.$uname.'/'.$filename;         $udom.'/'.$uname.'/'.$filename;
         }          }
       } elsif ($file =~ m-^/adm/-) {
    $location = $perlvar{'lonDocRoot'}.'/'.$file;
     } else {      } else {
         $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;          $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
         $file=~s:^/res/:/:;          $file=~s:^/res/:/:;
Line 7517  sub filelocation { Line 8961  sub filelocation {
         }          }
     }      }
     $location=~s://+:/:g; # remove duplicate /      $location=~s://+:/:g; # remove duplicate /
     while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..      while ($location=~m{/\.\./}) {
    if ($location =~ m{/[^/]+/\.\./}) {
       $location=~ s{/[^/]+/\.\./}{/}g;
    } else {
       $location=~ s{/\.\./}{/}g;
    }
       } #remove dir/..
     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./      while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
     return $location;      return $location;
 }  }
   
 sub hreflocation {  sub hreflocation {
     my ($dir,$file)=@_;      my ($dir,$file)=@_;
     unless (($file=~m-^http://-i) || ($file=~m-^/-)) {      unless (($file=~m-^https?\://-i) || ($file=~m-^/-)) {
  $file=filelocation($dir,$file);   $file=filelocation($dir,$file);
     } elsif ($file=~m-^/adm/-) {      } elsif ($file=~m-^/adm/-) {
  $file=~s-^/adm/wrapper/-/-;   $file=~s-^/adm/wrapper/-/-;
Line 7538  sub hreflocation { Line 8988  sub hreflocation {
  $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/};
       }
     return $file;      return $file;
 }  }
   
Line 7566  sub machine_ids { Line 9019  sub machine_ids {
     my ($hostname) = @_;      my ($hostname) = @_;
     $hostname ||= &hostname($perlvar{'lonHostID'});      $hostname ||= &hostname($perlvar{'lonHostID'});
     my @ids;      my @ids;
     my %hostname = &all_hostnames();      my %name_to_host = &all_names();
     while( my($id, $name) = each(%hostname)) {      if (ref($name_to_host{$hostname}) eq 'ARRAY') {
 # &logthis("-$id-$name-$hostname-");   return @{ $name_to_host{$hostname} };
  if ($hostname eq $name) {  
     push(@ids,$id);  
  }  
     }      }
     return @ids;      return;
 }  }
   
 sub additional_machine_domains {  sub additional_machine_domains {
Line 7617  sub declutter { Line 9067  sub declutter {
   
 sub clutter {  sub clutter {
     my $thisfn='/'.&declutter(shift);      my $thisfn='/'.&declutter(shift);
     unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) {       if ($thisfn !~ m{^/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)/}
    || $thisfn =~ m{^/adm/(includes|pages)} ) { 
        $thisfn='/res'.$thisfn;          $thisfn='/res'.$thisfn; 
     }      }
     if ($thisfn !~m|/adm|) {      if ($thisfn !~m|/adm|) {
Line 7686  sub correct_line_ends { Line 9137  sub correct_line_ends {
 sub goodbye {  sub goodbye {
    &logthis("Starting Shut down");     &logthis("Starting Shut down");
 #not converted to using infrastruture and probably shouldn't be  #not converted to using infrastruture and probably shouldn't be
    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));     &logthis(sprintf("%-20s is %s",'%badServerCache',length(&nfreeze(\%badServerCache))));
 #converted  #converted
 #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));  #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
    &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));     &logthis(sprintf("%-20s is %s",'%homecache',length(&nfreeze(\%homecache))));
 #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));  #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&nfreeze(\%titlecache))));
 #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));  #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&nfreeze(\%courseresdatacache))));
 #1.1 only  #1.1 only
 #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&freeze(\%userresdatacache))));  #   &logthis(sprintf("%-20s is %s",'%userresdatacache',length(&nfreeze(\%userresdatacache))));
 #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&freeze(\%getsectioncache))));  #   &logthis(sprintf("%-20s is %s",'%getsectioncache',length(&nfreeze(\%getsectioncache))));
 #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&freeze(\%courseresversioncache))));  #   &logthis(sprintf("%-20s is %s",'%courseresversioncache',length(&nfreeze(\%courseresversioncache))));
 #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&freeze(\%resversioncache))));  #   &logthis(sprintf("%-20s is %s",'%resversioncache',length(&nfreeze(\%resversioncache))));
    &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));     &logthis(sprintf("%-20s is %s",'%remembered',length(&nfreeze(\%remembered))));
    &logthis(sprintf("%-20s is %s",'kicks',$kicks));     &logthis(sprintf("%-20s is %s",'kicks',$kicks));
    &logthis(sprintf("%-20s is %s",'hits',$hits));     &logthis(sprintf("%-20s is %s",'hits',$hits));
    &flushcourselogs();     &flushcourselogs();
    &logthis("Shutting down");     &logthis("Shutting down");
 }  }
   
 BEGIN {  
   
 # ----------------------------------- Read loncapa.conf and loncapa_apache.conf  
     unless ($readit) {  
 {  
     my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');  
     %perlvar = (%perlvar,%{$configvars});  
 }  
   
 sub get_dns {  sub get_dns {
     my ($url,$func) = @_;      my ($url,$func,$ignore_cache) = @_;
       if (!$ignore_cache) {
    my ($content,$cached)=
       &Apache::lonnet::is_cached_new('dns',$url);
    if ($cached) {
       &$func($content);
       return;
    }
       }
   
       my %alldns;
     open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");      open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
     foreach my $dns (<$config>) {      foreach my $dns (<$config>) {
  next if ($dns !~ /^\^(\S*)/x);   next if ($dns !~ /^\^(\S*)/x);
  $dns = $1;          my $line = $1;
           my ($host,$protocol) = split(/:/,$line);
           if ($protocol ne 'https') {
               $protocol = 'http';
           }
    $alldns{$host} = $protocol;
       }
       while (%alldns) {
    my ($dns) = keys(%alldns);
  my $ua=new LWP::UserAgent;   my $ua=new LWP::UserAgent;
  my $request=new HTTP::Request('GET',"http://$dns$url");   my $request=new HTTP::Request('GET',"$alldns{$dns}://$dns$url");
  my $response=$ua->request($request);   my $response=$ua->request($request);
           delete($alldns{$dns});
  next if ($response->is_error());   next if ($response->is_error());
  my @content = split("\n",$response->content);   my @content = split("\n",$response->content);
    &Apache::lonnet::do_cache_new('dns',$url,\@content,30*24*60*60);
  &$func(\@content);   &$func(\@content);
    return;
     }      }
     close($config);      close($config);
       my $which = (split('/',$url))[3];
       &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
       open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
       my @content = <$config>;
       &$func(\@content);
       return;
 }  }
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
Line 7747  sub get_dns { Line 9216  sub get_dns {
  $this_domain{$field} = shift(@elements);   $this_domain{$field} = shift(@elements);
     }      }
     $domain{$name} = \%this_domain;      $domain{$name} = \%this_domain;
     &logthis("Domain.tab: $name ".$domain{$name}{'description'} );  
  }   }
     }      }
       
       sub reset_domain_info {
    undef($loaded);
    undef(%domain);
       }
   
     sub load_domain_tab {      sub load_domain_tab {
  &get_dns('/adm/dns/domain',\&parse_domain_tab);   my ($ignore_cache) = @_;
    &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache);
  my $fh;   my $fh;
  if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {   if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
     my @lines = <$fh>;      my @lines = <$fh>;
Line 7773  sub get_dns { Line 9247  sub get_dns {
  }   }
  return $domain{$name}{$what};   return $domain{$name}{$what};
     }      }
   
       sub domain_info {
           &load_domain_tab() if (!$loaded);
           return %domain;
       }
   
 }  }
   
   
Line 7782  sub get_dns { Line 9262  sub get_dns {
     my %hostdom;      my %hostdom;
     my %libserv;      my %libserv;
     my $loaded;      my $loaded;
       my %name_to_host;
   
     sub parse_hosts_tab {      sub parse_hosts_tab {
  my ($file) = @_;   my ($file) = @_;
Line 7789  sub get_dns { Line 9270  sub get_dns {
     next if ($configline =~ /^(\#|\s*$ )/x);      next if ($configline =~ /^(\#|\s*$ )/x);
     next if ($configline =~ /^\^/);      next if ($configline =~ /^\^/);
     chomp($configline);      chomp($configline);
     my ($id,$domain,$role,$name)=split(/:/,$configline);      my ($id,$domain,$role,$name,$protocol)=split(/:/,$configline);
     $name=~s/\s//g;      $name=~s/\s//g;
     if ($id && $domain && $role && $name) {      if ($id && $domain && $role && $name) {
  $hostname{$id}=$name;   $hostname{$id}=$name;
    push(@{$name_to_host{$name}}, $id);
  $hostdom{$id}=$domain;   $hostdom{$id}=$domain;
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
                   if (defined($protocol)) {
                       if ($protocol eq 'https') {
                           $protocol{$id} = $protocol;
                       } else {
                           $protocol{$id} = 'http'; 
                       }
                   } else {
                       $protocol{$id} = 'http';
                   }
     }      }
     &logthis("Hosts.tab: $name ".$id );  
  }   }
     }      }
       
       sub reset_hosts_info {
    &purge_remembered();
    &reset_domain_info();
    &reset_hosts_ip_info();
    undef(%name_to_host);
    undef(%hostname);
    undef(%hostdom);
    undef(%libserv);
    undef($loaded);
       }
   
     sub load_hosts_tab {      sub load_hosts_tab {
  &get_dns('/adm/dns/hosts',\&parse_hosts_tab);   my ($ignore_cache) = @_;
    &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
  open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");   open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
  my @config = <$config>;   my @config = <$config>;
  &parse_hosts_tab(\@config);   &parse_hosts_tab(\@config);
Line 7809  sub get_dns { Line 9311  sub get_dns {
  $loaded=1;   $loaded=1;
     }      }
   
     # FIXME: dev server don't want this, production servers _do_ want this  
     #&get_iphost();  
   
     sub hostname {      sub hostname {
  &load_hosts_tab() if (!$loaded);   &load_hosts_tab() if (!$loaded);
   
Line 7825  sub get_dns { Line 9324  sub get_dns {
  return %hostname;   return %hostname;
     }      }
   
       sub all_names {
    &load_hosts_tab() if (!$loaded);
   
    return %name_to_host;
       }
   
       sub all_host_domain {
           &load_hosts_tab() if (!$loaded);
           return %hostdom;
       }
   
     sub is_library {      sub is_library {
  &load_hosts_tab() if (!$loaded);   &load_hosts_tab() if (!$loaded);
   
Line 7880  sub get_dns { Line 9390  sub get_dns {
     my %iphost;      my %iphost;
     my %name_to_ip;      my %name_to_ip;
     my %lonid_to_ip;      my %lonid_to_ip;
   
     sub get_hosts_from_ip {      sub get_hosts_from_ip {
  my ($ip) = @_;   my ($ip) = @_;
  my %iphosts = &get_iphost();   my %iphosts = &get_iphost();
Line 7888  sub get_dns { Line 9399  sub get_dns {
  }   }
  return;   return;
     }      }
       
       sub reset_hosts_ip_info {
    undef(%iphost);
    undef(%name_to_ip);
    undef(%lonid_to_ip);
       }
   
     sub get_host_ip {      sub get_host_ip {
  my ($lonid) = @_;   my ($lonid) = @_;
Line 7904  sub get_dns { Line 9421  sub get_dns {
     }      }
           
     sub get_iphost {      sub get_iphost {
  if (%iphost) { return %iphost; }   my ($ignore_cache) = @_;
  my %hostname = &all_hostnames();  
  foreach my $id (keys(%hostname)) {   if (!$ignore_cache) {
     my $name=$hostname{$id};      if (%iphost) {
    return %iphost;
       }
       my ($ip_info,$cached)=
    &Apache::lonnet::is_cached_new('iphost','iphost');
       if ($cached) {
    %iphost      = %{$ip_info->[0]};
    %name_to_ip  = %{$ip_info->[1]};
    %lonid_to_ip = %{$ip_info->[2]};
    return %iphost;
       }
    }
   
    # get yesterday's info for fallback
    my %old_name_to_ip;
    my ($ip_info,$cached)=
       &Apache::lonnet::is_cached_new('iphost','iphost');
    if ($cached) {
       %old_name_to_ip = %{$ip_info->[1]};
    }
   
    my %name_to_host = &all_names();
    foreach my $name (keys(%name_to_host)) {
     my $ip;      my $ip;
     if (!exists($name_to_ip{$name})) {      if (!exists($name_to_ip{$name})) {
  $ip = gethostbyname($name);   $ip = gethostbyname($name);
  if (!$ip || length($ip) ne 4) {   if (!$ip || length($ip) ne 4) {
     &logthis("Skipping host $id name $name no IP found");      if (defined($old_name_to_ip{$name})) {
     next;   $ip = $old_name_to_ip{$name};
    &logthis("Can't find $name defaulting to old $ip");
       } else {
    &logthis("Name $name no IP found");
    next;
       }
    } else {
       $ip=inet_ntoa($ip);
  }   }
  $ip=inet_ntoa($ip);  
  $name_to_ip{$name} = $ip;   $name_to_ip{$name} = $ip;
     } else {      } else {
  $ip = $name_to_ip{$name};   $ip = $name_to_ip{$name};
     }      }
     $lonid_to_ip{$id} = $ip;      foreach my $id (@{ $name_to_host{$name} }) {
     push(@{$iphost{$ip}},$id);   $lonid_to_ip{$id} = $ip;
       }
       push(@{$iphost{$ip}},@{$name_to_host{$name}});
  }   }
    &Apache::lonnet::do_cache_new('iphost','iphost',
         [\%iphost,\%name_to_ip,\%lonid_to_ip],
         48*60*60);
   
  return %iphost;   return %iphost;
     }      }
   
       #
       #  Given a DNS returns the loncapa host name for that DNS 
       # 
       sub host_from_dns {
           my ($dns) = @_;
           my @hosts;
           my $ip;
   
           if (exists($name_to_ip{$dns})) {
               $ip = $name_to_ip{$dns};
           }
           if (!$ip) {
               $ip = gethostbyname($dns); # Initial translation to IP is in net order.
               if (length($ip) == 4) { 
           $ip   = &IO::Socket::inet_ntoa($ip);
               }
           }
           if ($ip) {
       @hosts = get_hosts_from_ip($ip);
       return $hosts[0];
           }
           return undef;
       }
   
   }
   
   BEGIN {
   
   # ----------------------------------- Read loncapa.conf and loncapa_apache.conf
       unless ($readit) {
   {
       my $configvars = LONCAPA::Configuration::read_conf('loncapa.conf');
       %perlvar = (%perlvar,%{$configvars});
 }  }
   
   
 # ------------------------------------------------------ Read spare server file  # ------------------------------------------------------ Read spare server file
 {  {
     open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");      open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
Line 8004  $memcache=new Cache::Memcached({'servers Line 9590  $memcache=new Cache::Memcached({'servers
   
 $processmarker='_'.time.'_'.$perlvar{'lonHostID'};  $processmarker='_'.time.'_'.$perlvar{'lonHostID'};
 $dumpcount=0;  $dumpcount=0;
   $locknum=0;
   
 &logtouch();  &logtouch();
 &logthis('<font color="yellow">INFO: Read configuration</font>');  &logthis('<font color="yellow">INFO: Read configuration</font>');
Line 8171  when the connection is brought back up Line 9758  when the connection is brought back up
 =item * B<con_failed>: unable to contact remote host and unable to save message  =item * B<con_failed>: unable to contact remote host and unable to save message
 for later delivery  for later delivery
   
 =item * B<error:>: an error a occured, a description of the error follows the :  =item * B<error:>: an error a occurred, a description of the error follows the :
   
 =item * B<no_such_host>: unable to fund a host associated with the user/domain  =item * B<no_such_host>: unable to fund a host associated with the user/domain
 that was requested  that was requested
Line 8186  that was requested Line 9773  that was requested
   
 =item *   =item * 
 X<appenv()>  X<appenv()>
 B<appenv(%hash)>: the value of %hash is written to  B<appenv($hashref,$rolesarrayref)>: the value of %{$hashref} is written to
 the user envirnoment file, and will be restored for each access this  the user envirnoment file, and will be restored for each access this
 user makes during this session, also modifies the %env for the current  user makes during this session, also modifies the %env for the current
 process  process. Optional rolesarrayref - if defined contains a reference to an array
   of roles which are exempt from the restriction on modifying user.role entries 
   in the user's environment.db and in %env.    
   
 =item *  =item *
 X<delenv()>  X<delenv()>
 B<delenv($regexp)>: removes all items from the session  B<delenv($delthis,$regexp)>: removes all items from the session
 environment file that matches the regular expression in $regexp. The  environment file that begin with $delthis. If the 
 values are also delted from the current processes %env.  optional second arg - $regexp - is true, $delthis is treated as a 
   regular expression, otherwise \Q$delthis\E is used. 
   The values are also deleted from the current processes %env.
   
 =item * get_env_multiple($name)   =item * get_env_multiple($name) 
   
Line 8292  and course level Line 9883  and course level
   
 =item *  =item *
   
 plaintext($short) : return value in %prp hash (rolesplain.tab); plain text  plaintext($short,$type,$cid,$forcedefault) : return value in %prp hash 
 explanation of a user role term  (rolesplain.tab); plain text explanation of a user role term.
   $type is Course (default) or Community.
   If $forcedefault evaluates to true, text returned will be default 
   text for $type. Otherwise, if this is a course, the text returned 
   will be a custom name for the role (if defined in the course's 
   environment).  If no custom name is defined the default is returned.
      
 =item *  =item *
   
 get_my_roles($uname,$udom,$context,$types,$roles,$roledoms) :  get_my_roles($uname,$udom,$context,$types,$roles,$roledoms,$withsec) :
 All arguments are optional. Returns a hash of a roles, either for  All arguments are optional. Returns a hash of a roles, either for
 co-author/assistant author roles for a user's Construction Space  co-author/assistant author roles for a user's Construction Space
 (default), or if $context is 'user', roles for the user himself,  (default), or if $context is 'userroles', roles for the user himself,
 In the hash, keys are set to colon-sparated $uname,$udom,and $role,  In the hash, keys are set to colon-separated $uname,$udom,$role, and
 and value is set to colon-separated start and end times for the role.  (optionally) if $withsec is true, a fourth colon-separated item - $section.
 If no username and domain are specified, will default to current  For each key, value is set to colon-separated start and end times for
 user/domain. Types, roles, and roledoms are references to arrays,  the role.  If no username and domain are specified, will default to
   current user/domain. Types, roles, and roledoms are references to arrays
 of role statuses (active, future or previous), roles   of role statuses (active, future or previous), roles 
 (e.g., cc,in, st etc.) and domains of the roles which can be used  (e.g., cc,in, st etc.) and domains of the roles which can be used
 to restrict the list of roles reported. If no array ref is   to restrict the list of roles reported. If no array ref is 
Line 8318  provided for types, will default to retu Line 9915  provided for types, will default to retu
   
 =item *  =item *
   
 assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a  assignrole($udom,$uname,$url,$role,$end,$start,$deleteflag,$selfenroll,$context) : assign role; give a role to a
 user for the level given by URL.  Optional start and end dates (leave empty  user for the level given by URL.  Optional start and end dates (leave empty
 string or zero for "no date")  string or zero for "no date")
   
Line 8335  modifyuserauth($udom,$uname,$umode,$upas Line 9932  modifyuserauth($udom,$uname,$umode,$upas
   
 =item *  =item *
   
 modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :   modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,
              $forceid,$desiredhome,$email,$inststatus) : 
 modify user  modify user
   
 =item *  =item *
   
 modifystudent  modifystudent
   
 modify a students enrollment and identification information.  modify a student's enrollment and identification information.
 The course id is resolved based on the current users environment.    The course id is resolved based on the current users environment.  
 This means the envoking user must be a course coordinator or otherwise  This means the envoking user must be a course coordinator or otherwise
 associated with a course.  associated with a course.
Line 8354  Inputs: Line 9952  Inputs:
   
 =over 4  =over 4
   
 =item B<$udom> Students loncapa domain  =item B<$udom> Student's loncapa domain
   
 =item B<$uname> Students loncapa login name  =item B<$uname> Student's loncapa login name
   
 =item B<$uid> Students id/student number  =item B<$uid> Student/Employee ID
   
 =item B<$umode> Students authentication mode  =item B<$umode> Student's authentication mode
   
 =item B<$upass> Students password  =item B<$upass> Student's password
   
 =item B<$first> Students first name  =item B<$first> Student's first name
   
 =item B<$middle> Students middle name  =item B<$middle> Student's middle name
   
 =item B<$last> Students last name  =item B<$last> Student's last name
   
 =item B<$gene> Students generation  =item B<$gene> Student's generation
   
 =item B<$usec> Students section in course  =item B<$usec> Student's section in course
   
 =item B<$end> Unix time of the roles expiration  =item B<$end> Unix time of the roles expiration
   
Line 8382  Inputs: Line 9980  Inputs:
   
 =item B<$desiredhome> server to use as home server for student  =item B<$desiredhome> server to use as home server for student
   
   =item B<$email> Student's permanent e-mail address
   
   =item B<$type> Type of enrollment (auto or manual)
   
   =item B<$locktype> boolean - enrollment type locked to prevent Autoenroll.pl changing manual to auto    
   
   =item B<$cid> courseID - needed if a course role is assigned by a user whose current role is DC
   
   =item B<$selfenroll> boolean - 1 if user role change occurred via self-enrollment
   
   =item B<$context> role change context (shown in User Management Logs display in a course)
   
   =item B<$inststatus> institutional status of user - : separated string of escaped status types  
   
 =back  =back
   
 =item *  =item *
Line 8415  Inputs: Line 10027  Inputs:
   
 =item $start  =item $start
   
   =item $type
   
   =item $locktype
   
   =item $cid
   
   =item $selfenroll
   
   =item $context
   
 =back  =back
   
   
Line 8452  setting for a specific $type, where $typ Line 10074  setting for a specific $type, where $typ
 @what should be a list of parameters to ask about. This routine caches  @what should be a list of parameters to ask about. This routine caches
 answers for 5 minutes.  answers for 5 minutes.
   
   =item *
   
   get_courseresdata($courseid, $domain) : dump the entire course resource
   data base, returning a hash that is keyed by the resource name and has
   values that are the resource value.  I believe that the timestamps and
   versions are also returned.
   
   
 =back  =back
   
 =head2 Course Modification  =head2 Course Modification
Line 8465  database) for a course Line 10095  database) for a course
   
 =item *  =item *
   
 createcourse($udom,$description,$url) : make/modify course  createcourse($udom,$description,$url,$course_server,$nonstandard,$inst_code,$course_owner,$crstype,$cnum) : make course
   
   =item *
   
   generate_coursenum($udom) : get a unique (unused) course number in domain $udom
   
 =back  =back
   
Line 8715  Returns: Line 10349  Returns:
  'key_exists: <key>' -> failed to anything out of $storehash, as at   'key_exists: <key>' -> failed to anything out of $storehash, as at
                         least <key> already existed in the db (other                          least <key> already existed in the db (other
                         requested keys may also already exist)                          requested keys may also already exist)
  'error: <msg>' -> unable to tie the DB or other erorr occured   'error: <msg>' -> unable to tie the DB or other error occurred
  'con_lost' -> unable to contact request server   'con_lost' -> unable to contact request server
  'refused' -> action was not allowed by remote machine   'refused' -> action was not allowed by remote machine
   
Line 8743  put_dom($namespace,$storehash,$udom,$uho Line 10377  put_dom($namespace,$storehash,$udom,$uho
 domain level either on specified domain server ($uhome) or primary domain   domain level either on specified domain server ($uhome) or primary domain 
 server ($udom and $uhome are optional)  server ($udom and $uhome are optional)
   
   =item * 
   
   get_domain_defaults($target_domain) : returns hash with defaults for
   authentication and language in the domain. Keys are: auth_def, auth_arg_def,
   lang_def; corresponsing values are authentication type (internal, krb4, krb5,
   or localauth), initial password or a kerberos realm, language (e.g., en-us).
   Values are retrieved from cache (if current), or from domain's configuration.db
   (if available), or lastly from values in lonTabs/dns_domain,tab, 
   or lonTabs/domain.tab. 
   
   %domdefaults = &get_auth_defaults($target_domain);
   
 =back  =back
   
 =head2 Network Status Functions  =head2 Network Status Functions
Line 8757  dirlist($uri) : return directory list ba Line 10403  dirlist($uri) : return directory list ba
   
 spareserver() : find server with least workload from spare.tab  spareserver() : find server with least workload from spare.tab
   
   
   =item *
   
   host_from_dns($dns) : Returns the loncapa hostname corresponding to a DNS name or undef
   if there is no corresponding loncapa host.
   
 =back  =back
   
   
 =head2 Apache Request  =head2 Apache Request
   
 =over 4  =over 4
Line 9134  symblist($mapname,%newhash) : update sym Line 10787  symblist($mapname,%newhash) : update sym
 =back  =back
   
 =cut  =cut
   
Removed from v.1.860  
changed lines
  Added in v.1.1017

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