Diff for /loncom/lond between versions 1.296 and 1.501

version 1.296, 2005/09/01 07:49:43 version 1.501, 2013/07/25 19:11:07
Line 15 Line 15
 #  #
 # LON-CAPA is distributed in the hope that it will be useful,  # LON-CAPA is distributed in the hope that it will be useful,
 # but WITHOUT ANY WARRANTY; without even the implied warranty of  # but WITHOUT ANY WARRANTY; without even the implied warranty of
   
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 # GNU General Public License for more details.  # GNU General Public License for more details.
 #  #
Line 31 Line 32
   
 use strict;  use strict;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
   use LONCAPA;
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   use LONCAPA::Lond;
   
 use IO::Socket;  use IO::Socket;
 use IO::File;  use IO::File;
 #use Apache::File;  #use Apache::File;
 use Symbol;  
 use POSIX;  use POSIX;
 use Crypt::IDEA;  use Crypt::IDEA;
 use LWP::UserAgent();  use LWP::UserAgent();
   use Digest::MD5 qw(md5_hex);
 use GDBM_File;  use GDBM_File;
 use Authen::Krb4;  
 use Authen::Krb5;  use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  
 use localauth;  use localauth;
 use localenroll;  use localenroll;
 use localstudentphoto;  use localstudentphoto;
 use File::Copy;  use File::Copy;
 use File::Find;  use File::Find;
 use LONCAPA::ConfigFileEdit;  
 use LONCAPA::lonlocal;  use LONCAPA::lonlocal;
 use LONCAPA::lonssl;  use LONCAPA::lonssl;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
   use Apache::lonnet;
   use Mail::Send;
   
 my $DEBUG = 0;       # Non zero to enable debug log entries.  my $DEBUG = 0;       # Non zero to enable debug log entries.
   
Line 67  my $currentdomainid; Line 69  my $currentdomainid;
 my $client;  my $client;
 my $clientip; # IP address of client.  my $clientip; # IP address of client.
 my $clientname; # LonCAPA name of client.  my $clientname; # LonCAPA name of client.
   my $clientversion;              # LonCAPA version running on client.
   my $clienthomedom;              # LonCAPA domain of homeID for client. 
                                   # primary library server. 
   
 my $server;  my $server;
 my $thisserver; # DNS of us.  
   
 my $keymode;  my $keymode;
   
Line 85  my $tmpsnum = 0;  # Id of tmpputs. Line 89  my $tmpsnum = 0;  # Id of tmpputs.
   
 my $ConnectionType;  my $ConnectionType;
   
 my %hostid; # ID's for hosts in cluster by ip.  
 my %hostdom; # LonCAPA domain for hosts in cluster.  
 my %hostip; # IPs for hosts in cluster.  
 my %hostdns; # ID's of hosts looked up by DNS name.  
   
 my %managers; # Ip -> manager names  my %managers; # Ip -> manager names
   
 my %perlvar; # Will have the apache conf defined perl vars.  my %perlvar; # Will have the apache conf defined perl vars.
   
   my $dist;
   
 #  #
 #   The hash below is used for command dispatching, and is therefore keyed on the request keyword.  #   The hash below is used for command dispatching, and is therefore keyed on the request keyword.
 #    Each element of the hash contains a reference to an array that contains:  #    Each element of the hash contains a reference to an array that contains:
Line 141  my @adderrors    = ("ok", Line 142  my @adderrors    = ("ok",
     "lcuseradd Unable to make www member of users's group",      "lcuseradd Unable to make www member of users's group",
     "lcuseradd Unable to su to root",      "lcuseradd Unable to su to root",
     "lcuseradd Unable to set password",      "lcuseradd Unable to set password",
     "lcuseradd Usrname has invalid characters",      "lcuseradd Username has invalid characters",
     "lcuseradd Password has an invalid character",      "lcuseradd Password has an invalid character",
     "lcuseradd User already exists",      "lcuseradd User already exists",
     "lcuseradd Could not add user.",      "lcuseradd Could not add user.",
     "lcuseradd Password mismatch");      "lcuseradd Password mismatch");
   
   
   # This array are the errors from lcinstallfile:
   
   my @installerrors = ("ok",
        "Initial user id of client not that of www",
        "Usage error, not enough command line arguments",
        "Source filename does not exist",
        "Destination filename does not exist",
        "Some file operation failed",
        "Invalid table filename."
        );
   
 #  #
 #   Statistics that are maintained and dislayed in the status line.  #   Statistics that are maintained and dislayed in the status line.
Line 177  sub ResetStatistics { Line 188  sub ResetStatistics {
 #   $Socket      - Socket open on client.  #   $Socket      - Socket open on client.
 #   $initcmd     - The full text of the init command.  #   $initcmd     - The full text of the init command.
 #  #
 # Implicit inputs:  
 #    $thisserver - Our DNS name.  
 #  
 # Returns:  # Returns:
 #     IDEA session key on success.  #     IDEA session key on success.
 #     undef on failure.  #     undef on failure.
 #  #
 sub LocalConnection {  sub LocalConnection {
     my ($Socket, $initcmd) = @_;      my ($Socket, $initcmd) = @_;
     Debug("Attempting local connection: $initcmd client: $clientip me: $thisserver");      Debug("Attempting local connection: $initcmd client: $clientip");
     if($clientip ne "127.0.0.1") {      if($clientip ne "127.0.0.1") {
  &logthis('<font color="red"> LocalConnection rejecting non local: '   &logthis('<font color="red"> LocalConnection rejecting non local: '
  ."$clientip ne $thisserver </font>");   ."$clientip ne 127.0.0.1 </font>");
  close $Socket;   close $Socket;
  return undef;   return undef;
     }  else {      }  else {
Line 407  sub isClient { Line 415  sub isClient {
 #  #
 sub ReadManagerTable {  sub ReadManagerTable {
   
       &Debug("Reading manager table");
     #   Clean out the old table first..      #   Clean out the old table first..
   
    foreach my $key (keys %managers) {     foreach my $key (keys %managers) {
Line 415  sub ReadManagerTable { Line 424  sub ReadManagerTable {
   
    my $tablename = $perlvar{'lonTabDir'}."/managers.tab";     my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
    if (!open (MANAGERS, $tablename)) {     if (!open (MANAGERS, $tablename)) {
       logthis('<font color="red">No manager table.  Nobody can manage!!</font>');         my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
       return;         if (&Apache::lonnet::is_LC_dns($hostname)) {
              &logthis('<font color="red">No manager table.  Nobody can manage!!</font>');
          }
          return;
    }     }
    while(my $host = <MANAGERS>) {     while(my $host = <MANAGERS>) {
       chomp($host);        chomp($host);
       if ($host =~ "^#") {                  # Comment line.        if ($host =~ "^#") {                  # Comment line.
          next;           next;
       }        }
       if (!defined $hostip{$host}) { # This is a non cluster member        if (!defined &Apache::lonnet::get_host_ip($host)) { # This is a non cluster member
     #  The entry is of the form:      #  The entry is of the form:
     #    cluname:hostname      #    cluname:hostname
     #  cluname - A 'cluster hostname' is needed in order to negotiate      #  cluname - A 'cluster hostname' is needed in order to negotiate
Line 441  sub ReadManagerTable { Line 453  sub ReadManagerTable {
          }           }
       } else {        } else {
          logthis('<font color="green"> existing host'." $host</font>\n");           logthis('<font color="green"> existing host'." $host</font>\n");
          $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber           $managers{&Apache::lonnet::get_host_ip($host)} = $host;  # Use info from cluster tab if cluster memeber
       }        }
    }     }
 }  }
Line 502  sub AdjustHostContents { Line 514  sub AdjustHostContents {
     my $adjusted;      my $adjusted;
     my $me        = $perlvar{'lonHostID'};      my $me        = $perlvar{'lonHostID'};
   
  foreach my $line (split(/\n/,$contents)) {      foreach my $line (split(/\n/,$contents)) {
  if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {   if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/) ||
                ($line =~ /^\s*\^/))) {
     chomp($line);      chomp($line);
     my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);      my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
     if ($id eq $me) {      if ($id eq $me) {
           my $ip = gethostbyname($name);   my $ip = gethostbyname($name);
           my $ipnew = inet_ntoa($ip);   my $ipnew = inet_ntoa($ip);
          $ip = $ipnew;   $ip = $ipnew;
  #  Reconstruct the host line and append to adjusted:   #  Reconstruct the host line and append to adjusted:
   
    my $newline = "$id:$domain:$role:$name:$ip";   my $newline = "$id:$domain:$role:$name:$ip";
    if($maxcon ne "") { # Not all hosts have loncnew tuning params   if($maxcon ne "") { # Not all hosts have loncnew tuning params
      $newline .= ":$maxcon:$idleto:$mincon";      $newline .= ":$maxcon:$idleto:$mincon";
    }   }
    $adjusted .= $newline."\n";   $adjusted .= $newline."\n";
   
       } else { # Not me, pass unmodified.      } else { # Not me, pass unmodified.
    $adjusted .= $line."\n";   $adjusted .= $line."\n";
       }      }
  } else {                  # Blank or comment never re-written.   } else {                  # Blank or comment never re-written.
     $adjusted .= $line."\n"; # Pass blanks and comments as is.      $adjusted .= $line."\n"; # Pass blanks and comments as is.
  }   }
  }      }
  return $adjusted;      return $adjusted;
 }  }
 #  #
 #   InstallFile: Called to install an administrative file:  #   InstallFile: Called to install an administrative file:
 #       - The file is created with <name>.tmp  #       - The file is created int a temp directory called <name>.tmp
 #       - The <name>.tmp file is then mv'd to <name>  #       - lcinstall file is called to install the file.
 #   This lugubrious procedure is done to ensure that we are never without  #         since the web app has no direct write access to the table directory
 #   a valid, even if dated, version of the file regardless of who crashes  
 #   and when the crash occurs.  
 #  #
 #  Parameters:  #  Parameters:
 #       Name of the file  #       Name of the file
Line 541  sub AdjustHostContents { Line 552  sub AdjustHostContents {
 #  Return:  #  Return:
 #      nonzero - success.  #      nonzero - success.
 #      0       - failure and $! has an errno.  #      0       - failure and $! has an errno.
   # Assumptions:
   #    File installtion is a relatively infrequent
 #  #
 sub InstallFile {  sub InstallFile {
   
     my ($Filename, $Contents) = @_;      my ($Filename, $Contents) = @_;
     my $TempFile = $Filename.".tmp";  #     my $TempFile = $Filename.".tmp";
       my $exedir = $perlvar{'lonDaemons'};
       my $tmpdir = $exedir.'/tmp/';
       my $TempFile = $tmpdir."TempTableFile.tmp";
   
     #  Open the file for write:      #  Open the file for write:
   
Line 559  sub InstallFile { Line 575  sub InstallFile {
     print $fh ($Contents);       print $fh ($Contents); 
     $fh->close; # In case we ever have a filesystem w. locking      $fh->close; # In case we ever have a filesystem w. locking
   
     chmod(0660, $TempFile);      chmod(0664, $TempFile); # Everyone can write it.
   
     # Now we can move install the file in position.      # Use lcinstall file to put the file in the table directory...
       
     move($TempFile, $Filename);      &Debug("Opening pipe to $exedir/lcinstallfile $TempFile $Filename");
       my $pf = IO::File->new("| $exedir/lcinstallfile   $TempFile $Filename > $exedir/logs/lcinstallfile.log");
       close $pf;
       my $err = $?;
       &Debug("Status is $err");
       if ($err != 0) {
    my $msg = $err;
    if ($err < @installerrors) {
       $msg = $installerrors[$err];
    }
    &logthis("Install failed for table file $Filename : $msg");
    return 0;
       }
   
       # Remove the temp file:
   
       unlink($TempFile);
   
     return 1;      return 1;
 }  }
Line 571  sub InstallFile { Line 603  sub InstallFile {
   
 #  #
 #   ConfigFileFromSelector: converts a configuration file selector  #   ConfigFileFromSelector: converts a configuration file selector
 #                 (one of host or domain at this point) into a   #                 into a configuration file pathname.
 #                 configuration file pathname.  #                 Supports the following file selectors: 
   #                 hosts, domain, dns_hosts, dns_domain  
   #
 #  #
 #  Parameters:  #  Parameters:
 #      selector  - Configuration file selector.  #      selector  - Configuration file selector.
Line 584  sub ConfigFileFromSelector { Line 618  sub ConfigFileFromSelector {
     my $tablefile;      my $tablefile;
   
     my $tabledir = $perlvar{'lonTabDir'}.'/';      my $tabledir = $perlvar{'lonTabDir'}.'/';
     if ($selector eq "hosts") {      if (($selector eq "hosts") || ($selector eq "domain") || 
  $tablefile = $tabledir."hosts.tab";          ($selector eq "dns_hosts") || ($selector eq "dns_domain")) {
     } elsif ($selector eq "domain") {   $tablefile =  $tabledir.$selector.'.tab';
  $tablefile = $tabledir."domain.tab";  
     } else {  
  return undef;  
     }      }
     return $tablefile;      return $tablefile;
   
 }  }
 #  #
 #   PushFile:  Called to do an administrative push of a file.  #   PushFile:  Called to do an administrative push of a file.
Line 612  sub ConfigFileFromSelector { Line 642  sub ConfigFileFromSelector {
 sub PushFile {  sub PushFile {
     my $request = shift;          my $request = shift;    
     my ($command, $filename, $contents) = split(":", $request, 3);      my ($command, $filename, $contents) = split(":", $request, 3);
       &Debug("PushFile");
           
     #  At this point in time, pushes for only the following tables are      #  At this point in time, pushes for only the following tables are
     #  supported:      #  supported:
     #   hosts.tab  ($filename eq host).      #   hosts.tab  ($filename eq host).
     #   domain.tab ($filename eq domain).      #   domain.tab ($filename eq domain).
       #   dns_hosts.tab ($filename eq dns_host).
       #   dns_domain.tab ($filename eq dns_domain). 
     # Construct the destination filename or reject the request.      # Construct the destination filename or reject the request.
     #      #
     # lonManage is supposed to ensure this, however this session could be      # lonManage is supposed to ensure this, however this session could be
Line 628  sub PushFile { Line 661  sub PushFile {
     if(! (defined $tablefile)) {      if(! (defined $tablefile)) {
  return "refused";   return "refused";
     }      }
     #  
     # >copy< the old table to the backup table  
     #        don't rename in case system crashes/reboots etc. in the time  
     #        window between a rename and write.  
     #  
     my $backupfile = $tablefile;  
     $backupfile    =~ s/\.tab$/.old/;  
     if(!CopyFile($tablefile, $backupfile)) {  
  &logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");  
  return "error:$!";  
     }  
     &logthis('<font color="green"> Pushfile: backed up '  
     .$tablefile." to $backupfile</font>");  
       
     #  If the file being pushed is the host file, we adjust the entry for ourself so that the      #  If the file being pushed is the host file, we adjust the entry for ourself so that the
     #  IP will be our current IP as looked up in dns.  Note this is only 99% good as it's possible      #  IP will be our current IP as looked up in dns.  Note this is only 99% good as it's possible
     #  to conceive of conditions where we don't have a DNS entry locally.  This is possible in a       #  to conceive of conditions where we don't have a DNS entry locally.  This is possible in a 
Line 654  sub PushFile { Line 674  sub PushFile {
   
     #  Install the new file:      #  Install the new file:
   
       &logthis("Installing new $tablefile contents:\n$contents");
     if(!InstallFile($tablefile, $contents)) {      if(!InstallFile($tablefile, $contents)) {
  &logthis('<font color="red"> Pushfile: unable to install '   &logthis('<font color="red"> Pushfile: unable to install '
  .$tablefile." $! </font>");   .$tablefile." $! </font>");
  return "error:$!";   return "error:$!";
     } else {      } else {
  &logthis('<font color="green"> Installed new '.$tablefile   &logthis('<font color="green"> Installed new '.$tablefile
  ."</font>");   ." - transaction by: $clientname ($clientip)</font>");
           my $adminmail = $perlvar{'lonAdmEMail'};
           my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
           if ($admindom ne '') {
               my %domconfig =
                   &Apache::lonnet::get_dom('configuration',['contacts'],$admindom);
               if (ref($domconfig{'contacts'}) eq 'HASH') {
                   if ($domconfig{'contacts'}{'adminemail'} ne '') {
                       $adminmail = $domconfig{'contacts'}{'adminemail'};
                   }
               }
           }
           if ($adminmail =~ /^[^\@]+\@[^\@]+$/) {
               my $msg = new Mail::Send;
               $msg->to($adminmail);
               $msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'});
               $msg->add('Content-type','text/plain; charset=UTF-8');
               if (my $fh = $msg->open()) {
                   print $fh 'Update to '.$tablefile.' from Cluster Manager '.
                             "$clientname ($clientip)\n";
                   $fh->close;
               }
           }
     }      }
   
   
     #  Indicate success:      #  Indicate success:
     
     return "ok";      return "ok";
Line 834  sub AdjustOurHost { Line 875  sub AdjustOurHost {
     #   Use the config line to get my hostname.      #   Use the config line to get my hostname.
     #   Use gethostbyname to translate that into an IP address.      #   Use gethostbyname to translate that into an IP address.
     #      #
     my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);      my ($id,$domain,$role,$name,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
     my $BinaryIp = gethostbyname($name);  
     my $ip       = inet_ntoa($ip);  
     #      #
     #  Reassemble the config line from the elements in the list.      #  Reassemble the config line from the elements in the list.
     #  Note that if the loncnew items were not present before, they will      #  Note that if the loncnew items were not present before, they will
     #  be now even if they would be empty      #  be now even if they would be empty
     #      #
     my $newConfigLine = $id;      my $newConfigLine = $id;
     foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {      foreach my $item ($domain, $role, $name, $maxcon, $idleto, $mincon) {
  $newConfigLine .= ":".$item;   $newConfigLine .= ":".$item;
     }      }
     #  Replace the line:      #  Replace the line:
Line 889  sub EditFile { Line 928  sub EditFile {
   
     #  Split the command into it's pieces:  edit:filetype:script      #  Split the command into it's pieces:  edit:filetype:script
   
     my ($request, $filetype, $script) = split(/:/, $request,3); # : in script      my ($cmd, $filetype, $script) = split(/:/, $request,3); # : in script
   
     #  Check the pre-coditions for success:      #  Check the pre-coditions for success:
   
     if($request != "edit") { # Something is amiss afoot alack.      if($cmd != "edit") { # Something is amiss afoot alack.
  return "error:edit request detected, but request != 'edit'\n";   return "error:edit request detected, but request != 'edit'\n";
     }      }
     if( ($filetype ne "hosts")  &&      if( ($filetype ne "hosts")  &&
Line 938  sub EditFile { Line 977  sub EditFile {
     return "ok\n";      return "ok\n";
 }  }
   
 #---------------------------------------------------------------  
 #  
 # Manipulation of hash based databases (factoring out common code  
 # for later use as we refactor.  
 #  
 #  Ties a domain level resource file to a hash.  
 #  If requested a history entry is created in the associated hist file.  
 #  
 #  Parameters:  
 #     domain    - Name of the domain in which the resource file lives.  
 #     namespace - Name of the hash within that domain.  
 #     how       - How to tie the hash (e.g. GDBM_WRCREAT()).  
 #     loghead   - Optional parameter, if present a log entry is created  
 #                 in the associated history file and this is the first part  
 #                  of that entry.  
 #     logtail   - Goes along with loghead,  The actual logentry is of the  
 #                 form $loghead:<timestamp>:logtail.  
 # Returns:  
 #    Reference to a hash bound to the db file or alternatively undef  
 #    if the tie failed.  
 #  
 sub tie_domain_hash {  
     my ($domain,$namespace,$how,$loghead,$logtail) = @_;  
       
     # Filter out any whitespace in the domain name:  
       
     $domain =~ s/\W//g;  
       
     # We have enough to go on to tie the hash:  
       
     my $user_top_dir   = $perlvar{'lonUsersDir'};  
     my $domain_dir     = $user_top_dir."/$domain";  
     my $resource_file  = $domain_dir."/$namespace.db";  
     my %hash;  
     if(tie(%hash, 'GDBM_File', $resource_file, $how, 0640)) {  
  if (defined($loghead)) { # Need to log the operation.  
     my $logFh = IO::File->new(">>$domain_dir/$namespace.hist");  
     if($logFh) {  
  my $timestamp = time;  
  print $logFh "$loghead:$timestamp:$logtail\n";  
     }  
     $logFh->close;  
  }  
  return \%hash; # Return the tied hash.  
     } else {  
  return undef; # Tie failed.  
     }  
 }  
   
 #  
 #   Ties a user's resource file to a hash.    
 #   If necessary, an appropriate history  
 #   log file entry is made as well.  
 #   This sub factors out common code from the subs that manipulate  
 #   the various gdbm files that keep keyword value pairs.  
 # Parameters:  
 #   domain       - Name of the domain the user is in.  
 #   user         - Name of the 'current user'.  
 #   namespace    - Namespace representing the file to tie.  
 #   how          - What the tie is done to (e.g. GDBM_WRCREAT().  
 #   loghead      - Optional first part of log entry if there may be a  
 #                  history file.  
 #   what         - Optional tail of log entry if there may be a history  
 #                  file.  
 # Returns:  
 #   hash to which the database is tied.  It's up to the caller to untie.  
 #   undef if the has could not be tied.  
 #  
 sub tie_user_hash {  
     my ($domain,$user,$namespace,$how,$loghead,$what) = @_;  
   
     $namespace=~s/\//\_/g; # / -> _  
     $namespace=~s/\W//g; # whitespace eliminated.  
     my $proname     = propath($domain, $user);  
      
     #  Tie the database.  
       
     my %hash;  
     if(tie(%hash, 'GDBM_File', "$proname/$namespace.db",  
    $how, 0640)) {  
  # If this is a namespace for which a history is kept,  
  # make the history log entry:      
  if (($namespace !~/^nohist\_/) && (defined($loghead))) {  
     my $args = scalar @_;  
     Debug(" Opening history: $namespace $args");  
     my $hfh = IO::File->new(">>$proname/$namespace.hist");   
     if($hfh) {  
  my $now = time;  
  print $hfh "$loghead:$now:$what\n";  
     }  
     $hfh->close;  
  }  
  return \%hash;  
     } else {  
  return undef;  
     }  
       
 }  
   
 #   read_profile  #   read_profile
 #  #
 #   Returns a set of specific entries from a user's profile file.  #   Returns a set of specific entries from a user's profile file.
Line 1061  sub read_profile { Line 1001  sub read_profile {
  &GDBM_READER());   &GDBM_READER());
     if ($hashref) {      if ($hashref) {
         my @queries=split(/\&/,$what);          my @queries=split(/\&/,$what);
           if ($namespace eq 'roles') {
               @queries = map { &unescape($_); } @queries; 
           }
         my $qresult='';          my $qresult='';
   
  for (my $i=0;$i<=$#queries;$i++) {   for (my $i=0;$i<=$#queries;$i++) {
     $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.      $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.
  }   }
  $qresult=~s/\&$//;              # Remove trailing & from last lookup.   $qresult=~s/\&$//;              # Remove trailing & from last lookup.
  if (untie %$hashref) {   if (&untie_user_hash($hashref)) {
     return $qresult;      return $qresult;
  } else {   } else {
     return "error: ".($!+0)." untie (GDBM) Failed";      return "error: ".($!+0)." untie (GDBM) Failed";
Line 1106  sub ping_handler { Line 1049  sub ping_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     Debug("$cmd $tail $client .. $currenthostid:");      Debug("$cmd $tail $client .. $currenthostid:");
         
     Reply( $client,"$currenthostid\n","$cmd:$tail");      Reply( $client,\$currenthostid,"$cmd:$tail");
         
     return 1;      return 1;
 }  }
Line 1132  sub ping_handler { Line 1075  sub ping_handler {
 sub pong_handler {  sub pong_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
     my $reply=&reply("ping",$clientname);      my $reply=&Apache::lonnet::reply("ping",$clientname);
     &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");       &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); 
     return 1;      return 1;
 }  }
Line 1154  sub pong_handler { Line 1097  sub pong_handler {
 #  Implicit Inputs:  #  Implicit Inputs:
 #      $currenthostid - Global variable that carries the name of the host  #      $currenthostid - Global variable that carries the name of the host
 #                       known as.  #                       known as.
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  #      $clientname    - Global variable that carries the name of the host we're connected to.
 #  Returns:  #  Returns:
 #      1       - Ok to continue processing.  #      1       - Ok to continue processing.
 #      0       - Program should exit.  #      0       - Program should exit.
Line 1176  sub establish_key_handler { Line 1119  sub establish_key_handler {
     $key=substr($key,0,32);      $key=substr($key,0,32);
     my $cipherkey=pack("H32",$key);      my $cipherkey=pack("H32",$key);
     $cipher=new IDEA $cipherkey;      $cipher=new IDEA $cipherkey;
     &Reply($replyfd, "$buildkey\n", "$cmd:$tail");       &Reply($replyfd, \$buildkey, "$cmd:$tail"); 
         
     return 1;      return 1;
   
Line 1193  sub establish_key_handler { Line 1136  sub establish_key_handler {
 #  Implicit Inputs:  #  Implicit Inputs:
 #      $currenthostid - Global variable that carries the name of the host  #      $currenthostid - Global variable that carries the name of the host
 #                       known as.  #                       known as.
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  #      $clientname    - Global variable that carries the name of the host we're connected to.
 #  Returns:  #  Returns:
 #      1       - Ok to continue processing.  #      1       - Ok to continue processing.
 #      0       - Program should exit.  #      0       - Program should exit.
Line 1202  sub establish_key_handler { Line 1145  sub establish_key_handler {
 sub load_handler {  sub load_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
   
   
    # Get the load average from /proc/loadavg and calculate it as a percentage of     # Get the load average from /proc/loadavg and calculate it as a percentage of
    # the allowed load limit as set by the perl global variable lonLoadLim     # the allowed load limit as set by the perl global variable lonLoadLim
   
Line 1213  sub load_handler { Line 1158  sub load_handler {
         
     my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};      my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
   
     &Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");      &Reply( $replyfd, \$loadpercent, "$cmd:$tail");
         
     return 1;      return 1;
 }  }
Line 1230  sub load_handler { Line 1175  sub load_handler {
 #  Implicit Inputs:  #  Implicit Inputs:
 #      $currenthostid - Global variable that carries the name of the host  #      $currenthostid - Global variable that carries the name of the host
 #                       known as.  #                       known as.
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  #      $clientname    - Global variable that carries the name of the host we're connected to.
 #  Returns:  #  Returns:
 #      1       - Ok to continue processing.  #      1       - Ok to continue processing.
 #      0       - Program should exit  #      0       - Program should exit
Line 1242  sub load_handler { Line 1187  sub load_handler {
 sub user_load_handler {  sub user_load_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
     my $userloadpercent=&userload();      my $userloadpercent=&Apache::lonnet::userload();
     &Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");      &Reply($replyfd, \$userloadpercent, "$cmd:$tail");
           
     return 1;      return 1;
 }  }
Line 1286  sub user_authorization_type { Line 1231  sub user_authorization_type {
  } else {   } else {
             $type .= ':';              $type .= ':';
         }          }
  &Reply( $replyfd, "$type\n", $userinput);   &Reply( $replyfd, \$type, $userinput);
     }      }
       
     return 1;      return 1;
Line 1308  sub user_authorization_type { Line 1253  sub user_authorization_type {
 #    a reply is written to the client.  #    a reply is written to the client.
 sub push_file_handler {  sub push_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
       &Debug("In push file handler");
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     # At this time we only know that the IP of our partner is a valid manager      # At this time we only know that the IP of our partner is a valid manager
Line 1316  sub push_file_handler { Line 1261  sub push_file_handler {
     # spoofing).      # spoofing).
   
     my $cert = &GetCertificate($userinput);      my $cert = &GetCertificate($userinput);
     if(&ValidManager($cert)) {       if(&ValidManager($cert)) {
    &Debug("Valid manager: $client");
   
  # Now presumably we have the bona fides of both the peer host and the   # Now presumably we have the bona fides of both the peer host and the
  # process making the request.   # process making the request.
               
  my $reply = &PushFile($userinput);   my $reply = &PushFile($userinput);
  &Reply($client, "$reply\n", $userinput);   &Reply($client, \$reply, $userinput);
   
     } else {      } else {
    &logthis("push_file_handler $client is not valid");
  &Failure( $client, "refused\n", $userinput);   &Failure( $client, "refused\n", $userinput);
     }       } 
     return 1;      return 1;
 }  }
 &register_handler("pushfile", \&push_file_handler, 1, 0, 1);  &register_handler("pushfile", \&push_file_handler, 1, 0, 1);
   
   # The du_handler routine should be considered obsolete and is retained
   # for communication with legacy servers.  Please see the du2_handler.
 #  #
 #   du  - list the disk usuage of a directory recursively.   #   du  - list the disk usage of a directory recursively. 
 #      #    
 #   note: stolen code from the ls file handler  #   note: stolen code from the ls file handler
 #   under construction by Rick Banghart   #   under construction by Rick Banghart 
Line 1350  sub push_file_handler { Line 1299  sub push_file_handler {
 #  #
 sub du_handler {  sub du_handler {
     my ($cmd, $ududir, $client) = @_;      my ($cmd, $ududir, $client) = @_;
     my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.      ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
     my $userinput = "$cmd:$ududir";      my $userinput = "$cmd:$ududir";
   
     if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {      if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {
Line 1368  sub du_handler { Line 1317  sub du_handler {
  my $code=sub {    my $code=sub { 
     if ($_=~/\.\d+\./) { return;}       if ($_=~/\.\d+\./) { return;} 
     if ($_=~/\.meta$/) { return;}      if ($_=~/\.meta$/) { return;}
       if (-d $_)         { return;}
     $total_size+=(stat($_))[7];      $total_size+=(stat($_))[7];
  };   };
  chdir($ududir);   chdir($ududir);
  find($code,$ududir);   find($code,$ududir);
  $total_size=int($total_size/1024);   $total_size=int($total_size/1024);
  &Reply($client,"$total_size\n","$cmd:$ududir");   &Reply($client,\$total_size,"$cmd:$ududir");
     } else {      } else {
  &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");    &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); 
     }      }
Line 1381  sub du_handler { Line 1331  sub du_handler {
 }  }
 &register_handler("du", \&du_handler, 0, 1, 0);  &register_handler("du", \&du_handler, 0, 1, 0);
   
   # Please also see the du_handler, which is obsoleted by du2. 
   # du2_handler differs from du_handler in that required path to directory
   # provided by &propath() is prepended in the handler instead of on the 
   # client side.
   #
   #   du2  - list the disk usage of a directory recursively.
   #
   # Parameters:
   #    $cmd        - The command that dispatched us (du).
   #    $tail       - The tail of the request that invoked us.
   #                  $tail is a : separated list of the following:
   #                   - $ududir - directory path to list (before prepending)
   #                   - $getpropath = 1 if &propath() should prepend
   #                   - $uname - username to use for &propath or user dir
   #                   - $udom - domain to use for &propath or user dir
   #                   All are escaped.
   #    $client     - Socket open on the client.
   # Returns:
   #     1 - indicating that the daemon should not disconnect.
   # Side Effects:
   #   The reply is written to $client.
   #
   
   sub du2_handler {
       my ($cmd, $tail, $client) = @_;
       my ($ududir,$getpropath,$uname,$udom) = map { &unescape($_) } (split(/:/, $tail));
       my $userinput = "$cmd:$tail";
       if (($ududir=~/\.\./) || (($ududir!~m|^/home/httpd/|) && (!$getpropath))) {
           &Failure($client,"refused\n","$cmd:$tail");
           return 1;
       }
       if ($getpropath) {
           if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
               $ududir = &propath($udom,$uname).'/'.$ududir;
           } else {
               &Failure($client,"refused\n","$cmd:$tail");
               return 1;
           }
       }
       #  Since $ududir could have some nasties in it,
       #  we will require that ududir is a valid
       #  directory.  Just in case someone tries to
       #  slip us a  line like .;(cd /home/httpd rm -rf*)
       #  etc.
       #
       if (-d $ududir) {
           my $total_size=0;
           my $code=sub {
               if ($_=~/\.\d+\./) { return;}
               if ($_=~/\.meta$/) { return;}
               if (-d $_)         { return;}
               $total_size+=(stat($_))[7];
           };
           chdir($ududir);
           find($code,$ududir);
           $total_size=int($total_size/1024);
           &Reply($client,\$total_size,"$cmd:$ududir");
       } else {
           &Failure($client, "bad_directory:$ududir\n","$cmd:$tail");
       }
       return 1;
   }
   &register_handler("du2", \&du2_handler, 0, 1, 0);
   
 #  #
 # The ls_handler routine should be considered obosolete and is retained  # The ls_handler routine should be considered obsolete and is retained
 # for communication with legacy servers.  Please see the ls2_handler.  # for communication with legacy servers.  Please see the ls3_handler.
 #  #
 #   ls  - list the contents of a directory.  For each file in the  #   ls  - list the contents of a directory.  For each file in the
 #    selected directory the filename followed by the full output of  #    selected directory the filename followed by the full output of
Line 1422  sub ls_handler { Line 1436  sub ls_handler {
  open(FILE, $ulsdir.'/'.$ulsfn.".meta");   open(FILE, $ulsdir.'/'.$ulsfn.".meta");
  my @obsolete=<FILE>;   my @obsolete=<FILE>;
  foreach my $obsolete (@obsolete) {   foreach my $obsolete (@obsolete) {
     if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; }       if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } 
     if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }      if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
  }   }
     }      }
Line 1442  sub ls_handler { Line 1456  sub ls_handler {
  $ulsout='no_such_dir';   $ulsout='no_such_dir';
     }      }
     if ($ulsout eq '') { $ulsout='empty'; }      if ($ulsout eq '') { $ulsout='empty'; }
     &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.      &Reply($client, \$ulsout, $userinput); # This supports debug logging.
           
     return 1;      return 1;
   
 }  }
 &register_handler("ls", \&ls_handler, 0, 1, 0);  &register_handler("ls", \&ls_handler, 0, 1, 0);
   
 #  # The ls2_handler routine should be considered obsolete and is retained
 # Please also see the ls_handler, which this routine obosolets.  # for communication with legacy servers.  Please see the ls3_handler.
   # Please also see the ls_handler, which was itself obsoleted by ls2.
 # ls2_handler differs from ls_handler in that it escapes its return   # ls2_handler differs from ls_handler in that it escapes its return 
 # values before concatenating them together with ':'s.  # values before concatenating them together with ':'s.
 #  #
Line 1490  sub ls2_handler { Line 1505  sub ls2_handler {
                         open(FILE, $ulsdir.'/'.$ulsfn.".meta");                          open(FILE, $ulsdir.'/'.$ulsfn.".meta");
                         my @obsolete=<FILE>;                          my @obsolete=<FILE>;
                         foreach my $obsolete (@obsolete) {                          foreach my $obsolete (@obsolete) {
                             if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; }                               if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } 
                             if($obsolete =~ m|(<copyright>)(default)|) {                              if($obsolete =~ m|(<copyright>)(default)|) {
                                 $rights = 1;                                  $rights = 1;
                             }                              }
Line 1511  sub ls2_handler { Line 1526  sub ls2_handler {
         $ulsout='no_such_dir';          $ulsout='no_such_dir';
    }     }
    if ($ulsout eq '') { $ulsout='empty'; }     if ($ulsout eq '') { $ulsout='empty'; }
    &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.     &Reply($client, \$ulsout, $userinput); # This supports debug logging.
    return 1;     return 1;
 }  }
 &register_handler("ls2", \&ls2_handler, 0, 1, 0);  &register_handler("ls2", \&ls2_handler, 0, 1, 0);
   #
   #   ls3  - list the contents of a directory.  For each file in the
   #    selected directory the filename followed by the full output of
   #    the stat function is returned.  The returned info for each
   #    file are separated by ':'.  The stat fields are separated by &'s.
   # Parameters:
   #    $cmd        - The command that dispatched us (ls).
   #    $tail       - The tail of the request that invoked us.
   #                  $tail is a : separated list of the following:
   #                   - $ulsdir - directory path to list (before prepending)
   #                   - $getpropath = 1 if &propath() should prepend
   #                   - $getuserdir = 1 if path to user dir in lonUsers should
   #                                     prepend
   #                   - $alternate_root - path to prepend
   #                   - $uname - username to use for &propath or user dir
   #                   - $udom - domain to use for &propath or user dir
   #            All of these except $getpropath and &getuserdir are escaped.    
   #                  no_such_dir.
   #    $client     - Socket open on the client.
   # Returns:
   #     1 - indicating that the daemon should not disconnect.
   # Side Effects:
   #   The reply is written to $client.
   #
   
   sub ls3_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($ulsdir,$getpropath,$getuserdir,$alternate_root,$uname,$udom) =
           split(/:/,$tail);
       if (defined($ulsdir)) {
           $ulsdir = &unescape($ulsdir);
       }
       if (defined($alternate_root)) {
           $alternate_root = &unescape($alternate_root);
       }
       if (defined($uname)) {
           $uname = &unescape($uname);
       }
       if (defined($udom)) {
           $udom = &unescape($udom);
       }
   
       my $dir_root = $perlvar{'lonDocRoot'};
       if ($getpropath) {
           if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
               $dir_root = &propath($udom,$uname);
               $dir_root =~ s/\/$//;
           } else {
               &Failure($client,"refused\n","$cmd:$tail");
               return 1;
           }
       } elsif ($getuserdir) {
           if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
               my $subdir=$uname.'__';
               $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
               $dir_root = $Apache::lonnet::perlvar{'lonUsersDir'}
                          ."/$udom/$subdir/$uname";
           } else {
               &Failure($client,"refused\n","$cmd:$tail");
               return 1;
           }
       } elsif ($alternate_root ne '') {
           $dir_root = $alternate_root;
       }
       if (($dir_root ne '') && ($dir_root ne '/')) {
           if ($ulsdir =~ /^\//) {
               $ulsdir = $dir_root.$ulsdir;
           } else {
               $ulsdir = $dir_root.'/'.$ulsdir;
           }
       }
       my $obs;
       my $rights;
       my $ulsout='';
       my $ulsfn;
       if (-e $ulsdir) {
           if(-d $ulsdir) {
               if (opendir(LSDIR,$ulsdir)) {
                   while ($ulsfn=readdir(LSDIR)) {
                       undef($obs);
                       undef($rights);
                       my @ulsstats=stat($ulsdir.'/'.$ulsfn);
                       #We do some obsolete checking here
                       if(-e $ulsdir.'/'.$ulsfn.".meta") {
                           open(FILE, $ulsdir.'/'.$ulsfn.".meta");
                           my @obsolete=<FILE>;
                           foreach my $obsolete (@obsolete) {
                               if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
                               if($obsolete =~ m|(<copyright>)(default)|) {
                                   $rights = 1;
                               }
                           }
                       }
                       my $tmp = $ulsfn.'&'.join('&',@ulsstats);
                       if ($obs    eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
                       if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
                       $ulsout.= &escape($tmp).':';
                   }
                   closedir(LSDIR);
               }
           } else {
               my @ulsstats=stat($ulsdir);
               $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
           }
       } else {
           $ulsout='no_such_dir';
       }
       if ($ulsout eq '') { $ulsout='empty'; }
       &Reply($client, \$ulsout, $userinput); # This supports debug logging.
       return 1;
   }
   &register_handler("ls3", \&ls3_handler, 0, 1, 0);
   
   sub read_lonnet_global {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       my $requested = &Apache::lonnet::thaw_unescape($tail);
       my $result;
       my %packagevars = (
                           spareid => \%Apache::lonnet::spareid,
                           perlvar => \%Apache::lonnet::perlvar,
                         );
       my %limit_to = (
                       perlvar => {
                                    lonOtherAuthen => 1,
                                    lonBalancer    => 1,
                                    lonVersion     => 1,
                                    lonSysEMail    => 1,
                                    lonHostID      => 1,
                                    lonRole        => 1,
                                    lonDefDomain   => 1,
                                    lonLoadLim     => 1,
                                    lonUserLoadLim => 1,
                                  }
                     );
       if (ref($requested) eq 'HASH') {
           foreach my $what (keys(%{$requested})) {
               my $response;
               my $items = {};
               if (exists($packagevars{$what})) {
                   if (ref($limit_to{$what}) eq 'HASH') {
                       foreach my $varname (keys(%{$packagevars{$what}})) {
                           if ($limit_to{$what}{$varname}) {
                               $items->{$varname} = $packagevars{$what}{$varname};
                           }
                       }
                   } else {
                       $items = $packagevars{$what};
                   }
                   if ($what eq 'perlvar') {
                       if (!exists($packagevars{$what}{'lonBalancer'})) {
                           if ($dist =~ /^(centos|rhes|fedora|scientific)/) {
                               my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf');
                               if (ref($othervarref) eq 'HASH') {
                                   $items->{'lonBalancer'} = $othervarref->{'lonBalancer'};
                               }
                           }
                       }
                   }
                   $response = &Apache::lonnet::freeze_escape($items);
               }
               $result .= &escape($what).'='.$response.'&';
           }
       }
       $result =~ s/\&$//;
       &Reply($client,\$result,$userinput);
       return 1;
   }
   &register_handler("readlonnetglobal", \&read_lonnet_global, 0, 1, 0);
   
   sub server_devalidatecache_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       my ($name,$id) = map { &unescape($_); } split(/:/,$tail);
       &Apache::lonnet::devalidate_cache_new($name,$id);
       my $result = 'ok';
       &Reply($client,\$result,$userinput);
       return 1;
   }
   &register_handler("devalidatecache", \&server_devalidatecache_handler, 0, 1, 0);
   
   sub server_timezone_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       my $timezone;
       my $clockfile = '/etc/sysconfig/clock'; # Fedora/CentOS/SuSE
       my $tzfile = '/etc/timezone'; # Debian/Ubuntu
       if (-e $clockfile) {
           if (open(my $fh,"<$clockfile")) {
               while (<$fh>) {
                   next if (/^[\#\s]/);
                   if (/^(?:TIME)?ZONE\s*=\s*['"]?\s*([\w\/]+)/) {
                       $timezone = $1;
                       last;
                   }
               }
               close($fh);
           }
       } elsif (-e $tzfile) {
           if (open(my $fh,"<$tzfile")) {
               $timezone = <$fh>;
               close($fh);
               chomp($timezone);
               if ($timezone =~ m{^Etc/(\w+)$}) {
                   $timezone = $1;
               }
           }
       }
       &Reply($client,\$timezone,$userinput); # This supports debug logging.
       return 1;
   }
   &register_handler("servertimezone", \&server_timezone_handler, 0, 1, 0);
   
   sub server_loncaparev_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       &Reply($client,\$perlvar{'lonVersion'},$userinput);
       return 1;
   }
   &register_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);
   
   sub server_homeID_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       &Reply($client,\$perlvar{'lonHostID'},$userinput);
       return 1;
   }
   &register_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0);
   
   sub server_distarch_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       my $reply = &distro_and_arch();
       &Reply($client,\$reply,$userinput);
       return 1;
   }
   &register_handler("serverdistarch", \&server_distarch_handler, 0, 1, 0);
   
 #   Process a reinit request.  Reinit requests that either  #   Process a reinit request.  Reinit requests that either
 #   lonc or lond be reinitialized so that an updated   #   lonc or lond be reinitialized so that an updated 
Line 1539  sub reinit_process_handler { Line 1792  sub reinit_process_handler {
     if(&ValidManager($cert)) {      if(&ValidManager($cert)) {
  chomp($userinput);   chomp($userinput);
  my $reply = &ReinitProcess($userinput);   my $reply = &ReinitProcess($userinput);
  &Reply( $client,  "$reply\n", $userinput);   &Reply( $client,  \$reply, $userinput);
     } else {      } else {
  &Failure( $client, "refused\n", $userinput);   &Failure( $client, "refused\n", $userinput);
     }      }
Line 1623  sub authenticate_handler { Line 1876  sub authenticate_handler {
     #  udom    - User's domain.      #  udom    - User's domain.
     #  uname   - Username.      #  uname   - Username.
     #  upass   - User's password.      #  upass   - User's password.
       #  checkdefauth - Pass to validate_user() to try authentication
       #                 with default auth type(s) if no user account.
       #  clientcancheckhost - Passed by clients with functionality in lonauth.pm
       #                       to check if session can be hosted.
           
     my ($udom,$uname,$upass)=split(/:/,$tail);      my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail);
     &Debug(" Authenticate domain = $udom, user = $uname, password = $upass");      &Debug(" Authenticate domain = $udom, user = $uname, password = $upass,  checkdefauth = $checkdefauth");
     chomp($upass);      chomp($upass);
     $upass=&unescape($upass);      $upass=&unescape($upass);
   
     my $pwdcorrect = &validate_user($udom, $uname, $upass);      my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
     if($pwdcorrect) {      if($pwdcorrect) {
  &Reply( $client, "authorized\n", $userinput);          my $canhost = 1;
           unless ($clientcancheckhost) {
               my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
               my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
               my @intdoms;
               my $internet_names = &Apache::lonnet::get_internet_names($clientname);
               if (ref($internet_names) eq 'ARRAY') {
                   @intdoms = @{$internet_names};
               }
               unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
                   my ($remote,$hosted);
                   my $remotesession = &get_usersession_config($udom,'remotesession');
                   if (ref($remotesession) eq 'HASH') {
                       $remote = $remotesession->{'remote'}
                   }
                   my $hostedsession = &get_usersession_config($clienthomedom,'hostedsession');
                   if (ref($hostedsession) eq 'HASH') {
                       $hosted = $hostedsession->{'hosted'};
                   }
                   $canhost = &Apache::lonnet::can_host_session($udom,$clientname,
                                                                $clientversion,
                                                                $remote,$hosted);
               }
           }
           if ($canhost) {               
               &Reply( $client, "authorized\n", $userinput);
           } else {
               &Reply( $client, "not_allowed_to_host\n", $userinput);
           }
  #   #
  #  Bad credentials: Failed to authorize   #  Bad credentials: Failed to authorize
  #   #
Line 1674  sub change_password_handler { Line 1959  sub change_password_handler {
     #  uname - Username.      #  uname - Username.
     #  upass - Current password.      #  upass - Current password.
     #  npass - New password.      #  npass - New password.
       #  context - Context in which this was called 
       #            (preferences or reset_by_email).
       #  lonhost - HostID of server where request originated 
         
     my ($udom,$uname,$upass,$npass)=split(/:/,$tail);      my ($udom,$uname,$upass,$npass,$context,$lonhost)=split(/:/,$tail);
   
     $upass=&unescape($upass);      $upass=&unescape($upass);
     $npass=&unescape($npass);      $npass=&unescape($npass);
     &Debug("Trying to change password for $uname");      &Debug("Trying to change password for $uname");
   
     # First require that the user can be authenticated with their      # First require that the user can be authenticated with their
     # old password:      # old password unless context was 'reset_by_email':
       
     my $validated = &validate_user($udom, $uname, $upass);      my ($validated,$failure);
       if ($context eq 'reset_by_email') {
           if ($lonhost eq '') {
               $failure = 'invalid_client';
           } else {
               $validated = 1;
           }
       } else {
           $validated = &validate_user($udom, $uname, $upass);
       }
     if($validated) {      if($validated) {
  my $realpasswd  = &get_auth_type($udom, $uname); # Defined since authd.   my $realpasswd  = &get_auth_type($udom, $uname); # Defined since authd.
   
Line 1695  sub change_password_handler { Line 1992  sub change_password_handler {
     $salt=substr($salt,6,2);      $salt=substr($salt,6,2);
     my $ncpass=crypt($npass,$salt);      my $ncpass=crypt($npass,$salt);
     if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {      if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {
  &logthis("Result of password change for "   my $msg="Result of password change for $uname: pwchange_success";
  ."$uname: pwchange_success");                  if ($lonhost) {
                       $msg .= " - request originated from: $lonhost";
                   }
                   &logthis($msg);
  &Reply($client, "ok\n", $userinput);   &Reply($client, "ok\n", $userinput);
     } else {      } else {
  &logthis("Unable to open $uname passwd "                  &logthis("Unable to open $uname passwd "               
  ."to change password");   ."to change password");
  &Failure( $client, "non_authorized\n",$userinput);   &Failure( $client, "non_authorized\n",$userinput);
     }      }
  } elsif ($howpwd eq 'unix') {   } elsif ($howpwd eq 'unix' && $context ne 'reset_by_email') {
     my $result = &change_unix_password($uname, $npass);      my $result = &change_unix_password($uname, $npass);
     &logthis("Result of password change for $uname: ".      &logthis("Result of password change for $uname: ".
      $result);       $result);
     &Reply($client, "$result\n", $userinput);      &Reply($client, \$result, $userinput);
  } else {   } else {
     # this just means that the current password mode is not      # this just means that the current password mode is not
     # one we know how to change (e.g the kerberos auth modes or      # one we know how to change (e.g the kerberos auth modes or
Line 1717  sub change_password_handler { Line 2017  sub change_password_handler {
  }     }  
   
     } else {      } else {
  &Failure( $client, "non_authorized\n", $userinput);   if ($failure eq '') {
       $failure = 'non_authorized';
    }
    &Failure( $client, "$failure\n", $userinput);
     }      }
   
     return 1;      return 1;
Line 1767  sub add_user_handler { Line 2070  sub add_user_handler {
     ."makeuser";      ."makeuser";
     }      }
     unless ($fperror) {      unless ($fperror) {
  my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);   my $result=&make_passwd_file($uname,$udom,$umode,$npass, $passfilename);
  &Reply($client, $result, $userinput);     #BUGBUG - could be fail   &Reply($client,\$result, $userinput);     #BUGBUG - could be fail
     } else {      } else {
  &Failure($client, "$fperror\n", $userinput);   &Failure($client, \$fperror, $userinput);
     }      }
  }   }
  umask($oldumask);   umask($oldumask);
Line 1837  sub change_authentication_handler { Line 2140  sub change_authentication_handler {
  my $result = &change_unix_password($uname, $npass);   my $result = &change_unix_password($uname, $npass);
  &logthis("Result of password change for $uname: ".$result);   &logthis("Result of password change for $uname: ".$result);
  if ($result eq "ok") {   if ($result eq "ok") {
     &Reply($client, "$result\n")      &Reply($client, \$result);
  } else {   } else {
     &Failure($client, "$result\n");      &Failure($client, \$result);
  }   }
     } else {      } else {
  my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);   my $result=&make_passwd_file($uname,$udom,$umode,$npass,$passfilename);
  #   #
  #  If the current auth mode is internal, and the old auth mode was   #  If the current auth mode is internal, and the old auth mode was
  #  unix, or krb*,  and the user is an author for this domain,   #  unix, or krb*,  and the user is an author for this domain,
Line 1858  sub change_authentication_handler { Line 2161  sub change_authentication_handler {
  &manage_permissions("/$udom/_au", $udom, $uname, "$umode:");   &manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
     }      }
  }   }
  &Reply($client, $result, $userinput);   &Reply($client, \$result, $userinput);
     }      }
                 
   
Line 1904  sub is_home_handler { Line 2207  sub is_home_handler {
 &register_handler("home", \&is_home_handler, 0,1,0);  &register_handler("home", \&is_home_handler, 0,1,0);
   
 #  #
 #   Process an update request for a resource?? I think what's going on here is  #   Process an update request for a resource.
 #   that a resource has been modified that we hold a subscription to.  #   A resource has been modified that we hold a subscription to.
 #   If the resource is not local, then we must update, or at least invalidate our  #   If the resource is not local, then we must update, or at least invalidate our
 #   cached copy of the resource.   #   cached copy of the resource. 
 #   FUTURE WORK:  
 #      I need to look at this logic carefully.  My druthers would be to follow  
 #      typical caching logic, and simple invalidate the cache, drop any subscription  
 #      an let the next fetch start the ball rolling again... however that may  
 #      actually be more difficult than it looks given the complex web of  
 #      proxy servers.  
 # Parameters:  # Parameters:
 #    $cmd      - The command that got us here.  #    $cmd      - The command that got us here.
 #    $tail     - Tail of the command (remaining parameters).  #    $tail     - Tail of the command (remaining parameters).
Line 1937  sub update_resource_handler { Line 2234  sub update_resource_handler {
     my $ownership=ishome($fname);      my $ownership=ishome($fname);
     if ($ownership eq 'not_owner') {      if ($ownership eq 'not_owner') {
  if (-e $fname) {   if (-e $fname) {
               # Delete preview file, if exists
               unlink("$fname.tmp");
               # Get usage stats
     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,      my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);   $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
     my $now=time;      my $now=time;
     my $since=$now-$atime;      my $since=$now-$atime;
               # If the file has not been used within lonExpire seconds,
               # unsubscribe from it and delete local copy
     if ($since>$perlvar{'lonExpire'}) {      if ($since>$perlvar{'lonExpire'}) {
  my $reply=&reply("unsub:$fname","$clientname");   my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
    &devalidate_meta_cache($fname);
  unlink("$fname");   unlink("$fname");
    unlink("$fname.meta");
     } else {      } else {
               # Yes, this is in active use. Get a fresh copy. Since it might be in
               # very active use and huge (like a movie), copy it to "in.transfer" filename first.
  my $transname="$fname.in.transfer";   my $transname="$fname.in.transfer";
  my $remoteurl=&reply("sub:$fname","$clientname");   my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
  my $response;   my $response;
  alarm(120);  # FIXME: cannot replicate files that take more than two minutes to transfer?
   # alarm(120);
   # FIXME: this should use the LWP mechanism, not internal alarms.
                   alarm(1200);
  {   {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',"$remoteurl");      my $request=new HTTP::Request('GET',"$remoteurl");
Line 1956  sub update_resource_handler { Line 2265  sub update_resource_handler {
  }   }
  alarm(0);   alarm(0);
  if ($response->is_error()) {   if ($response->is_error()) {
   # FIXME: we should probably clean up here instead of just whine
     unlink($transname);      unlink($transname);
     my $message=$response->status_line;      my $message=$response->status_line;
     &logthis("LWP GET: $message for $fname ($remoteurl)");      &logthis("LWP GET: $message for $fname ($remoteurl)");
  } else {   } else {
     if ($remoteurl!~/\.meta$/) {      if ($remoteurl!~/\.meta$/) {
   # FIXME: isn't there an internal LWP mechanism for this?
  alarm(120);   alarm(120);
  {   {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
Line 1972  sub update_resource_handler { Line 2283  sub update_resource_handler {
  }   }
  alarm(0);   alarm(0);
     }      }
                       # we successfully transfered, copy file over to real name
     rename($transname,$fname);      rename($transname,$fname);
       &devalidate_meta_cache($fname);
  }   }
     }      }
     &Reply( $client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
Line 1986  sub update_resource_handler { Line 2299  sub update_resource_handler {
 }  }
 &register_handler("update", \&update_resource_handler, 0 ,1, 0);  &register_handler("update", \&update_resource_handler, 0 ,1, 0);
   
   sub devalidate_meta_cache {
       my ($url) = @_;
       use Cache::Memcached;
       my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
       $url = &Apache::lonnet::declutter($url);
       $url =~ s-\.meta$--;
       my $id = &escape('meta:'.$url);
       $memcache->delete($id);
   }
   
 #  #
 #   Fetch a user file from a remote server to the user's home directory  #   Fetch a user file from a remote server to the user's home directory
 #   userfiles subdir.  #   userfiles subdir.
Line 2022  sub fetch_user_file_handler { Line 2345  sub fetch_user_file_handler {
   
  my $destname=$udir.'/'.$ufile;   my $destname=$udir.'/'.$ufile;
  my $transname=$udir.'/'.$ufile.'.in.transit';   my $transname=$udir.'/'.$ufile.'.in.transit';
  my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;          my $clientprotocol=$Apache::lonnet::protocol{$clientname};
           $clientprotocol = 'http' if ($clientprotocol ne 'https');
    my $clienthost = &Apache::lonnet::hostname($clientname);
    my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;
  my $response;   my $response;
  Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");   Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
  alarm(120);   alarm(120);
Line 2044  sub fetch_user_file_handler { Line 2370  sub fetch_user_file_handler {
  unlink($transname);   unlink($transname);
  &Failure($client, "failed\n", $userinput);   &Failure($client, "failed\n", $userinput);
     } else {      } else {
                   if ($fname =~ /^default.+\.(page|sequence)$/) {
                       my ($major,$minor) = split(/\./,$clientversion);
                       if (($major < 2) || ($major == 2 && $minor < 11)) {
                           my $now = time;
                           &Apache::lonnet::do_cache_new('crschange',$udom.'_'.$uname,$now,600);
                           my $key = &escape('internal.contentchange');
                           my $what = "$key=$now";
                           my $hashref = &tie_user_hash($udom,$uname,'environment',
                                                        &GDBM_WRCREAT(),"P",$what);
                           if ($hashref) {
                               $hashref->{$key}=$now;
                               if (!&untie_user_hash($hashref)) {
                                   &logthis("error: ".($!+0)." untie (GDBM) failed ".
                                            "when updating internal.contentchange");
                               }
                           }
                       }
                   }
  &Reply($client, "ok\n", $userinput);   &Reply($client, "ok\n", $userinput);
     }      }
  }      }   
Line 2184  sub rename_user_file_handler { Line 2528  sub rename_user_file_handler {
 &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);  &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);
   
 #  #
   #  Checks if the specified user has an active session on the server
   #  return ok if so, not_found if not
   #
   # Parameters:
   #   cmd      - The request keyword that dispatched to tus.
   #   tail     - The tail of the request (colon separated parameters).
   #   client   - Filehandle open on the client.
   # Return:
   #    1.
   sub user_has_session_handler {
       my ($cmd, $tail, $client) = @_;
   
       my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
       
       opendir(DIR,$perlvar{'lonIDsDir'});
       my $filename;
       while ($filename=readdir(DIR)) {
    last if ($filename=~/^\Q$uname\E_\d+_\Q$udom\E_/);
       }
       if ($filename) {
    &Reply($client, "ok\n", "$cmd:$tail");
       } else {
    &Failure($client, "not_found\n", "$cmd:$tail");
       }
       return 1;
   
   }
   &register_handler("userhassession", \&user_has_session_handler, 0,1,0);
   
   #
 #  Authenticate access to a user file by checking that the token the user's   #  Authenticate access to a user file by checking that the token the user's 
 #  passed also exists in their session file  #  passed also exists in their session file
 #  #
Line 2199  sub token_auth_user_file_handler { Line 2573  sub token_auth_user_file_handler {
     my ($fname, $session) = split(/:/, $tail);      my ($fname, $session) = split(/:/, $tail);
           
     chomp($session);      chomp($session);
     my $reply="non_auth\n";      my $reply="non_auth";
     if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.      my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';
      $session.'.id')) {      if (open(ENVIN,"$file")) {
  while (my $line=<ENVIN>) {   flock(ENVIN,LOCK_SH);
     if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; }   tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
    if (exists($disk_env{"userfile.$fname"})) {
       $reply="ok";
    } else {
       foreach my $envname (keys(%disk_env)) {
    if ($envname=~ m|^userfile\.\Q$fname\E|) {
       $reply="ok";
       last;
    }
       }
  }   }
    untie(%disk_env);
  close(ENVIN);   close(ENVIN);
  &Reply($client, $reply, "$cmd:$tail");   &Reply($client, \$reply, "$cmd:$tail");
     } else {      } else {
  &Failure($client, "invalid_token\n", "$cmd:$tail");   &Failure($client, "invalid_token\n", "$cmd:$tail");
     }      }
Line 2266  sub subscribe_handler { Line 2650  sub subscribe_handler {
 &register_handler("sub", \&subscribe_handler, 0, 1, 0);  &register_handler("sub", \&subscribe_handler, 0, 1, 0);
   
 #  #
 #   Determine the version of a resource (?) Or is it return  #   Determine the latest version of a resource (it looks for the highest
 #   the top version of the resource?  Not yet clear from the  #   past version and then returns that +1)
 #   code in currentversion.  
 #  #
 # Parameters:  # Parameters:
 #    $cmd      - The command that got us here.  #    $cmd      - The command that got us here.
 #    $tail     - Tail of the command (remaining parameters).  #    $tail     - Tail of the command (remaining parameters).
   #                 (Should consist of an absolute path to a file)
 #    $client   - File descriptor connected to client.  #    $client   - File descriptor connected to client.
 # Returns  # Returns
 #     0        - Requested to exit, caller should shut down.  #     0        - Requested to exit, caller should shut down.
Line 2354  sub put_user_profile_entry { Line 2738  sub put_user_profile_entry {
  my ($key,$value)=split(/=/,$pair);   my ($key,$value)=split(/=/,$pair);
  $hashref->{$key}=$value;   $hashref->{$key}=$value;
     }      }
     if (untie(%$hashref)) {      if (&untie_user_hash($hashref)) {
  &Reply( $client, "ok\n", $userinput);   &Reply( $client, "ok\n", $userinput);
     } else {      } else {
  &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".   &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
Line 2362  sub put_user_profile_entry { Line 2746  sub put_user_profile_entry {
  $userinput);   $userinput);
     }      }
  } else {   } else {
     &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".      &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
      "while attempting put\n", $userinput);       "while attempting put\n", $userinput);
  }   }
     } else {      } else {
Line 2398  sub newput_user_profile_entry { Line 2782  sub newput_user_profile_entry {
     my $hashref = &tie_user_hash($udom, $uname, $namespace,      my $hashref = &tie_user_hash($udom, $uname, $namespace,
  &GDBM_WRCREAT(),"N",$what);   &GDBM_WRCREAT(),"N",$what);
     if(!$hashref) {      if(!$hashref) {
  &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".   &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
   "while attempting put\n", $userinput);    "while attempting put\n", $userinput);
  return 1;   return 1;
     }      }
Line 2417  sub newput_user_profile_entry { Line 2801  sub newput_user_profile_entry {
  $hashref->{$key}=$value;   $hashref->{$key}=$value;
     }      }
   
     if (untie(%$hashref)) {      if (&untie_user_hash($hashref)) {
  &Reply( $client, "ok\n", $userinput);   &Reply( $client, "ok\n", $userinput);
     } else {      } else {
  &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".   &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
Line 2470  sub increment_user_value_handler { Line 2854  sub increment_user_value_handler {
                     }                      }
                 }                  }
     }      }
     if (untie(%$hashref)) {      if (&untie_user_hash($hashref)) {
  &Reply( $client, "ok\n", $userinput);   &Reply( $client, "ok\n", $userinput);
     } else {      } else {
  &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".   &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
Line 2537  sub roles_put_handler { Line 2921  sub roles_put_handler {
        $auth_type);         $auth_type);
     $hashref->{$key}=$value;      $hashref->{$key}=$value;
  }   }
  if (untie($hashref)) {   if (&untie_user_hash($hashref)) {
     &Reply($client, "ok\n", $userinput);      &Reply($client, "ok\n", $userinput);
  } else {   } else {
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 2588  sub roles_delete_handler { Line 2972  sub roles_delete_handler {
  foreach my $key (@rolekeys) {   foreach my $key (@rolekeys) {
     delete $hashref->{$key};      delete $hashref->{$key};
  }   }
  if (untie(%$hashref)) {   if (&untie_user_hash($hashref)) {
     &Reply($client, "ok\n", $userinput);      &Reply($client, "ok\n", $userinput);
  } else {   } else {
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 2630  sub get_profile_entry { Line 3014  sub get_profile_entry {
     my ($udom,$uname,$namespace,$what) = split(/:/,$tail);      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
     chomp($what);      chomp($what);
   
   
     my $replystring = read_profile($udom, $uname, $namespace, $what);      my $replystring = read_profile($udom, $uname, $namespace, $what);
     my ($first) = split(/:/,$replystring);      my ($first) = split(/:/,$replystring);
     if($first ne "error") {      if($first ne "error") {
  &Reply($client, "$replystring\n", $userinput);   &Reply($client, \$replystring, $userinput);
     } else {      } else {
  &Failure($client, $replystring." while attempting get\n", $userinput);   &Failure($client, $replystring." while attempting get\n", $userinput);
     }      }
Line 2667  sub get_profile_entry_encrypted { Line 3052  sub get_profile_entry_encrypted {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
         
     my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
     chomp($what);      chomp($what);
     my $qresult = read_profile($udom, $uname, $namespace, $what);      my $qresult = read_profile($udom, $uname, $namespace, $what);
     my ($first) = split(/:/, $qresult);      my ($first) = split(/:/, $qresult);
Line 2729  sub delete_profile_entry { Line 3114  sub delete_profile_entry {
  foreach my $key (@keys) {   foreach my $key (@keys) {
     delete($hashref->{$key});      delete($hashref->{$key});
  }   }
  if (untie(%$hashref)) {   if (&untie_user_hash($hashref)) {
     &Reply($client, "ok\n", $userinput);      &Reply($client, "ok\n", $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 2771  sub get_profile_keys { Line 3156  sub get_profile_keys {
  foreach my $key (keys %$hashref) {   foreach my $key (keys %$hashref) {
     $qresult.="$key&";      $qresult.="$key&";
  }   }
  if (untie(%$hashref)) {   if (&untie_user_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, \$qresult, $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
     "while attempting keys\n", $userinput);      "while attempting keys\n", $userinput);
Line 2809  sub get_profile_keys { Line 3194  sub get_profile_keys {
 sub dump_profile_database {  sub dump_profile_database {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
       my $res = LONCAPA::Lond::dump_profile_database($tail);
   
       if ($res =~ /^error:/) {
           Failure($client, \$res, "$cmd:$tail");
       } else {
           Reply($client, \$res, "$cmd:$tail");
       }
   
       return 1;  
   
       #TODO remove 
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
         
     my ($udom,$uname,$namespace) = split(/:/,$tail);      my ($udom,$uname,$namespace) = split(/:/,$tail);
Line 2832  sub dump_profile_database { Line 3228  sub dump_profile_database {
     $data{$symb}->{$param}=$value;      $data{$symb}->{$param}=$value;
     $data{$symb}->{'v.'.$param}=$v;      $data{$symb}->{'v.'.$param}=$v;
  }   }
  if (untie(%$hashref)) {   if (&untie_user_hash($hashref)) {
     while (my ($symb,$param_hash) = each(%data)) {      while (my ($symb,$param_hash) = each(%data)) {
  while(my ($param,$value) = each (%$param_hash)){   while(my ($param,$value) = each (%$param_hash)){
     next if ($param =~ /^v\./);       # Ignore versions...      next if ($param =~ /^v\./);       # Ignore versions...
Line 2843  sub dump_profile_database { Line 3239  sub dump_profile_database {
  }   }
     }      }
     chop($qresult);      chop($qresult);
     &Reply($client , "$qresult\n", $userinput);      &Reply($client , \$qresult, $userinput);
  } else {   } else {
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
      "while attempting currentdump\n", $userinput);       "while attempting currentdump\n", $userinput);
Line 2875  sub dump_profile_database { Line 3271  sub dump_profile_database {
 #                                             that is matched against  #                                             that is matched against
 #                                             database keywords to do  #                                             database keywords to do
 #                                             selective dumps.  #                                             selective dumps.
   #                               range       - optional range of entries
   #                                             e.g., 10-20 would return the
   #                                             10th to 19th items, etc.  
 #   $client                   - Channel open on the client.  #   $client                   - Channel open on the client.
 # Returns:  # Returns:
 #    1    - Continue processing.  #    1    - Continue processing.
Line 2884  sub dump_profile_database { Line 3283  sub dump_profile_database {
 sub dump_with_regexp {  sub dump_with_regexp {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
       my $res = LONCAPA::Lond::dump_with_regexp($tail, $clientversion);
     my $userinput = "$cmd:$tail";      
       if ($res =~ /^error:/) {
     my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);          Failure($client, \$res, "$cmd:$tail");
     if (defined($regexp)) {  
  $regexp=&unescape($regexp);  
     } else {  
  $regexp='.';  
     }  
     my $hashref = &tie_user_hash($udom, $uname, $namespace,  
  &GDBM_READER());  
     if ($hashref) {  
         my $qresult='';  
  while (my ($key,$value) = each(%$hashref)) {  
     if ($regexp eq '.') {  
  $qresult.=$key.'='.$value.'&';  
     } else {  
  my $unescapeKey = &unescape($key);  
  if (eval('$unescapeKey=~/$regexp/')) {  
     $qresult.="$key=$value&";  
  }  
     }  
  }  
  if (untie(%$hashref)) {  
     chop($qresult);  
     &Reply($client, "$qresult\n", $userinput);  
  } else {  
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".  
      "while attempting dump\n", $userinput);  
  }  
     } else {      } else {
  &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".          Reply($client, \$res, "$cmd:$tail");
  "while attempting dump\n", $userinput);  
     }      }
   
     return 1;      return 1;
Line 2969  sub store_handler { Line 3341  sub store_handler {
     $hashref->{"$version:$rid:timestamp"}=$now;      $hashref->{"$version:$rid:timestamp"}=$now;
     $allkeys.='timestamp';      $allkeys.='timestamp';
     $hashref->{"$version:keys:$rid"}=$allkeys;      $hashref->{"$version:keys:$rid"}=$allkeys;
     if (untie($hashref)) {      if (&untie_user_hash($hashref)) {
  &Reply($client, "ok\n", $userinput);   &Reply($client, "ok\n", $userinput);
     } else {      } else {
  &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".   &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 2987  sub store_handler { Line 3359  sub store_handler {
 }  }
 &register_handler("store", \&store_handler, 0, 1, 0);  &register_handler("store", \&store_handler, 0, 1, 0);
   
   #  Modify a set of key=value pairs associated with a versioned name.
   #
   #  Parameters:
   #    $cmd                - Request command keyword.
   #    $tail               - Tail of the request.  This is a colon
   #                          separated list containing:
   #                          domain/user - User and authentication domain.
   #                          namespace   - Name of the database being modified
   #                          rid         - Resource keyword to modify.
   #                          v           - Version item to modify
   #                          what        - new value associated with rid.
   #
   #    $client             - Socket open on the client.
   #
   #
   #  Returns:
   #      1 (keep on processing).
   #  Side-Effects:
   #    Writes to the client
   sub putstore_handler {
       my ($cmd, $tail, $client) = @_;
    
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$rid,$v,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
   
    chomp($what);
    my $hashref  = &tie_user_hash($udom, $uname, $namespace,
          &GDBM_WRCREAT(), "M",
          "$rid:$v:$what");
    if ($hashref) {
       my $now = time;
       my %data = &hash_extract($what);
       my @allkeys;
       while (my($key,$value) = each(%data)) {
    push(@allkeys,$key);
    $hashref->{"$v:$rid:$key"} = $value;
       }
       my $allkeys = join(':',@allkeys);
       $hashref->{"$v:keys:$rid"}=$allkeys;
   
       if (&untie_user_hash($hashref)) {
    &Reply($client, "ok\n", $userinput);
       } else {
    &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
    "while attempting store\n", $userinput);
       }
    } else {
       &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
        "while attempting store\n", $userinput);
    }
       } else {
    &Failure($client, "refused\n", $userinput);
       }
   
       return 1;
   }
   &register_handler("putstore", \&putstore_handler, 0, 1, 0);
   
   sub hash_extract {
       my ($str)=@_;
       my %hash;
       foreach my $pair (split(/\&/,$str)) {
    my ($key,$value)=split(/=/,$pair);
    $hash{$key}=$value;
       }
       return (%hash);
   }
   sub hash_to_str {
       my ($hash_ref)=@_;
       my $str;
       foreach my $key (keys(%$hash_ref)) {
    $str.=$key.'='.$hash_ref->{$key}.'&';
       }
       $str=~s/\&$//;
       return $str;
   }
   
 #  #
 #  Dump out all versions of a resource that has key=value pairs associated  #  Dump out all versions of a resource that has key=value pairs associated
 # with it for each version.  These resources are built up via the store  # with it for each version.  These resources are built up via the store
Line 3016  sub restore_handler { Line 3467  sub restore_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
     my $userinput = "$cmd:$tail"; # Only used for logging purposes.      my $userinput = "$cmd:$tail"; # Only used for logging purposes.
       my ($udom,$uname,$namespace,$rid) = split(/:/,$tail);
     my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);  
     $namespace=~s/\//\_/g;      $namespace=~s/\//\_/g;
     $namespace=~s/\W//g;      $namespace = &LONCAPA::clean_username($namespace);
   
     chomp($rid);      chomp($rid);
     my $proname=&propath($udom,$uname);  
     my $qresult='';      my $qresult='';
     my %hash;      my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",      if ($hashref) {
     &GDBM_READER(),0640)) {   my $version=$hashref->{"version:$rid"};
  my $version=$hash{"version:$rid"};  
  $qresult.="version=$version&";   $qresult.="version=$version&";
  my $scope;   my $scope;
  for ($scope=1;$scope<=$version;$scope++) {   for ($scope=1;$scope<=$version;$scope++) {
     my $vkeys=$hash{"$scope:keys:$rid"};      my $vkeys=$hashref->{"$scope:keys:$rid"};
     my @keys=split(/:/,$vkeys);      my @keys=split(/:/,$vkeys);
     my $key;      my $key;
     $qresult.="$scope:keys=$vkeys&";      $qresult.="$scope:keys=$vkeys&";
     foreach $key (@keys) {      foreach $key (@keys) {
  $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";   $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
     }                                        }                                  
  }   }
  if (untie(%hash)) {   if (&untie_user_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply( $client, "$qresult\n", $userinput);      &Reply( $client, \$qresult, $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
     "while attempting restore\n", $userinput);      "while attempting restore\n", $userinput);
Line 3057  sub restore_handler { Line 3506  sub restore_handler {
 &register_handler("restore", \&restore_handler, 0,1,0);  &register_handler("restore", \&restore_handler, 0,1,0);
   
 #  #
 #   Add a chat message to to a discussion board.  #   Add a chat message to a synchronous discussion board.
 #  #
 # Parameters:  # Parameters:
 #    $cmd                - Request keyword.  #    $cmd                - Request keyword.
 #    $tail               - Tail of the command. A colon separated list  #    $tail               - Tail of the command. A colon separated list
 #                          containing:  #                          containing:
 #                          cdom    - Domain on which the chat board lives  #                          cdom    - Domain on which the chat board lives
 #                          cnum    - Identifier of the discussion group.  #                          cnum    - Course containing the chat board.
 #                          post    - Body of the posting.  #                          newpost - Body of the posting.
   #                          group   - Optional group, if chat board is only 
   #                                    accessible in a group within the course 
 #   $client              - Socket open on the client.  #   $client              - Socket open on the client.
 # Returns:  # Returns:
 #   1    - Indicating caller should keep on processing.  #   1    - Indicating caller should keep on processing.
Line 3080  sub send_chat_handler { Line 3531  sub send_chat_handler {
           
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($cdom,$cnum,$newpost)=split(/\:/,$tail);      my ($cdom,$cnum,$newpost,$group)=split(/\:/,$tail);
     &chat_add($cdom,$cnum,$newpost);      &chat_add($cdom,$cnum,$newpost,$group);
     &Reply($client, "ok\n", $userinput);      &Reply($client, "ok\n", $userinput);
   
     return 1;      return 1;
Line 3089  sub send_chat_handler { Line 3540  sub send_chat_handler {
 &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);  &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);
   
 #  #
 #   Retrieve the set of chat messagss from a discussion board.  #   Retrieve the set of chat messages from a discussion board.
 #  #
 #  Parameters:  #  Parameters:
 #    $cmd             - Command keyword that initiated the request.  #    $cmd             - Command keyword that initiated the request.
Line 3099  sub send_chat_handler { Line 3550  sub send_chat_handler {
 #                       chat id        - Discussion thread(?)  #                       chat id        - Discussion thread(?)
 #                       domain/user    - Authentication domain and username  #                       domain/user    - Authentication domain and username
 #                                        of the requesting person.  #                                        of the requesting person.
   #                       group          - Optional course group containing
   #                                        the board.      
 #   $client           - Socket open on the client program.  #   $client           - Socket open on the client program.
 # Returns:  # Returns:
 #    1     - continue processing  #    1     - continue processing
Line 3111  sub retrieve_chat_handler { Line 3564  sub retrieve_chat_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);      my ($cdom,$cnum,$udom,$uname,$group)=split(/\:/,$tail);
     my $reply='';      my $reply='';
     foreach (&get_chat($cdom,$cnum,$udom,$uname)) {      foreach (&get_chat($cdom,$cnum,$udom,$uname,$group)) {
  $reply.=&escape($_).':';   $reply.=&escape($_).':';
     }      }
     $reply=~s/\:$//;      $reply=~s/\:$//;
     &Reply($client, $reply."\n", $userinput);      &Reply($client, \$reply, $userinput);
   
   
     return 1;      return 1;
Line 3190  sub reply_query_handler { Line 3643  sub reply_query_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($cmd,$id,$reply)=split(/:/,$userinput);       my ($id,$reply)=split(/:/,$tail); 
     my $store;      my $store;
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     if ($store=IO::File->new(">$execdir/tmp/$id")) {      if ($store=IO::File->new(">$execdir/tmp/$id")) {
Line 3254  sub put_course_id_handler { Line 3707  sub put_course_id_handler {
  foreach my $pair (@pairs) {   foreach my $pair (@pairs) {
             my ($key,$courseinfo) = split(/=/,$pair,2);              my ($key,$courseinfo) = split(/=/,$pair,2);
             $courseinfo =~ s/=/:/g;              $courseinfo =~ s/=/:/g;
               if (defined($hashref->{$key})) {
             my @current_items = split(/:/,$hashref->{$key});                  my $value = &Apache::lonnet::thaw_unescape($hashref->{$key});
                   if (ref($value) eq 'HASH') {
                       my @items = ('description','inst_code','owner','type');
                       my @new_items = split(/:/,$courseinfo,-1);
                       my %storehash; 
                       for (my $i=0; $i<@new_items; $i++) {
                           $storehash{$items[$i]} = &unescape($new_items[$i]);
                       }
                       $hashref->{$key} = 
                           &Apache::lonnet::freeze_escape(\%storehash);
                       my $unesc_key = &unescape($key);
                       $hashref->{&escape('lasttime:'.$unesc_key)} = $now;
                       next;
                   }
               }
               my @current_items = split(/:/,$hashref->{$key},-1);
             shift(@current_items); # remove description              shift(@current_items); # remove description
             pop(@current_items);   # remove last access              pop(@current_items);   # remove last access
             my $numcurrent = scalar(@current_items);              my $numcurrent = scalar(@current_items);
               if ($numcurrent > 3) {
             my @new_items = split(/:/,$courseinfo);                  $numcurrent = 3;
               }
               my @new_items = split(/:/,$courseinfo,-1);
             my $numnew = scalar(@new_items);              my $numnew = scalar(@new_items);
             if ($numcurrent > 0) {              if ($numcurrent > 0) {
                 if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier                  if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 
                     $courseinfo .= ':'.join(':',@current_items);                      for (my $j=$numcurrent-$numnew; $j>=0; $j--) {
                 } elsif ($numnew == 2) { # flushcourselogs() from 1.2.X                          $courseinfo .= ':'.$current_items[$numcurrent-$j-1];
                     $courseinfo .= ':'.$current_items[$numcurrent-1];                      }
                 }                  }
             }              }
     $hashref->{$key}=$courseinfo.':'.$now;              $hashref->{$key}=$courseinfo.':'.$now;
  }   }
  if (untie(%$hashref)) {   if (&untie_domain_hash($hashref)) {
     &Reply( $client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)      &Failure($client, "error: ".($!+0)
Line 3283  sub put_course_id_handler { Line 3753  sub put_course_id_handler {
  ." tie(GDBM) Failed ".   ." tie(GDBM) Failed ".
  "while attempting courseidput\n", $userinput);   "while attempting courseidput\n", $userinput);
     }      }
       
   
     return 1;      return 1;
 }  }
 &register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);  &register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);
   
   sub put_course_id_hash_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($udom,$mode,$what) = split(/:/, $tail,3);
       chomp($what);
       my $now=time;
       my @pairs=split(/\&/,$what);
       my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
           foreach my $pair (@pairs) {
               my ($key,$value)=split(/=/,$pair);
               my $unesc_key = &unescape($key);
               if ($mode ne 'timeonly') {
                   if (!defined($hashref->{&escape('lasttime:'.$unesc_key)})) {
                       my $curritems = &Apache::lonnet::thaw_unescape($key); 
                       if (ref($curritems) ne 'HASH') {
                           my @current_items = split(/:/,$hashref->{$key},-1);
                           my $lasttime = pop(@current_items);
                           $hashref->{&escape('lasttime:'.$unesc_key)} = $lasttime;
                       } else {
                           $hashref->{&escape('lasttime:'.$unesc_key)} = '';
                       }
                   } 
                   $hashref->{$key} = $value;
               }
               if ($mode ne 'notime') {
                   $hashref->{&escape('lasttime:'.$unesc_key)} = $now;
               }
           }
           if (&untie_domain_hash($hashref)) {
               &Reply($client, "ok\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                        "while attempting courseidputhash\n", $userinput);
           }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                     "while attempting courseidputhash\n", $userinput);
       }
       return 1;
   }
   &register_handler("courseidputhash", \&put_course_id_hash_handler, 0, 1, 0);
   
 #  Retrieves the value of a course id resource keyword pattern  #  Retrieves the value of a course id resource keyword pattern
 #  defined since a starting date.  Both the starting date and the  #  defined since a starting date.  Both the starting date and the
 #  keyword pattern are optional.  If the starting date is not supplied it  #  keyword pattern are optional.  If the starting date is not supplied it
Line 3310  sub put_course_id_handler { Line 3822  sub put_course_id_handler {
 #                 institutional code - optional supplied code to filter   #                 institutional code - optional supplied code to filter 
 #                            the dump. Only courses with an institutional code   #                            the dump. Only courses with an institutional code 
 #                            that match the supplied code will be returned.  #                            that match the supplied code will be returned.
 #                 owner    - optional supplied username of owner to filter  #                 owner    - optional supplied username and domain of owner to
 #                            the dump.  Only courses for which the course   #                            filter the dump.  Only courses for which the course
 #                            owner matches the supplied username will be  #                            owner matches the supplied username and/or domain
 #                            returned. Implicit assumption that owner  #                            will be returned. Pre-2.2.0 legacy entries from 
 #                            is a user in the domain in which the  #                            nohist_courseiddump will only contain usernames.
 #                            course database is defined.  #                 type     - optional parameter for selection 
   #                 regexp_ok - if 1 or -1 allow the supplied institutional code
   #                            filter to behave as a regular expression:
   #                      1 will not exclude the course if the instcode matches the RE 
   #                            -1 will exclude the course if the instcode matches the RE
   #                 rtn_as_hash - whether to return the information available for
   #                            each matched item as a frozen hash of all 
   #                            key, value pairs in the item's hash, or as a 
   #                            colon-separated list of (in order) description,
   #                            institutional code, and course owner.
   #                 selfenrollonly - filter by courses allowing self-enrollment  
   #                                  now or in the future (selfenrollonly = 1).
   #                 catfilter - filter by course category, assigned to a course 
   #                             using manually defined categories (i.e., not
   #                             self-cataloging based on on institutional code).   
   #                 showhidden - include course in results even if course  
   #                              was set to be excluded from course catalog (DC only).
   #                 caller -  if set to 'coursecatalog', courses set to be hidden
   #                           from course catalog will be excluded from results (unless
   #                           overridden by "showhidden".
   #                 cloner - escaped username:domain of course cloner (if picking course to
   #                          clone).
   #                 cc_clone_list - escaped comma separated list of courses for which 
   #                                 course cloner has active CC role (and so can clone
   #                                 automatically).
   #                 cloneonly - filter by courses for which cloner has rights to clone.
   #                 createdbefore - include courses for which creation date preceeded this date.
   #                 createdafter - include courses for which creation date followed this date.
   #                 creationcontext - include courses created in specified context 
   #
   #                 domcloner - flag to indicate if user can create CCs in course's domain.
   #                             If so, ability to clone course is automatic. 
   #
 #     $client  - The socket open on the client.  #     $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1     - Continue processing.  #    1     - Continue processing.
Line 3324  sub put_course_id_handler { Line 3868  sub put_course_id_handler {
 sub dump_course_id_handler {  sub dump_course_id_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
       my $res = LONCAPA::Lond::dump_course_id_handler($tail);
       if ($res =~ /^error:/) {
           Failure($client, \$res, "$cmd:$tail");
       } else {
           Reply($client, \$res, "$cmd:$tail");
       }
   
       return 1;  
   
       #TODO remove
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail);      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
           $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
           $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
           $creationcontext,$domcloner) =split(/:/,$tail);
       my $now = time;
       my ($cloneruname,$clonerudom,%cc_clone);
     if (defined($description)) {      if (defined($description)) {
  $description=&unescape($description);   $description=&unescape($description);
     } else {      } else {
Line 3337  sub dump_course_id_handler { Line 3896  sub dump_course_id_handler {
     } else {      } else {
         $instcodefilter='.';          $instcodefilter='.';
     }      }
       my ($ownerunamefilter,$ownerdomfilter);
     if (defined($ownerfilter)) {      if (defined($ownerfilter)) {
         $ownerfilter=&unescape($ownerfilter);          $ownerfilter=&unescape($ownerfilter);
           if ($ownerfilter ne '.' && defined($ownerfilter)) {
               if ($ownerfilter =~ /^([^:]*):([^:]*)$/) {
                    $ownerunamefilter = $1;
                    $ownerdomfilter = $2;
               } else {
                   $ownerunamefilter = $ownerfilter;
                   $ownerdomfilter = '';
               }
           }
     } else {      } else {
         $ownerfilter='.';          $ownerfilter='.';
     }      }
   
     if (defined($coursefilter)) {      if (defined($coursefilter)) {
         $coursefilter=&unescape($coursefilter);          $coursefilter=&unescape($coursefilter);
     } else {      } else {
         $coursefilter='.';          $coursefilter='.';
     }      }
       if (defined($typefilter)) {
     unless (defined($since)) { $since=0; }          $typefilter=&unescape($typefilter);
       } else {
           $typefilter='.';
       }
       if (defined($regexp_ok)) {
           $regexp_ok=&unescape($regexp_ok);
       }
       if (defined($catfilter)) {
           $catfilter=&unescape($catfilter);
       }
       if (defined($cloner)) {
           $cloner = &unescape($cloner);
           ($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/); 
       }
       if (defined($cc_clone_list)) {
           $cc_clone_list = &unescape($cc_clone_list);
           my @cc_cloners = split('&',$cc_clone_list);
           foreach my $cid (@cc_cloners) {
               my ($clonedom,$clonenum) = split(':',$cid);
               next if ($clonedom ne $udom); 
               $cc_clone{$clonedom.'_'.$clonenum} = 1;
           } 
       }
       if ($createdbefore ne '') {
           $createdbefore = &unescape($createdbefore);
       } else {
          $createdbefore = 0;
       }
       if ($createdafter ne '') {
           $createdafter = &unescape($createdafter);
       } else {
           $createdafter = 0;
       }
       if ($creationcontext ne '') {
           $creationcontext = &unescape($creationcontext);
       } else {
           $creationcontext = '.';
       }
       my $unpack = 1;
       if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' && 
           $typefilter eq '.') {
           $unpack = 0;
       }
       if (!defined($since)) { $since=0; }
     my $qresult='';      my $qresult='';
     my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
     my ($descr,$lasttime,$inst_code,$owner);              my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
             my @courseitems = split(/:/,$value);                  %unesc_val,$selfenroll_end,$selfenroll_types,$created,
             $lasttime = pop(@courseitems);                  $context);
     ($descr,$inst_code,$owner)=@courseitems;              $unesc_key = &unescape($key);
     if ($lasttime<$since) { next; }              if ($unesc_key =~ /^lasttime:/) {
                   next;
               } else {
                   $lasttime_key = &escape('lasttime:'.$unesc_key);
               }
               if ($hashref->{$lasttime_key} ne '') {
                   $lasttime = $hashref->{$lasttime_key};
                   next if ($lasttime<$since);
               }
               my ($canclone,$valchange);
               my $items = &Apache::lonnet::thaw_unescape($value);
               if (ref($items) eq 'HASH') {
                   if ($hashref->{$lasttime_key} eq '') {
                       next if ($since > 1);
                   }
                   $is_hash =  1;
                   if ($domcloner) {
                       $canclone = 1;
                   } elsif (defined($clonerudom)) {
                       if ($items->{'cloners'}) {
                           my @cloneable = split(',',$items->{'cloners'});
                           if (@cloneable) {
                               if (grep(/^\*$/,@cloneable))  {
                                   $canclone = 1;
                               } elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) {
                                   $canclone = 1;
                               } elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) {
                                   $canclone = 1;
                               }
                           }
                           unless ($canclone) {
                               if ($cloneruname ne '' && $clonerudom ne '') {
                                   if ($cc_clone{$unesc_key}) {
                                       $canclone = 1;
                                       $items->{'cloners'} .= ','.$cloneruname.':'.
                                                              $clonerudom;
                                       $valchange = 1;
                                   }
                               }
                           }
                       } elsif (defined($cloneruname)) {
                           if ($cc_clone{$unesc_key}) {
                               $canclone = 1;
                               $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                               $valchange = 1;
                           }
                           unless ($canclone) {
                               if ($items->{'owner'} =~ /:/) {
                                   if ($items->{'owner'} eq $cloner) {
                                       $canclone = 1;
                                   }
                               } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
                                   $canclone = 1;
                               }
                               if ($canclone) {
                                   $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                                   $valchange = 1;
                               }
                           }
                       }
                   }
                   if ($unpack || !$rtn_as_hash) {
                       $unesc_val{'descr'} = $items->{'description'};
                       $unesc_val{'inst_code'} = $items->{'inst_code'};
                       $unesc_val{'owner'} = $items->{'owner'};
                       $unesc_val{'type'} = $items->{'type'};
                       $unesc_val{'cloners'} = $items->{'cloners'};
                       $unesc_val{'created'} = $items->{'created'};
                       $unesc_val{'context'} = $items->{'context'};
                   }
                   $selfenroll_types = $items->{'selfenroll_types'};
                   $selfenroll_end = $items->{'selfenroll_end_date'};
                   $created = $items->{'created'};
                   $context = $items->{'context'};
                   if ($selfenrollonly) {
                       next if (!$selfenroll_types);
                       if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
                           next;
                       }
                   }
                   if ($creationcontext ne '.') {
                       next if (($context ne '') && ($context ne $creationcontext));  
                   }
                   if ($createdbefore > 0) {
                       next if (($created eq '') || ($created > $createdbefore));   
                   }
                   if ($createdafter > 0) {
                       next if (($created eq '') || ($created <= $createdafter)); 
                   }
                   if ($catfilter ne '') {
                       next if ($items->{'categories'} eq '');
                       my @categories = split('&',$items->{'categories'}); 
                       next if (@categories == 0);
                       my @subcats = split('&',$catfilter);
                       my $matchcat = 0;
                       foreach my $cat (@categories) {
                           if (grep(/^\Q$cat\E$/,@subcats)) {
                               $matchcat = 1;
                               last;
                           }
                       }
                       next if (!$matchcat);
                   }
                   if ($caller eq 'coursecatalog') {
                       if ($items->{'hidefromcat'} eq 'yes') {
                           next if !$showhidden;
                       }
                   }
               } else {
                   next if ($catfilter ne '');
                   next if ($selfenrollonly);
                   next if ($createdbefore || $createdafter);
                   next if ($creationcontext ne '.');
                   if ((defined($clonerudom)) && (defined($cloneruname)))  {
                       if ($cc_clone{$unesc_key}) {
                           $canclone = 1;
                           $val{'cloners'} = &escape($cloneruname.':'.$clonerudom);
                       }
                   }
                   $is_hash =  0;
                   my @courseitems = split(/:/,$value);
                   $lasttime = pop(@courseitems);
                   if ($hashref->{$lasttime_key} eq '') {
                       next if ($lasttime<$since);
                   }
           ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
               }
               if ($cloneonly) {
                  next unless ($canclone);
               }
             my $match = 1;              my $match = 1;
     unless ($description eq '.') {      if ($description ne '.') {
  my $unescapeDescr = &unescape($descr);                  if (!$is_hash) {
  unless (eval('$unescapeDescr=~/\Q$description\E/i')) {                      $unesc_val{'descr'} = &unescape($val{'descr'});
                   }
                   if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
                     $match = 0;                      $match = 0;
  }                  }
             }              }
             unless ($instcodefilter eq '.' || !defined($instcodefilter)) {              if ($instcodefilter ne '.') {
                 my $unescapeInstcode = &unescape($inst_code);                  if (!$is_hash) {
                 unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {                      $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
                     $match = 0;                  }
                   if ($regexp_ok == 1) {
                       if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
                           $match = 0;
                       }
                   } elsif ($regexp_ok == -1) {
                       if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) {
                           $match = 0;
                       }
                   } else {
                       if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
                           $match = 0;
                       }
                 }                  }
     }      }
             unless ($ownerfilter eq '.' || !defined($ownerfilter)) {              if ($ownerfilter ne '.') {
                 my $unescapeOwner = &unescape($owner);                  if (!$is_hash) {
                 unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) {                      $unesc_val{'owner'} = &unescape($val{'owner'});
                     $match = 0;                  }
                   if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
                       if ($unesc_val{'owner'} =~ /:/) {
                           if (eval{$unesc_val{'owner'} !~ 
                                /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
                               $match = 0;
                           } 
                       } else {
                           if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                               $match = 0;
                           }
                       }
                   } elsif ($ownerunamefilter ne '') {
                       if ($unesc_val{'owner'} =~ /:/) {
                           if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
                                $match = 0;
                           }
                       } else {
                           if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                               $match = 0;
                           }
                       }
                   } elsif ($ownerdomfilter ne '') {
                       if ($unesc_val{'owner'} =~ /:/) {
                           if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
                                $match = 0;
                           }
                       } else {
                           if ($ownerdomfilter ne $udom) {
                               $match = 0;
                           }
                       }
                 }                  }
             }              }
             unless ($coursefilter eq '.' || !defined($coursefilter)) {              if ($coursefilter ne '.') {
                 my $unescapeCourse = &unescape($key);                  if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
                 unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) {  
                     $match = 0;                      $match = 0;
                 }                  }
             }              }
               if ($typefilter ne '.') {
                   if (!$is_hash) {
                       $unesc_val{'type'} = &unescape($val{'type'});
                   }
                   if ($unesc_val{'type'} eq '') {
                       if ($typefilter ne 'Course') {
                           $match = 0;
                       }
                   } else {
                       if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
                           $match = 0;
                       }
                   }
               }
             if ($match == 1) {              if ($match == 1) {
                 $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';                  if ($rtn_as_hash) {
                       if ($is_hash) {
                           if ($valchange) {
                               my $newvalue = &Apache::lonnet::freeze_escape($items);
                               $qresult.=$key.'='.$newvalue.'&';
                           } else {
                               $qresult.=$key.'='.$value.'&';
                           }
                       } else {
                           my %rtnhash = ( 'description' => &unescape($val{'descr'}),
                                           'inst_code' => &unescape($val{'inst_code'}),
                                           'owner'     => &unescape($val{'owner'}),
                                           'type'      => &unescape($val{'type'}),
                                           'cloners'   => &unescape($val{'cloners'}),
                                         );
                           my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
                           $qresult.=$key.'='.$items.'&';
                       }
                   } else {
                       if ($is_hash) {
                           $qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
                                       &escape($unesc_val{'inst_code'}).':'.
                                       &escape($unesc_val{'owner'}).'&';
                       } else {
                           $qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
                                       ':'.$val{'owner'}.'&';
                       }
                   }
             }              }
  }   }
  if (untie(%$hashref)) {   if (&untie_domain_hash($hashref)) {
     chop($qresult);      chop($qresult);
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, \$qresult, $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
     "while attempting courseiddump\n", $userinput);      "while attempting courseiddump\n", $userinput);
Line 3398  sub dump_course_id_handler { Line 4225  sub dump_course_id_handler {
  &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  "while attempting courseiddump\n", $userinput);   "while attempting courseiddump\n", $userinput);
     }      }
       return 1;
   }
   &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
   
   sub course_lastaccess_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($cdom,$cnum) = split(':',$tail); 
       my (%lastaccess,$qresult);
       my $hashref = &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
           while (my ($key,$value) = each(%$hashref)) {
               my ($unesc_key,$lasttime);
               $unesc_key = &unescape($key);
               if ($cnum) {
                   next unless ($unesc_key =~ /\Q$cdom\E_\Q$cnum\E$/);
               }
               if ($unesc_key =~ /^lasttime:($LONCAPA::match_domain\_$LONCAPA::match_courseid)/) {
                   $lastaccess{$1} = $value;
               } else {
                   my $items = &Apache::lonnet::thaw_unescape($value);
                   if (ref($items) eq 'HASH') {
                       unless ($lastaccess{$unesc_key}) {
                           $lastaccess{$unesc_key} = '';
                       }
                   } else {
                       my @courseitems = split(':',$value);
                       $lastaccess{$unesc_key} = pop(@courseitems);
                   }
               }
           }
           foreach my $cid (sort(keys(%lastaccess))) {
               $qresult.=&escape($cid).'='.$lastaccess{$cid}.'&'; 
           }
           if (&untie_domain_hash($hashref)) {
               if ($qresult) {
                   chop($qresult);
               }
               &Reply($client, \$qresult, $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting lastacourseaccess\n", $userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                   "while attempting lastcourseaccess\n", $userinput);
       }
       return 1;
   }
   &register_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0);
   
   #
   # Puts an unencrypted entry in a namespace db file at the domain level 
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #  Side effects:
   #     reply is written to $client.
   #
   sub put_domain_handler {
       my ($cmd,$tail,$client) = @_;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$namespace,$what) =split(/:/,$tail,3);
       chomp($what);
       my @pairs=split(/\&/,$what);
       my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(),
                                      "P", $what);
       if ($hashref) {
           foreach my $pair (@pairs) {
               my ($key,$value)=split(/=/,$pair);
               $hashref->{$key}=$value;
           }
           if (&untie_domain_hash($hashref)) {
               &Reply($client, "ok\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                        "while attempting putdom\n", $userinput);
           }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                     "while attempting putdom\n", $userinput);
       }
   
     return 1;      return 1;
 }  }
 &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);  &register_handler("putdom", \&put_domain_handler, 0, 1, 0);
   
   # Unencrypted get from the namespace database file at the domain level.
   # This function retrieves a keyed item from a specific named database in the
   # domain directory.
   #
   # Parameters:
   #   $cmd             - Command request keyword (get).
   #   $tail            - Tail of the command.  This is a colon separated list
   #                      consisting of the domain and the 'namespace' 
   #                      which selects the gdbm file to do the lookup in,
   #                      & separated list of keys to lookup.  Note that
   #                      the values are returned as an & separated list too.
   #   $client          - File descriptor open on the client.
   # Returns:
   #   1       - Continue processing.
   #   0       - Exit.
   #  Side effects:
   #     reply is written to $client.
   #
   
   sub get_domain_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput = "$client:$tail";
   
       my ($udom,$namespace,$what)=split(/:/,$tail,3);
       chomp($what);
       my @queries=split(/\&/,$what);
       my $qresult='';
       my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER());
       if ($hashref) {
           for (my $i=0;$i<=$#queries;$i++) {
               $qresult.="$hashref->{$queries[$i]}&";
           }
           if (&untie_domain_hash($hashref)) {
               $qresult=~s/\&$//;
               &Reply($client, \$qresult, $userinput);
           } else {
               &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
                         "while attempting getdom\n",$userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                    "while attempting getdom\n",$userinput);
       }
   
       return 1;
   }
   &register_handler("getdom", \&get_domain_handler, 0, 1, 0);
   
 #  #
 #  Puts an id to a domains id database.   #  Puts an id to a domains id database. 
Line 3436  sub put_id_handler { Line 4401  sub put_id_handler {
     my ($key,$value)=split(/=/,$pair);      my ($key,$value)=split(/=/,$pair);
     $hashref->{$key}=$value;      $hashref->{$key}=$value;
  }   }
  if (untie(%$hashref)) {   if (&untie_domain_hash($hashref)) {
     &Reply($client, "ok\n", $userinput);      &Reply($client, "ok\n", $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
Line 3485  sub get_id_handler { Line 4450  sub get_id_handler {
  for (my $i=0;$i<=$#queries;$i++) {   for (my $i=0;$i<=$#queries;$i++) {
     $qresult.="$hashref->{$queries[$i]}&";      $qresult.="$hashref->{$queries[$i]}&";
  }   }
  if (untie(%$hashref)) {   if (&untie_domain_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, \$qresult, $userinput);
  } else {   } else {
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting idget\n",$userinput);        "while attempting idget\n",$userinput);
Line 3501  sub get_id_handler { Line 4466  sub get_id_handler {
 }  }
 &register_handler("idget", \&get_id_handler, 0, 1, 0);  &register_handler("idget", \&get_id_handler, 0, 1, 0);
   
   #   Deletes one or more ids in a domain's id database.
   #
   #   Parameters:
   #       $cmd                  - Command keyword (iddel).
   #       $tail                 - Command tail.  In this case a colon
   #                               separated list containing:
   #                               The domain for which we are deleting the id(s).
   #                               &-separated list of id(s) to delete.
   #       $client               - File open on client socket.
   # Returns:
   #     1   - Continue processing
   #     0   - Exit server.
   #     
   #
   
   sub del_id_handler {
       my ($cmd,$tail,$client) = @_;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(),
                                      "D", $what);
       if ($hashref) {
           my @keys=split(/\&/,$what);
           foreach my $key (@keys) {
               delete($hashref->{$key});
           }
           if (&untie_user_hash($hashref)) {
               &Reply($client, "ok\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting iddel\n", $userinput);
           }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                    "while attempting iddel\n", $userinput);
       }
       return 1;
   }
   &register_handler("iddel", \&del_id_handler, 0, 1, 0);
   
   #
   # Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database 
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose dcmail we are recording
   #               email    Consists of key=value pair 
   #                        where key is unique msgid
   #                        and value is message (in XML)
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply is written to $client.
   #
   sub put_dcmail_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
   
   
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
       if ($hashref) {
           my ($key,$value)=split(/=/,$what);
           $hashref->{$key}=$value;
       }
       if (&untie_domain_hash($hashref)) {
           &Reply($client, "ok\n", $userinput);
       } else {
           &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                    "while attempting dcmailput\n", $userinput);
       }
       return 1;
   }
   &register_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0);
   
   #
   # Retrieves broadcast e-mail from nohist_dcmail database
   # Returns to client an & separated list of key=value pairs,
   # where key is msgid and value is message information.
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose dcmail table we dump
   #               startfilter - beginning of time window 
   #               endfilter - end of time window
   #               sendersfilter - & separated list of username:domain 
   #                 for senders to search for.
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply (& separated list of msgid=messageinfo pairs) is 
   #     written to $client.
   #
   sub dump_dcmail_handler {
       my ($cmd, $tail, $client) = @_;
                                                                                   
       my $userinput = "$cmd:$tail";
       my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail);
       chomp($sendersfilter);
       my @senders = ();
       if (defined($startfilter)) {
           $startfilter=&unescape($startfilter);
       } else {
           $startfilter='.';
       }
       if (defined($endfilter)) {
           $endfilter=&unescape($endfilter);
       } else {
           $endfilter='.';
       }
       if (defined($sendersfilter)) {
           $sendersfilter=&unescape($sendersfilter);
    @senders = map { &unescape($_) } split(/\&/,$sendersfilter);
       }
   
       my $qresult='';
       my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
       if ($hashref) {
           while (my ($key,$value) = each(%$hashref)) {
               my $match = 1;
               my ($timestamp,$subj,$uname,$udom) = 
    split(/:/,&unescape(&unescape($key)),5); # yes, twice really
               $subj = &unescape($subj);
               unless ($startfilter eq '.' || !defined($startfilter)) {
                   if ($timestamp < $startfilter) {
                       $match = 0;
                   }
               }
               unless ($endfilter eq '.' || !defined($endfilter)) {
                   if ($timestamp > $endfilter) {
                       $match = 0;
                   }
               }
               unless (@senders < 1) {
                   unless (grep/^$uname:$udom$/,@senders) {
                       $match = 0;
                   }
               }
               if ($match == 1) {
                   $qresult.=$key.'='.$value.'&';
               }
           }
           if (&untie_domain_hash($hashref)) {
               chop($qresult);
               &Reply($client, \$qresult, $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting dcmaildump\n", $userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                   "while attempting dcmaildump\n", $userinput);
       }
       return 1;
   }
   
   &register_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0);
   
   #
   # Puts domain roles in nohist_domainroles database
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose roles we are recording  
   #               role -   Consists of key=value pair
   #                        where key is unique role
   #                        and value is start/end date information
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply is written to $client.
   #
   
   sub put_domainroles_handler {
       my ($cmd,$tail,$client) = @_;
   
       my $userinput = "$cmd:$tail";
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my @pairs=split(/\&/,$what);
       my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
       if ($hashref) {
           foreach my $pair (@pairs) {
               my ($key,$value)=split(/=/,$pair);
               $hashref->{$key}=$value;
           }
           if (&untie_domain_hash($hashref)) {
               &Reply($client, "ok\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                        "while attempting domroleput\n", $userinput);
           }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                     "while attempting domroleput\n", $userinput);
       }
                                                                                     
       return 1;
   }
   
   &register_handler("domroleput", \&put_domainroles_handler, 0, 1, 0);
   
   #
   # Retrieves domain roles from nohist_domainroles database
   # Returns to client an & separated list of key=value pairs,
   # where key is role and value is start and end date information.
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose domain roles table we dump
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply (& separated list of role=start/end info pairs) is
   #     written to $client.
 #  #
   sub dump_domainroles_handler {
       my ($cmd, $tail, $client) = @_;
                                                                                              
       my $userinput = "$cmd:$tail";
       my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail);
       chomp($rolesfilter);
       my @roles = ();
       if (defined($startfilter)) {
           $startfilter=&unescape($startfilter);
       } else {
           $startfilter='.';
       }
       if (defined($endfilter)) {
           $endfilter=&unescape($endfilter);
       } else {
           $endfilter='.';
       }
       if (defined($rolesfilter)) {
           $rolesfilter=&unescape($rolesfilter);
    @roles = split(/\&/,$rolesfilter);
       }
   
       my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
       if ($hashref) {
           my $qresult = '';
           while (my ($key,$value) = each(%$hashref)) {
               my $match = 1;
               my ($end,$start) = split(/:/,&unescape($value));
               my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
               unless (@roles < 1) {
                   unless (grep/^\Q$trole\E$/,@roles) {
                       $match = 0;
                       next;
                   }
               }
               unless ($startfilter eq '.' || !defined($startfilter)) {
                   if ((defined($start)) && ($start >= $startfilter)) {
                       $match = 0;
                       next;
                   }
               }
               unless ($endfilter eq '.' || !defined($endfilter)) {
                   if ((defined($end)) && (($end > 0) && ($end <= $endfilter))) {
                       $match = 0;
                       next;
                   }
               }
               if ($match == 1) {
                   $qresult.=$key.'='.$value.'&';
               }
           }
           if (&untie_domain_hash($hashref)) {
               chop($qresult);
               &Reply($client, \$qresult, $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting domrolesdump\n", $userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                   "while attempting domrolesdump\n", $userinput);
       }
       return 1;
   }
   
   &register_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0);
   
   
 #  Process the tmpput command I'm not sure what this does.. Seems to  #  Process the tmpput command I'm not sure what this does.. Seems to
 #  create a file in the lonDaemons/tmp directory of the form $id.tmp  #  create a file in the lonDaemons/tmp directory of the form $id.tmp
 # where Id is the client's ip concatenated with a sequence number.  # where Id is the client's ip concatenated with a sequence number.
Line 3523  sub tmp_put_handler { Line 4787  sub tmp_put_handler {
   
     my $userinput = "$cmd:$what"; # Reconstruct for logging.      my $userinput = "$cmd:$what"; # Reconstruct for logging.
   
       my ($record,$context) = split(/:/,$what);
     my $store;      if ($context ne '') {
           chomp($context);
           $context = &unescape($context);
       }
       my ($id,$store);
     $tmpsnum++;      $tmpsnum++;
     my $id=$$.'_'.$clientip.'_'.$tmpsnum;      if (($context eq 'resetpw') || ($context eq 'createaccount')) {
           $id = &md5_hex(&md5_hex(time.{}.rand().$$));
       } else {
           $id = $$.'_'.$clientip.'_'.$tmpsnum;
       }
     $id=~s/\W/\_/g;      $id=~s/\W/\_/g;
     $what=~s/\n//g;      $record=~s/\n//g;
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {      if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
  print $store $what;   print $store $record;
  close $store;   close $store;
  &Reply($client, "$id\n", $userinput);   &Reply($client, \$id, $userinput);
     } else {      } else {
  &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".   &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
   "while attempting tmpput\n", $userinput);    "while attempting tmpput\n", $userinput);
Line 3567  sub tmp_get_handler { Line 4839  sub tmp_get_handler {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {      if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
  my $reply=<$store>;   my $reply=<$store>;
  &Reply( $client, "$reply\n", $userinput);   &Reply( $client, \$reply, $userinput);
  close $store;   close $store;
     } else {      } else {
  &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".   &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
Line 3748  sub enrollment_enabled_handler { Line 5020  sub enrollment_enabled_handler {
     my $userinput = $cmd.":".$tail; # For logging purposes.      my $userinput = $cmd.":".$tail; # For logging purposes.
   
           
     my $cdom = split(/:/, $tail);   # Domain we're asking about.      my ($cdom) = split(/:/, $tail, 2);   # Domain we're asking about.
   
     my $outcome  = &localenroll::run($cdom);      my $outcome  = &localenroll::run($cdom);
     &Reply($client, "$outcome\n", $userinput);      &Reply($client, \$outcome, $userinput);
   
     return 1;      return 1;
 }  }
 &register_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);  &register_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);
   
   #
   #   Validate an institutional code used for a LON-CAPA course.          
   #
   # Formal Parameters:
   #   $cmd          - The command request that got us dispatched.
   #   $tail         - The tail of the command.  In this case,
   #                   this is a colon separated set of words that will be split
   #                   into:
   #                        $dom      - The domain for which the check of 
   #                                    institutional course code will occur.
   #
   #                        $instcode - The institutional code for the course
   #                                    being requested, or validated for rights
   #                                    to request.
   #
   #                        $owner    - The course requestor (who will be the
   #                                    course owner, in the form username:domain
   #
   #   $client       - Socket open on the client.
   # Returns:
   #    1           - Indicating processing should continue.
   #
   sub validate_instcode_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($dom,$instcode,$owner) = split(/:/, $tail);
       $instcode = &unescape($instcode);
       $owner = &unescape($owner);
       my ($outcome,$description,$credits) = 
           &localenroll::validate_instcode($dom,$instcode,$owner);
       my $result = &escape($outcome).'&'.&escape($description).'&'.
                    &escape($credits);
       &Reply($client, \$result, $userinput);
   
       return 1;
   }
   &register_handler("autovalidateinstcode", \&validate_instcode_handler, 0, 1, 0);
   
 #   Get the official sections for which auto-enrollment is possible.  #   Get the official sections for which auto-enrollment is possible.
 #   Since the admin people won't know about 'unofficial sections'   #   Since the admin people won't know about 'unofficial sections' 
 #   we cannot auto-enroll on them.  #   we cannot auto-enroll on them.
Line 3777  sub get_sections_handler { Line 5088  sub get_sections_handler {
     my @secs = &localenroll::get_sections($coursecode,$cdom);      my @secs = &localenroll::get_sections($coursecode,$cdom);
     my $seclist = &escape(join(':',@secs));      my $seclist = &escape(join(':',@secs));
   
     &Reply($client, "$seclist\n", $userinput);      &Reply($client, \$seclist, $userinput);
           
   
     return 1;      return 1;
Line 3802  sub get_sections_handler { Line 5113  sub get_sections_handler {
 sub validate_course_owner_handler {  sub validate_course_owner_handler {
     my ($cmd, $tail, $client)  = @_;      my ($cmd, $tail, $client)  = @_;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
     my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);      my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail);
       
     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);      $owner = &unescape($owner);
     &Reply($client, "$outcome\n", $userinput);      $coowners = &unescape($coowners);
       my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);
       &Reply($client, \$outcome, $userinput);
   
   
   
Line 3836  sub validate_course_section_handler { Line 5149  sub validate_course_section_handler {
     my ($inst_course_id, $cdom) = split(/:/, $tail);      my ($inst_course_id, $cdom) = split(/:/, $tail);
   
     my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);      my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
     &Reply($client, "$outcome\n", $userinput);      &Reply($client, \$outcome, $userinput);
   
   
     return 1;      return 1;
Line 3844  sub validate_course_section_handler { Line 5157  sub validate_course_section_handler {
 &register_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);  &register_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);
   
 #  #
 #   Create a password for a new auto-enrollment user.  #   Validate course owner's access to enrollment data for specific class section. 
 #   I think/guess, this password allows access to the institutions   #   
 #   AIS class list server/services.  Stuart can correct this comment  
 #   when he finds out how wrong I am.  
 #  #
 # Formal Parameters:  # Formal Parameters:
 #    $cmd     - The command request that got us dispatched.  #    $cmd     - The command request that got us dispatched.
 #    $tail    - The tail of the command.   In this case this is a colon separated  #    $tail    - The tail of the command.   In this case this is a colon separated
 #               set of words that will be split into:  #               set of words that will be split into:
 #               $authparam - An authentication parameter (username??).  #               $inst_class  - Institutional code for the specific class section   
   #               $courseowner - The escaped username:domain of the course owner 
   #               $cdom        - The domain of the course from the institution's
   #                              point of view.
   #    $client  - The socket open on the client.
   # Returns:
   #    1 - continue processing.
   #
   
   sub validate_class_access_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($inst_class,$ownerlist,$cdom) = split(/:/, $tail);
       my $owners = &unescape($ownerlist);
       my $outcome;
       eval {
    local($SIG{__DIE__})='DEFAULT';
    $outcome=&localenroll::check_section($inst_class,$owners,$cdom);
       };
       &Reply($client,\$outcome, $userinput);
   
       return 1;
   }
   &register_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0);
   
   #
   #   Create a password for a new LON-CAPA user added by auto-enrollment.
   #   Only used for case where authentication method for new user is localauth
   #
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched.
   #    $tail    - The tail of the command.   In this case this is a colon separated
   #               set of words that will be split into:
   #               $authparam - An authentication parameter (localauth parameter).
 #               $cdom      - The domain of the course from the institution's  #               $cdom      - The domain of the course from the institution's
 #                            point of view.  #                            point of view.
 #    $client  - The socket open on the client.  #    $client  - The socket open on the client.
Line 3927  sub retrieve_auto_file_handler { Line 5271  sub retrieve_auto_file_handler {
 }  }
 &register_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);  &register_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);
   
   sub crsreq_checks_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my $dom = $tail;
       my $result;
       my @reqtypes = ('official','unofficial','community');
       eval {
           local($SIG{__DIE__})='DEFAULT';
           my %validations;
           my $response = &localenroll::crsreq_checks($dom,\@reqtypes,
                                                      \%validations);
           if ($response eq 'ok') { 
               foreach my $key (keys(%validations)) {
                   $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&';
               }
               $result =~ s/\&$//;
           } else {
               $result = 'error';
           }
       };
       if (!$@) {
           &Reply($client, \$result, $userinput);
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autocrsreqchecks", \&crsreq_checks_handler, 0, 1, 0);
   
   sub validate_crsreq_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = split(/:/, $tail);
       $instcode = &unescape($instcode);
       $owner = &unescape($owner);
       $crstype = &unescape($crstype);
       $inststatuslist = &unescape($inststatuslist);
       $instcode = &unescape($instcode);
       $instseclist = &unescape($instseclist);
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::validate_crsreq($dom,$owner,$crstype,
                                                    $inststatuslist,$instcode,
                                                    $instseclist);
       };
       if (!$@) {
           &Reply($client, \$outcome, $userinput);
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0);
   
 #  #
 #   Read and retrieve institutional code format (for support form).  #   Read and retrieve institutional code format (for support form).
 # Formal Parameters:  # Formal Parameters:
Line 3960  sub get_institutional_code_format_handle Line 5359  sub get_institutional_code_format_handle
     \%cat_titles,      \%cat_titles,
     \%cat_order);      \%cat_order);
     if ($formatreply eq 'ok') {      if ($formatreply eq 'ok') {
  my $codes_str = &hash2str(%codes);   my $codes_str = &Apache::lonnet::hash2str(%codes);
  my $codetitles_str = &array2str(@codetitles);   my $codetitles_str = &Apache::lonnet::array2str(@codetitles);
  my $cat_titles_str = &hash2str(%cat_titles);   my $cat_titles_str = &Apache::lonnet::hash2str(%cat_titles);
  my $cat_order_str = &hash2str(%cat_order);   my $cat_order_str = &Apache::lonnet::hash2str(%cat_order);
  &Reply($client,   &Reply($client,
        $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'         $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
        .$cat_order_str."\n",         .$cat_order_str."\n",
Line 3980  sub get_institutional_code_format_handle Line 5379  sub get_institutional_code_format_handle
 &register_handler("autoinstcodeformat",  &register_handler("autoinstcodeformat",
   \&get_institutional_code_format_handler,0,1,0);    \&get_institutional_code_format_handler,0,1,0);
   
   sub get_institutional_defaults_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
   
       my $dom = $tail;
       my %defaults_hash;
       my @code_order;
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::instcode_defaults($dom,\%defaults_hash,
                                                      \@code_order);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result='';
               while (my ($key,$value) = each(%defaults_hash)) {
                   $result.=&escape($key).'='.&escape($value).'&';
               }
               $result .= 'code_order='.&escape(join('&',@code_order));
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("autoinstcodedefaults",
                     \&get_institutional_defaults_handler,0,1,0);
   
   sub get_possible_instcodes_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
   
       my $reply;
       my $cdom = $tail;
       my (@codetitles,%cat_titles,%cat_order,@code_order);
       my $formatreply = &localenroll::possible_instcodes($cdom,
                                                          \@codetitles,
                                                          \%cat_titles,
                                                          \%cat_order,
                                                          \@code_order);
       if ($formatreply eq 'ok') {
           my $result = join('&',map {&escape($_);} (@codetitles)).':';
           $result .= join('&',map {&escape($_);} (@code_order)).':';
           foreach my $key (keys(%cat_titles)) {
               $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_titles{$key}).'&';
           }
           $result =~ s/\&$//;
           $result .= ':';
           foreach my $key (keys(%cat_order)) {
               $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_order{$key}).'&';
           }
           $result =~ s/\&$//;
           &Reply($client,\$result,$userinput);
       } else {
           &Reply($client, "format_error\n", $userinput);
       }
       return 1;
   }
   &register_handler("autopossibleinstcodes",
                     \&get_possible_instcodes_handler,0,1,0);
   
   sub get_institutional_user_rules {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my $dom = &unescape($tail);
       my (%rules_hash,@rules_order);
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::username_rules($dom,\%rules_hash,\@rules_order);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result;
               foreach my $key (keys(%rules_hash)) {
                   $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
               }
               $result =~ s/\&$//;
               $result .= ':';
               if (@rules_order > 0) {
                   foreach my $item (@rules_order) {
                       $result .= &escape($item).'&';
                   }
               }
               $result =~ s/\&$//;
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instuserrules",\&get_institutional_user_rules,0,1,0);
   
   sub get_institutional_id_rules {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my $dom = &unescape($tail);
       my (%rules_hash,@rules_order);
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::id_rules($dom,\%rules_hash,\@rules_order);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result;
               foreach my $key (keys(%rules_hash)) {
                   $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
               }
               $result =~ s/\&$//;
               $result .= ':';
               if (@rules_order > 0) {
                   foreach my $item (@rules_order) {
                       $result .= &escape($item).'&';
                   }
               }
               $result =~ s/\&$//;
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instidrules",\&get_institutional_id_rules,0,1,0);
   
   sub get_institutional_selfcreate_rules {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my $dom = &unescape($tail);
       my (%rules_hash,@rules_order);
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::selfcreate_rules($dom,\%rules_hash,\@rules_order);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result;
               foreach my $key (keys(%rules_hash)) {
                   $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
               }
               $result =~ s/\&$//;
               $result .= ':';
               if (@rules_order > 0) {
                   foreach my $item (@rules_order) {
                       $result .= &escape($item).'&';
                   }
               }
               $result =~ s/\&$//;
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instemailrules",\&get_institutional_selfcreate_rules,0,1,0);
   
   
   sub institutional_username_check {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my %rulecheck;
       my $outcome;
       my ($udom,$uname,@rules) = split(/:/,$tail);
       $udom = &unescape($udom);
       $uname = &unescape($uname);
       @rules = map {&unescape($_);} (@rules);
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::username_check($udom,$uname,\@rules,\%rulecheck);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result='';
               foreach my $key (keys(%rulecheck)) {
                   $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
               }
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instrulecheck",\&institutional_username_check,0,1,0);
   
   sub institutional_id_check {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my %rulecheck;
       my $outcome;
       my ($udom,$id,@rules) = split(/:/,$tail);
       $udom = &unescape($udom);
       $id = &unescape($id);
       @rules = map {&unescape($_);} (@rules);
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::id_check($udom,$id,\@rules,\%rulecheck);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result='';
               foreach my $key (keys(%rulecheck)) {
                   $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
               }
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instidrulecheck",\&institutional_id_check,0,1,0);
   
   sub institutional_selfcreate_check {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my %rulecheck;
       my $outcome;
       my ($udom,$email,@rules) = split(/:/,$tail);
       $udom = &unescape($udom);
       $email = &unescape($email);
       @rules = map {&unescape($_);} (@rules);
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::selfcreate_check($udom,$email,\@rules,\%rulecheck);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result='';
               foreach my $key (keys(%rulecheck)) {
                   $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
               }
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instselfcreatecheck",\&institutional_selfcreate_check,0,1,0);
   
   # Get domain specific conditions for import of student photographs to a course
   #
   # Retrieves information from photo_permission subroutine in localenroll.
   # Returns outcome (ok) if no processing errors, and whether course owner is 
   # required to accept conditions of use (yes/no).
   #
   #    
   sub photo_permission_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my $cdom = $tail;
       my ($perm_reqd,$conditions);
       my $outcome;
       eval {
    local($SIG{__DIE__})='DEFAULT';
    $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
     \$conditions);
       };
       if (!$@) {
    &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
          $userinput);
       } else {
    &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autophotopermission",\&photo_permission_handler,0,1,0);
   
   #
   # Checks if student photo is available for a user in the domain, in the user's
   # directory (in /userfiles/internal/studentphoto.jpg).
   # Uses localstudentphoto:fetch() to ensure there is an up to date copy of
   # the student's photo.   
   
   sub photo_check_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my ($udom,$uname,$pid) = split(/:/,$tail);
       $udom = &unescape($udom);
       $uname = &unescape($uname);
       $pid = &unescape($pid);
       my $path=&propath($udom,$uname).'/userfiles/internal/';
       if (!-e $path) {
           &mkpath($path);
       }
       my $response;
       my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
       $result .= ':'.$response;
       &Reply($client, &escape($result)."\n",$userinput);
       return 1;
   }
   &register_handler("autophotocheck",\&photo_check_handler,0,1,0);
   
   #
   # Retrieve information from localenroll about whether to provide a button     
   # for users who have enbled import of student photos to initiate an 
   # update of photo files for registered students. Also include 
   # comment to display alongside button.  
   
   sub photo_choice_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput             = "$cmd:$tail";
       my $cdom                  = &unescape($tail);
       my ($update,$comment);
       eval {
    local($SIG{__DIE__})='DEFAULT';
    ($update,$comment)    = &localenroll::manager_photo_update($cdom);
       };
       if (!$@) {
    &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
       } else {
    &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autophotochoice",\&photo_choice_handler,0,1,0);
   
 #  #
 # Gets a student's photo to exist (in the correct image type) in the user's   # Gets a student's photo to exist (in the correct image type) in the user's 
 # directory.  # directory.
Line 3992  sub get_institutional_code_format_handle Line 5722  sub get_institutional_code_format_handle
 #    $client  - The socket open on the client.  #    $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1 - continue processing.  #    1 - continue processing.
   
 sub student_photo_handler {  sub student_photo_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     my ($domain,$uname,$type) = split(/:/, $tail);      my ($domain,$uname,$ext,$type) = split(/:/, $tail);
   
     my $path=&propath($domain,$uname).      my $path=&propath($domain,$uname). '/userfiles/internal/';
  '/userfiles/internal/studentphoto.'.$type;      my $filename = 'studentphoto.'.$ext;
     if (-e $path) {      if ($type eq 'thumbnail') {
           $filename = 'studentphoto_tn.'.$ext;
       }
       if (-e $path.$filename) {
  &Reply($client,"ok\n","$cmd:$tail");   &Reply($client,"ok\n","$cmd:$tail");
  return 1;   return 1;
     }      }
     &mkpath($path);      &mkpath($path);
     my $file=&localstudentphoto::fetch($domain,$uname);      my $file;
       if ($type eq 'thumbnail') {
    eval {
       local($SIG{__DIE__})='DEFAULT';
       $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
    };
       } else {
           $file=&localstudentphoto::fetch($domain,$uname);
       }
     if (!$file) {      if (!$file) {
  &Failure($client,"unavailable\n","$cmd:$tail");   &Failure($client,"unavailable\n","$cmd:$tail");
  return 1;   return 1;
     }      }
     if (!-e $path) { &convert_photo($file,$path); }      if (!-e $path.$filename) { &convert_photo($file,$path.$filename); }
     if (-e $path) {      if (-e $path.$filename) {
  &Reply($client,"ok\n","$cmd:$tail");   &Reply($client,"ok\n","$cmd:$tail");
  return 1;   return 1;
     }      }
Line 4018  sub student_photo_handler { Line 5760  sub student_photo_handler {
 }  }
 &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);  &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);
   
   sub inst_usertypes_handler {
       my ($cmd, $domain, $client) = @_;
       my $res;
       my $userinput = $cmd.":".$domain; # For logging purposes.
       my (%typeshash,@order,$result);
       eval {
    local($SIG{__DIE__})='DEFAULT';
    $result=&localenroll::inst_usertypes($domain,\%typeshash,\@order);
       };
       if ($result eq 'ok') {
           if (keys(%typeshash) > 0) {
               foreach my $key (keys(%typeshash)) {
                   $res.=&escape($key).'='.&escape($typeshash{$key}).'&';
               }
           }
           $res=~s/\&$//;
           $res .= ':';
           if (@order > 0) {
               foreach my $item (@order) {
                   $res .= &escape($item).'&';
               }
           }
           $res=~s/\&$//;
       }
       &Reply($client, \$res, $userinput);
       return 1;
   }
   &register_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);
   
 # mkpath makes all directories for a file, expects an absolute path with a  # mkpath makes all directories for a file, expects an absolute path with a
 # file or a trailing / if just a dir is passed  # file or a trailing / if just a dir is passed
 # returns 1 on success 0 on failure  # returns 1 on success 0 on failure
Line 4070  sub process_request { Line 5841  sub process_request {
                                 # fix all the userinput -> user_input.                                  # fix all the userinput -> user_input.
     my $wasenc    = 0; # True if request was encrypted.      my $wasenc    = 0; # True if request was encrypted.
 # ------------------------------------------------------------ See if encrypted  # ------------------------------------------------------------ See if encrypted
       # for command
       # sethost:<server>
       # <command>:<args>
       #   we just send it to the processor
       # for
       # sethost:<server>:<command>:<args>
       #  we do the implict set host and then do the command
       if ($userinput =~ /^sethost:/) {
    (my $cmd,my $newid,$userinput) = split(':',$userinput,3);
    if (defined($userinput)) {
       &sethost("$cmd:$newid");
    } else {
       $userinput = "$cmd:$newid";
    }
       }
   
     if ($userinput =~ /^enc/) {      if ($userinput =~ /^enc/) {
  $userinput = decipher($userinput);   $userinput = decipher($userinput);
  $wasenc=1;   $wasenc=1;
Line 4265  sub catchexception { Line 6052  sub catchexception {
     $SIG{__DIE__}='DEFAULT';      $SIG{__DIE__}='DEFAULT';
     &status("Catching exception");      &status("Catching exception");
     &logthis("<font color='red'>CRITICAL: "      &logthis("<font color='red'>CRITICAL: "
      ."ABNORMAL EXIT. Child $$ for server $thisserver died through "       ."ABNORMAL EXIT. Child $$ for server ".$perlvar{'lonHostID'}." died through "
      ."a crash with this error msg->[$error]</font>");       ."a crash with this error msg->[$error]</font>");
     &logthis('Famous last words: '.$status.' - '.$lastlog);      &logthis('Famous last words: '.$status.' - '.$lastlog);
     if ($client) { print $client "error: $error\n"; }      if ($client) { print $client "error: $error\n"; }
Line 4318  if (-e $pidfile) { Line 6105  if (-e $pidfile) {
 $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},  $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
                                 Type      => SOCK_STREAM,                                  Type      => SOCK_STREAM,
                                 Proto     => 'tcp',                                  Proto     => 'tcp',
                                 Reuse     => 1,                                  ReuseAddr     => 1,
                                 Listen    => 10 )                                  Listen    => 10 )
   or die "making socket: $@\n";    or die "making socket: $@\n";
   
Line 4376  sub HUPSMAN {                      # sig Line 6163  sub HUPSMAN {                      # sig
 }  }
   
 #  #
 #    Kill off hashes that describe the host table prior to re-reading it.  
 #    Hashes affected are:  
 #       %hostid, %hostdom %hostip %hostdns.  
 #  
 sub KillHostHashes {  
     foreach my $key (keys %hostid) {  
  delete $hostid{$key};  
     }  
     foreach my $key (keys %hostdom) {  
  delete $hostdom{$key};  
     }  
     foreach my $key (keys %hostip) {  
  delete $hostip{$key};  
     }  
     foreach my $key (keys %hostdns) {  
  delete $hostdns{$key};  
     }  
 }  
 #  
 #   Read in the host table from file and distribute it into the various hashes:  
 #  
 #    - %hostid  -  Indexed by IP, the loncapa hostname.  
 #    - %hostdom -  Indexed by  loncapa hostname, the domain.  
 #    - %hostip  -  Indexed by hostid, the Ip address of the host.  
 sub ReadHostTable {  
   
     open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";  
     my $myloncapaname = $perlvar{'lonHostID'};  
     Debug("My loncapa name is : $myloncapaname");  
     my %name_to_ip;  
     while (my $configline=<CONFIG>) {  
  if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) {  
     my ($id,$domain,$role,$name)=split(/:/,$configline);  
     $name=~s/\s//g;  
     my $ip;  
     if (!exists($name_to_ip{$name})) {  
  $ip = gethostbyname($name);  
  if (!$ip || length($ip) ne 4) {  
     &logthis("Skipping host $id name $name no IP found\n");  
     next;  
  }  
  $ip=inet_ntoa($ip);  
  $name_to_ip{$name} = $ip;  
     } else {  
  $ip = $name_to_ip{$name};  
     }  
     $hostid{$ip}=$id;         # LonCAPA name of host by IP.  
     $hostdom{$id}=$domain;    # LonCAPA domain name of host.   
     $hostip{$id}=$ip;         # IP address of host.  
     $hostdns{$name} = $id;    # LonCAPA name of host by DNS.  
   
     if ($id eq $perlvar{'lonHostID'}) {   
  Debug("Found me in the host table: $name");  
  $thisserver=$name;   
     }  
  }  
     }  
     close(CONFIG);  
 }  
 #  
 #  Reload the Apache daemon's state.  #  Reload the Apache daemon's state.
 #  This is done by invoking /home/httpd/perl/apachereload  #  This is done by invoking /home/httpd/perl/apachereload
 #  a setuid perl script that can be root for us to do this job.  #  a setuid perl script that can be root for us to do this job.
 #  #
 sub ReloadApache {  sub ReloadApache {
     my $execdir = $perlvar{'lonDaemons'};  # --------------------------- Handle case of another apachereload process (locking)
     my $script  = $execdir."/apachereload";      if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) {
     system($script);          my $execdir = $perlvar{'lonDaemons'};
           my $script  = $execdir."/apachereload";
           system($script);
           unlink('/tmp/lock_apachereload'); #  Remove the lock file.
       }
 }  }
   
 #  #
Line 4466  sub UpdateHosts { Line 6197  sub UpdateHosts {
     #  either dropped or changed hosts.  Note that the re-read of the table      #  either dropped or changed hosts.  Note that the re-read of the table
     #  will take care of new and changed hosts as connections come into being.      #  will take care of new and changed hosts as connections come into being.
   
       &Apache::lonnet::reset_hosts_info();
   
     KillHostHashes;      foreach my $child (keys(%children)) {
     ReadHostTable;  
   
     foreach my $child (keys %children) {  
  my $childip = $children{$child};   my $childip = $children{$child};
  if(!$hostid{$childip}) {   if ($childip ne '127.0.0.1'
       && !defined(&Apache::lonnet::get_hosts_from_ip($childip))) {
     logthis('<font color="blue"> UpdateHosts killing child '      logthis('<font color="blue"> UpdateHosts killing child '
     ." $child for ip $childip </font>");      ." $child for ip $childip </font>");
     kill('INT', $child);      kill('INT', $child);
Line 4555  sub Debug { Line 6285  sub Debug {
 #     reply   - Text to send to client.  #     reply   - Text to send to client.
 #     request - Original request from client.  #     request - Original request from client.
 #  #
   #NOTE $reply must be terminated by exactly *one* \n. If $reply is a reference
   #this is done automatically ($$reply must not contain any \n in this case). 
   #If $reply is a string the caller has to ensure this.
 sub Reply {  sub Reply {
     my ($fd, $reply, $request) = @_;      my ($fd, $reply, $request) = @_;
     print $fd $reply;      if (ref($reply)) {
     Debug("Request was $request  Reply was $reply");   print $fd $$reply;
    print $fd "\n";
    if ($DEBUG) { Debug("Request was $request  Reply was $$reply"); }
       } else {
    print $fd $reply;
    if ($DEBUG) { Debug("Request was $request  Reply was $reply"); }
       }
     $Transactions++;      $Transactions++;
 }  }
   
Line 4612  sub logstatus { Line 6350  sub logstatus {
 sub initnewstatus {  sub initnewstatus {
     my $docdir=$perlvar{'lonDocRoot'};      my $docdir=$perlvar{'lonDocRoot'};
     my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");      my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
     my $now=time;      my $now=time();
     my $local=localtime($now);      my $local=localtime($now);
     print $fh "LOND status $local - parent $$\n\n";      print $fh "LOND status $local - parent $$\n\n";
     opendir(DIR,"$docdir/lon-status/londchld");      opendir(DIR,"$docdir/lon-status/londchld");
Line 4632  sub status { Line 6370  sub status {
     $0='lond: '.$what.' '.$local;      $0='lond: '.$what.' '.$local;
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  
   
 sub escape {  
     my $str=shift;  
     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;  
     return $str;  
 }  
   
 # ----------------------------------------------------- Un-Escape Special Chars  
   
 sub unescape {  
     my $str=shift;  
     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     return $str;  
 }  
   
 # ----------------------------------------------------------- Send USR1 to lonc  
   
 sub reconlonc {  
     my $peerfile=shift;  
     &logthis("Trying to reconnect for $peerfile");  
     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";  
     if (my $fh=IO::File->new("$loncfile")) {  
  my $loncpid=<$fh>;  
         chomp($loncpid);  
         if (kill 0 => $loncpid) {  
     &logthis("lonc at pid $loncpid responding, sending USR1");  
             kill USR1 => $loncpid;  
         } else {  
     &logthis(  
               "<font color='red'>CRITICAL: "  
              ."lonc at pid $loncpid not responding, giving up</font>");  
         }  
     } else {  
       &logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');  
     }  
 }  
   
 # -------------------------------------------------- Non-critical communication  
   
 sub subreply {  
     my ($cmd,$server)=@_;  
     my $peerfile="$perlvar{'lonSockDir'}/$server";  
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",  
                                       Type    => SOCK_STREAM,  
                                       Timeout => 10)  
        or return "con_lost";  
     print $sclient "$cmd\n";  
     my $answer=<$sclient>;  
     chomp($answer);  
     if (!$answer) { $answer="con_lost"; }  
     return $answer;  
 }  
   
 sub reply {  
   my ($cmd,$server)=@_;  
   my $answer;  
   if ($server ne $currenthostid) {   
     $answer=subreply($cmd,$server);  
     if ($answer eq 'con_lost') {  
  $answer=subreply("ping",$server);  
         if ($answer ne $server) {  
     &logthis("sub reply: answer != server answer is $answer, server is $server");  
            &reconlonc("$perlvar{'lonSockDir'}/$server");  
         }  
         $answer=subreply($cmd,$server);  
     }  
   } else {  
     $answer='self_reply';  
   }   
   return $answer;  
 }  
   
 # -------------------------------------------------------------- Talk to lonsql  # -------------------------------------------------------------- Talk to lonsql
   
 sub sql_reply {  sub sql_reply {
Line 4722  sub sub_sql_reply { Line 6387  sub sub_sql_reply {
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";         or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "$cmd:$currentdomainid\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
     if (!$answer) { $answer="con_lost"; }      if (!$answer) { $answer="con_lost"; }
     return $answer;      return $answer;
 }  }
   
 # -------------------------------------------- Return path to profile directory  
   
 sub propath {  
     my ($udom,$uname)=@_;  
     $udom=~s/\W//g;  
     $uname=~s/\W//g;  
     my $subdir=$uname.'__';  
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;  
     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";  
     return $proname;  
 }   
   
 # --------------------------------------- Is this the home server of an author?  # --------------------------------------- Is this the home server of an author?
   
 sub ishome {  sub ishome {
Line 4785  $SIG{USR1} = \&checkchildren; Line 6438  $SIG{USR1} = \&checkchildren;
 $SIG{USR2} = \&UpdateHosts;  $SIG{USR2} = \&UpdateHosts;
   
 #  Read the host hashes:  #  Read the host hashes:
   &Apache::lonnet::load_hosts_tab();
   my %iphost = &Apache::lonnet::get_iphost(1);
   
 ReadHostTable;  $dist=`$perlvar{'lonDaemons'}/distprobe`;
   
 my $dist=`$perlvar{'lonDaemons'}/distprobe`;  my $arch = `uname -i`;
   chomp($arch);
   if ($arch eq 'unknown') {
       $arch = `uname -m`;
       chomp($arch);
   }
   
 # --------------------------------------------------------------  # --------------------------------------------------------------
 #   Accept connections.  When a connection comes in, it is validated  #   Accept connections.  When a connection comes in, it is validated
Line 4847  sub make_new_child { Line 6507  sub make_new_child {
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
         $children{$pid} = $clientip;          $children{$pid} = $clientip;
         &status('Started child '.$pid);          &status('Started child '.$pid);
    close($client);
         return;          return;
     } else {      } else {
         # Child can *not* return from this subroutine.          # Child can *not* return from this subroutine.
Line 4855  sub make_new_child { Line 6516  sub make_new_child {
                                 #don't get intercepted                                  #don't get intercepted
         $SIG{USR1}= \&logstatus;          $SIG{USR1}= \&logstatus;
         $SIG{ALRM}= \&timeout;          $SIG{ALRM}= \&timeout;
    #
    # Block sigpipe as it gets thrownon socket disconnect and we want to 
    # deal with that as a read faiure instead.
    #
    my $blockset = POSIX::SigSet->new(SIGPIPE);
    sigprocmask(SIG_BLOCK, $blockset);
   
         $lastlog='Forked ';          $lastlog='Forked ';
         $status='Forked';          $status='Forked';
   
Line 4865  sub make_new_child { Line 6533  sub make_new_child {
 #        my $tmpsnum=0;            # Now global  #        my $tmpsnum=0;            # Now global
 #---------------------------------------------------- kerberos 5 initialization  #---------------------------------------------------- kerberos 5 initialization
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
  if ($dist ne 'fedora4') {   unless (($dist eq 'fedora5') || ($dist eq 'fedora4') ||  
    ($dist eq 'fedora6') || ($dist eq 'suse9.3') ||
                   ($dist eq 'suse12.2') || ($dist eq 'suse12.3')) {
     &Authen::Krb5::init_ets();      &Authen::Krb5::init_ets();
  }   }
   
Line 4875  sub make_new_child { Line 6545  sub make_new_child {
 # -----------------------------------------------------------------------------  # -----------------------------------------------------------------------------
  # see if we know client and 'check' for spoof IP by ineffective challenge   # see if we know client and 'check' for spoof IP by ineffective challenge
   
  ReadManagerTable; # May also be a manager!!  
   
  my $outsideip=$clientip;   my $outsideip=$clientip;
  if ($clientip eq '127.0.0.1') {   if ($clientip eq '127.0.0.1') {
     $outsideip=$hostip{$perlvar{'lonHostID'}};      $outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'});
  }   }
    &ReadManagerTable();
  my $clientrec=($hostid{$outsideip}     ne undef);   my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));
  my $ismanager=($managers{$outsideip}    ne undef);   my $ismanager=($managers{$outsideip}    ne undef);
  $clientname  = "[unknonwn]";   $clientname  = "[unknown]";
  if($clientrec) { # Establish client type.   if($clientrec) { # Establish client type.
     $ConnectionType = "client";      $ConnectionType = "client";
     $clientname = $hostid{$outsideip};      $clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
     if($ismanager) {      if($ismanager) {
  $ConnectionType = "both";   $ConnectionType = "both";
     }      }
Line 4906  sub make_new_child { Line 6574  sub make_new_child {
     my $remotereq=<$client>;      my $remotereq=<$client>;
     chomp($remotereq);      chomp($remotereq);
     Debug("Got init: $remotereq");      Debug("Got init: $remotereq");
     my $inikeyword = split(/:/, $remotereq);  
     if ($remotereq =~ /^init/) {      if ($remotereq =~ /^init/) {
  &sethost("sethost:$perlvar{'lonHostID'}");   &sethost("sethost:$perlvar{'lonHostID'}");
  #   #
  #  If the remote is attempting a local init... give that a try:   #  If the remote is attempting a local init... give that a try:
  #   #
  my ($i, $inittype) = split(/:/, $remotereq);          logthis("remotereq: $remotereq");
    (my $i, my $inittype, $clientversion) = split(/:/, $remotereq);
           # For LON-CAPA 2.9, the  client session will have sent its LON-CAPA
           # version when initiating the connection. For LON-CAPA 2.8 and older,
           # the version is retrieved from the global %loncaparevs in lonnet.pm.            
           # $clientversion contains path to keyfile if $inittype eq 'local'
           # it's overridden below in this case
           $clientversion ||= $Apache::lonnet::loncaparevs{$clientname};
   
  # If the connection type is ssl, but I didn't get my   # If the connection type is ssl, but I didn't get my
  # certificate files yet, then I'll drop  back to    # certificate files yet, then I'll drop  back to 
Line 4932  sub make_new_child { Line 6607  sub make_new_child {
  }   }
   
  if($inittype eq "local") {   if($inittype eq "local") {
                       $clientversion = $perlvar{'lonVersion'};
     my $key = LocalConnection($client, $remotereq);      my $key = LocalConnection($client, $remotereq);
     if($key) {      if($key) {
  Debug("Got local key $key");   Debug("Got local key $key");
Line 4939  sub make_new_child { Line 6615  sub make_new_child {
  my $cipherkey = pack("H32", $key);   my $cipherkey = pack("H32", $key);
  $cipher       = new IDEA($cipherkey);   $cipher       = new IDEA($cipherkey);
  print $client "ok:local\n";   print $client "ok:local\n";
  &logthis('<font color="green"'   &logthis('<font color="green">'
  . "Successful local authentication </font>");   . "Successful local authentication </font>");
  $keymode = "local"   $keymode = "local"
     } else {      } else {
Line 4994  sub make_new_child { Line 6670  sub make_new_child {
     
  if ($clientok) {   if ($clientok) {
 # ---------------- New known client connecting, could mean machine online again  # ---------------- New known client connecting, could mean machine online again
           if (&Apache::lonnet::get_host_ip($currenthostid) ne $clientip 
     foreach my $id (keys(%hostip)) {   && $clientip ne '127.0.0.1') {
  if ($hostip{$id} ne $clientip ||   &Apache::lonnet::reconlonc($clientname);
     $hostip{$currenthostid} eq $clientip) {  
     # no need to try to do recon's to myself  
     next;  
  }  
  &reconlonc("$perlvar{'lonSockDir'}/$id");  
     }      }
     &logthis("<font color='green'>Established connection: $clientname</font>");      &logthis("<font color='green'>Established connection: $clientname</font>");
     &status('Will listen to '.$clientname);      &status('Will listen to '.$clientname);
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
     my $keep_going = 1;      my $keep_going = 1;
     my $user_input;      my $user_input;
               my $clienthost = &Apache::lonnet::hostname($clientname);
               my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);
               $clienthomedom = &Apache::lonnet::host_domain($clientserverhomeID);
     while(($user_input = get_request) && $keep_going) {      while(($user_input = get_request) && $keep_going) {
  alarm(120);   alarm(120);
  Debug("Main: Got $user_input\n");   Debug("Main: Got $user_input\n");
Line 5057  sub is_author { Line 6731  sub is_author {
   
     #  Author role should show up as a key /domain/_au      #  Author role should show up as a key /domain/_au
   
     my $key   = "/$domain/_au";      my $value;
     my $value = $hashref->{$key};      if ($hashref) {
   
     if(defined($value)) {   my $key    = "/$domain/_au";
  &Debug("$user @ $domain is an author");   if (defined($hashref)) {
       $value = $hashref->{$key};
       if(!untie_user_hash($hashref)) {
    return 'error: ' .  ($!+0)." untie (GDBM) Failed";
       }
    }
   
    if(defined($value)) {
       &Debug("$user @ $domain is an author");
    }
       } else {
    return 'error: '.($!+0)." tie (GDBM) Failed";
     }      }
   
     return defined($value);      return defined($value);
 }  }
 #  #
 #   Checks to see if the input roleput request was to set  #   Checks to see if the input roleput request was to set
 # an author role.  If so, invokes the lchtmldir script to set  # an author role.  If so, creates construction space 
 # up a correct public_html   
 # Parameters:  # Parameters:
 #    request   - The request sent to the rolesput subchunk.  #    request   - The request sent to the rolesput subchunk.
 #                We're looking for  /domain/_au  #                We're looking for  /domain/_au
Line 5079  sub is_author { Line 6763  sub is_author {
 #  #
 sub manage_permissions {  sub manage_permissions {
     my ($request, $domain, $user, $authtype) = @_;      my ($request, $domain, $user, $authtype) = @_;
   
     &Debug("manage_permissions: $request $domain $user $authtype");  
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
     if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
  my $execdir = $perlvar{'lonDaemons'};          my $path=$perlvar{'lonDocRoot'}."/priv/$domain";
  my $userhome= "/home/$user" ;          unless (-e $path) {        
  &logthis("system $execdir/lchtmldir $userhome $user $authtype");             mkdir($path);
  &Debug("Setting homedir permissions for $userhome");          }
  system("$execdir/lchtmldir $userhome $user $authtype");          unless (-e $path.'/'.$user) {
              mkdir($path.'/'.$user);
           }
     }      }
 }  }
   
Line 5163  sub rewrite_password_file { Line 6846  sub rewrite_password_file {
   
 #     Returns the authorization type or nouser if there is no such user.  #     Returns the authorization type or nouser if there is no such user.
 #  #
 sub get_auth_type   sub get_auth_type {
 {  
   
     my ($domain, $user)  = @_;      my ($domain, $user)  = @_;
   
     Debug("get_auth_type( $domain, $user ) \n");      Debug("get_auth_type( $domain, $user ) \n");
Line 5201  sub get_auth_type Line 6882  sub get_auth_type
 #     0        - The domain,user,password triplet is not a valid user.  #     0        - The domain,user,password triplet is not a valid user.
 #  #
 sub validate_user {  sub validate_user {
     my ($domain, $user, $password) = @_;      my ($domain, $user, $password, $checkdefauth) = @_;
   
   
     # Why negative ~pi you may well ask?  Well this function is about      # Why negative ~pi you may well ask?  Well this function is about
     # authentication, and therefore very important to get right.      # authentication, and therefore very important to get right.
Line 5225  sub validate_user { Line 6905  sub validate_user {
   
     my $null = pack("C",0); # Used by kerberos auth types.      my $null = pack("C",0); # Used by kerberos auth types.
   
       if ($howpwd eq 'nouser') {
           if ($checkdefauth) {
               my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
               if ($domdefaults{'auth_def'} eq 'localauth') {
                   $howpwd = $domdefaults{'auth_def'};
                   $contentpwd = $domdefaults{'auth_arg_def'};
               } elsif ((($domdefaults{'auth_def'} eq 'krb4') || 
                         ($domdefaults{'auth_def'} eq 'krb5')) &&
                        ($domdefaults{'auth_arg_def'} ne '')) {
                   $howpwd = $domdefaults{'auth_def'};
                   $contentpwd = $domdefaults{'auth_arg_def'}; 
               }
           }
       } 
     if ($howpwd ne 'nouser') {      if ($howpwd ne 'nouser') {
   
  if($howpwd eq "internal") { # Encrypted is in local password file.   if($howpwd eq "internal") { # Encrypted is in local password file.
     $validated = (crypt($password, $contentpwd) eq $contentpwd);      $validated = (crypt($password, $contentpwd) eq $contentpwd);
  }   }
Line 5248  sub validate_user { Line 6941  sub validate_user {
     } else {      } else {
  $validated = 0;   $validated = 0;
     }      }
  }   } elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
  elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.              my $checkwithkrb5 = 0;
     if(! ($password =~ /$null/) ) {              if ($dist =~/^fedora(\d+)$/) {
  my $k4error = &Authen::Krb4::get_pw_in_tkt($user,                  if ($1 > 11) {
    "",                      $checkwithkrb5 = 1;
    $contentpwd,,                  }
    'krbtgt',              } elsif ($dist =~ /^suse([\d.]+)$/) {
    $contentpwd,                  if ($1 > 11.1) {
    1,                      $checkwithkrb5 = 1; 
    $password);                  }
  if(!$k4error) {              }
     $validated = 1;              if ($checkwithkrb5) {
  } else {                  $validated = &krb5_authen($password,$null,$user,$contentpwd);
     $validated = 0;              } else {
     &logthis('krb4: '.$user.', '.$contentpwd.', '.                  $validated = &krb4_authen($password,$null,$user,$contentpwd);
      &Authen::Krb4::get_err_txt($Authen::Krb4::error));              }
  }  
     } else {  
  $validated = 0; # Password has a match with null.  
     }  
  } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.   } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
     if(!($password =~ /$null/)) { # Null password not allowed.              $validated = &krb5_authen($password,$null,$user,$contentpwd);
  my $krbclient = &Authen::Krb5::parse_name($user.'@'  
   .$contentpwd);  
  my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;  
  my $krbserver  = &Authen::Krb5::parse_name($krbservice);  
  my $credentials= &Authen::Krb5::cc_default();  
  $credentials->initialize($krbclient);  
  my $krbreturn  = &Authen::Krb5::get_in_tkt_with_password($krbclient,  
  $krbserver,  
  $password,  
  $credentials);  
  $validated = ($krbreturn == 1);  
     } else {  
  $validated = 0;  
     }  
  } elsif ($howpwd eq "localauth") {    } elsif ($howpwd eq "localauth") { 
     #  Authenticate via installation specific authentcation method:      #  Authenticate via installation specific authentcation method:
     $validated = &localauth::localauth($user,       $validated = &localauth::localauth($user, 
        $password,          $password, 
        $contentpwd);         $contentpwd,
          $domain);
       if ($validated < 0) {
    &logthis("localauth for $contentpwd $user:$domain returned a $validated");
    $validated = 0;
       }
  } else { # Unrecognized auth is also bad.   } else { # Unrecognized auth is also bad.
     $validated = 0;      $validated = 0;
  }   }
Line 5309  sub validate_user { Line 6989  sub validate_user {
     return $validated;      return $validated;
 }  }
   
   sub krb4_authen {
       my ($password,$null,$user,$contentpwd) = @_;
       my $validated = 0;
       if (!($password =~ /$null/) ) {  # Null password not allowed.
           eval {
               require Authen::Krb4;
           };
           if (!$@) {
               my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
                                                          "",
                                                          $contentpwd,,
                                                          'krbtgt',
                                                          $contentpwd,
                                                          1,
                                                          $password);
               if(!$k4error) {
                   $validated = 1;
               } else {
                   $validated = 0;
                   &logthis('krb4: '.$user.', '.$contentpwd.', '.
                             &Authen::Krb4::get_err_txt($Authen::Krb4::error));
               }
           } else {
               $validated = krb5_authen($password,$null,$user,$contentpwd);
           }
       }
       return $validated;
   }
   
   sub krb5_authen {
       my ($password,$null,$user,$contentpwd) = @_;
       my $validated = 0;
       if(!($password =~ /$null/)) { # Null password not allowed.
           my $krbclient = &Authen::Krb5::parse_name($user.'@'
                                                     .$contentpwd);
           my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
           my $krbserver  = &Authen::Krb5::parse_name($krbservice);
           my $credentials= &Authen::Krb5::cc_default();
           $credentials->initialize(&Authen::Krb5::parse_name($user.'@'
                                                               .$contentpwd));
           my $krbreturn;
           if (exists(&Authen::Krb5::get_init_creds_password)) {
               $krbreturn =
                   &Authen::Krb5::get_init_creds_password($krbclient,$password,
                                                             $krbservice);
               $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
           } else {
               $krbreturn  =
                   &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
                                                            $password,$credentials);
               $validated = ($krbreturn == 1);
           }
           if (!$validated) {
               &logthis('krb5: '.$user.', '.$contentpwd.', '.
                        &Authen::Krb5::error());
           }
       }
       return $validated;
   }
   
 sub addline {  sub addline {
     my ($fname,$hostid,$ip,$newline)=@_;      my ($fname,$hostid,$ip,$newline)=@_;
     my $contents;      my $contents;
     my $found=0;      my $found=0;
     my $expr='^'.$hostid.':'.$ip.':';      my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':';
     $expr =~ s/\./\\\./g;  
     my $sh;      my $sh;
     if ($sh=IO::File->new("$fname.subscription")) {      if ($sh=IO::File->new("$fname.subscription")) {
  while (my $subline=<$sh>) {   while (my $subline=<$sh>) {
Line 5331  sub addline { Line 7069  sub addline {
 }  }
   
 sub get_chat {  sub get_chat {
     my ($cdom,$cname,$udom,$uname)=@_;      my ($cdom,$cname,$udom,$uname,$group)=@_;
     my %hash;  
     my $proname=&propath($cdom,$cname);  
     my @entries=();      my @entries=();
     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",      my $namespace = 'nohist_chatroom';
     &GDBM_READER(),0640)) {      my $namespace_inroom = 'nohist_inchatroom';
  @entries=map { $_.':'.$hash{$_} } sort keys %hash;      if ($group ne '') {
  untie %hash;          $namespace .= '_'.$group;
           $namespace_inroom .= '_'.$group;
       }
       my $hashref = &tie_user_hash($cdom, $cname, $namespace,
    &GDBM_READER());
       if ($hashref) {
    @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
    &untie_user_hash($hashref);
     }      }
     my @participants=();      my @participants=();
     my $cutoff=time-60;      my $cutoff=time-60;
     if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db",      $hashref = &tie_user_hash($cdom, $cname, $namespace_inroom,
     &GDBM_WRCREAT(),0640)) {        &GDBM_WRCREAT());
         $hash{$uname.':'.$udom}=time;      if ($hashref) {
         foreach (sort keys %hash) {          $hashref->{$uname.':'.$udom}=time;
     if ($hash{$_}>$cutoff) {          foreach my $user (sort(keys(%$hashref))) {
  $participants[$#participants+1]='active_participant:'.$_;      if ($hashref->{$user}>$cutoff) {
    push(@participants, 'active_participant:'.$user);
             }              }
         }          }
         untie %hash;          &untie_user_hash($hashref);
     }      }
     return (@participants,@entries);      return (@participants,@entries);
 }  }
   
 sub chat_add {  sub chat_add {
     my ($cdom,$cname,$newchat)=@_;      my ($cdom,$cname,$newchat,$group)=@_;
     my %hash;  
     my $proname=&propath($cdom,$cname);  
     my @entries=();      my @entries=();
     my $time=time;      my $time=time;
     if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db",      my $namespace = 'nohist_chatroom';
     &GDBM_WRCREAT(),0640)) {      my $logfile = 'chatroom.log';
  @entries=map { $_.':'.$hash{$_} } sort keys %hash;      if ($group ne '') {
           $namespace .= '_'.$group;
           $logfile = 'chatroom_'.$group.'.log';
       }
       my $hashref = &tie_user_hash($cdom, $cname, $namespace,
    &GDBM_WRCREAT());
       if ($hashref) {
    @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
  my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);   my ($lastid)=($entries[$#entries]=~/^(\w+)\:/);
  my ($thentime,$idnum)=split(/\_/,$lastid);   my ($thentime,$idnum)=split(/\_/,$lastid);
  my $newid=$time.'_000000';   my $newid=$time.'_000000';
Line 5373  sub chat_add { Line 7123  sub chat_add {
     $idnum=substr('000000'.$idnum,-6,6);      $idnum=substr('000000'.$idnum,-6,6);
     $newid=$time.'_'.$idnum;      $newid=$time.'_'.$idnum;
  }   }
  $hash{$newid}=$newchat;   $hashref->{$newid}=$newchat;
  my $expired=$time-3600;   my $expired=$time-3600;
  foreach (keys %hash) {   foreach my $comment (keys(%$hashref)) {
     my ($thistime)=($_=~/(\d+)\_/);      my ($thistime) = ($comment=~/(\d+)\_/);
     if ($thistime<$expired) {      if ($thistime<$expired) {
  delete $hash{$_};   delete $hashref->{$comment};
     }      }
  }   }
  untie %hash;   {
     }      my $proname=&propath($cdom,$cname);
     {      if (open(CHATLOG,">>$proname/$logfile")) { 
  my $hfh;   print CHATLOG ("$time:".&unescape($newchat)."\n");
  if ($hfh=IO::File->new(">>$proname/chatroom.log")) {       }
     print $hfh "$time:".&unescape($newchat)."\n";      close(CHATLOG);
  }   }
    &untie_user_hash($hashref);
     }      }
 }  }
   
Line 5509  sub subscribe { Line 7260  sub subscribe {
                 # the metadata                  # the metadata
  unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }   unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
  $fname=~s/\/home\/httpd\/html\/res/raw/;   $fname=~s/\/home\/httpd\/html\/res/raw/;
  $fname="http://$thisserver/".$fname;                  my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}};
                   $protocol = 'http' if ($protocol ne 'https');
    $fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
  $result="$fname\n";   $result="$fname\n";
     }      }
  } else {   } else {
Line 5551  sub change_unix_password { Line 7304  sub change_unix_password {
   
   
 sub make_passwd_file {  sub make_passwd_file {
     my ($uname, $umode,$npass,$passfilename)=@_;      my ($uname,$udom,$umode,$npass,$passfilename)=@_;
     my $result="ok\n";      my $result="ok";
     if ($umode eq 'krb4' or $umode eq 'krb5') {      if ($umode eq 'krb4' or $umode eq 'krb5') {
  {   {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
Line 5592  sub make_passwd_file { Line 7345  sub make_passwd_file {
     #      #
     my $uid = getpwnam($uname);      my $uid = getpwnam($uname);
     if((defined $uid) && ($uid == 0)) {      if((defined $uid) && ($uid == 0)) {
  &logthis(">>>Attempted to create privilged account blocked");   &logthis(">>>Attempt to create privileged account blocked");
  return "no_priv_account_error\n";   return "no_priv_account_error\n";
     }      }
   
Line 5604  sub make_passwd_file { Line 7357  sub make_passwd_file {
  &Debug("user  = ".$uname.", Password =". $npass);   &Debug("user  = ".$uname.", Password =". $npass);
  my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");   my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
  print $se "$uname\n";   print $se "$uname\n";
                   print $se "$udom\n";
  print $se "$npass\n";   print $se "$npass\n";
  print $se "$npass\n";   print $se "$npass\n";
  print $se "$lc_error_file\n"; # Status -> unique file.   print $se "$lc_error_file\n"; # Status -> unique file.
Line 5620  sub make_passwd_file { Line 7374  sub make_passwd_file {
  if($useraddok > 0) {   if($useraddok > 0) {
     my $error_text = &lcuseraddstrerror($useraddok);      my $error_text = &lcuseraddstrerror($useraddok);
     &logthis("Failed lcuseradd: $error_text");      &logthis("Failed lcuseradd: $error_text");
     $result = "lcuseradd_failed:$error_text\n";      $result = "lcuseradd_failed:$error_text";
  }  else {   }  else {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
     if($pf) {      if($pf) {
Line 5644  sub make_passwd_file { Line 7398  sub make_passwd_file {
     }      }
  }   }
     } else {      } else {
  $result="auth_mode_error\n";   $result="auth_mode_error";
     }      }
     return $result;      return $result;
 }  }
Line 5657  sub convert_photo { Line 7411  sub convert_photo {
 sub sethost {  sub sethost {
     my ($remotereq) = @_;      my ($remotereq) = @_;
     my (undef,$hostid)=split(/:/,$remotereq);      my (undef,$hostid)=split(/:/,$remotereq);
       # ignore sethost if we are already correct
       if ($hostid eq $currenthostid) {
    return 'ok';
       }
   
     if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }      if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
     if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {      if (&Apache::lonnet::get_host_ip($perlvar{'lonHostID'}) 
    eq &Apache::lonnet::get_host_ip($hostid)) {
  $currenthostid  =$hostid;   $currenthostid  =$hostid;
  $currentdomainid=$hostdom{$hostid};   $currentdomainid=&Apache::lonnet::host_domain($hostid);
  &logthis("Setting hostid to $hostid, and domain to $currentdomainid");  # &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
     } else {      } else {
  &logthis("Requested host id $hostid not an alias of ".   &logthis("Requested host id $hostid not an alias of ".
  $perlvar{'lonHostID'}." refusing connection");   $perlvar{'lonHostID'}." refusing connection");
Line 5676  sub version { Line 7436  sub version {
     return "version:$VERSION";      return "version:$VERSION";
 }  }
   
 #There is a copy of this in lonnet.pm  sub get_usersession_config {
 sub userload {      my ($dom,$name) = @_;
     my $numusers=0;      my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
     {      if (defined($cached)) {
  opendir(LONIDS,$perlvar{'lonIDsDir'});          return $usersessionconf;
  my $filename;      } else {
  my $curtime=time;          my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom);
  while ($filename=readdir(LONIDS)) {          if (ref($domconfig{'usersessions'}) eq 'HASH') {
     if ($filename eq '.' || $filename eq '..') {next;}              &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600);
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];              return $domconfig{'usersessions'};
     if ($curtime-$mtime < 1800) { $numusers++; }          }
  }      }
  closedir(LONIDS);      return;
     }  }
     my $userloadpercent=0;  
     my $maxuserload=$perlvar{'lonUserLoadLim'};  
     if ($maxuserload) {  
  $userloadpercent=100*$numusers/$maxuserload;  
     }  sub distro_and_arch {
     $userloadpercent=sprintf("%.2f",$userloadpercent);      return $dist.':'.$arch;
     return $userloadpercent;  
 }  
   
 # Routines for serializing arrays and hashes (copies from lonnet)  
   
 sub array2str {  
   my (@array) = @_;  
   my $result=&arrayref2str(\@array);  
   $result=~s/^__ARRAY_REF__//;  
   $result=~s/__END_ARRAY_REF__$//;  
   return $result;  
 }  
                                                                                    
 sub arrayref2str {  
   my ($arrayref) = @_;  
   my $result='__ARRAY_REF__';  
   foreach my $elem (@$arrayref) {  
     if(ref($elem) eq 'ARRAY') {  
       $result.=&arrayref2str($elem).'&';  
     } elsif(ref($elem) eq 'HASH') {  
       $result.=&hashref2str($elem).'&';  
     } elsif(ref($elem)) {  
       #print("Got a ref of ".(ref($elem))." skipping.");  
     } else {  
       $result.=&escape($elem).'&';  
     }  
   }  
   $result=~s/\&$//;  
   $result .= '__END_ARRAY_REF__';  
   return $result;  
 }  
                                                                                    
 sub hash2str {  
   my (%hash) = @_;  
   my $result=&hashref2str(\%hash);  
   $result=~s/^__HASH_REF__//;  
   $result=~s/__END_HASH_REF__$//;  
   return $result;  
 }  
                                                                                    
 sub hashref2str {  
   my ($hashref)=@_;  
   my $result='__HASH_REF__';  
   foreach (sort(keys(%$hashref))) {  
     if (ref($_) eq 'ARRAY') {  
       $result.=&arrayref2str($_).'=';  
     } elsif (ref($_) eq 'HASH') {  
       $result.=&hashref2str($_).'=';  
     } elsif (ref($_)) {  
       $result.='=';  
       #print("Got a ref of ".(ref($_))." skipping.");  
     } else {  
         if ($_) {$result.=&escape($_).'=';} else { last; }  
     }  
   
     if(ref($hashref->{$_}) eq 'ARRAY') {  
       $result.=&arrayref2str($hashref->{$_}).'&';  
     } elsif(ref($hashref->{$_}) eq 'HASH') {  
       $result.=&hashref2str($hashref->{$_}).'&';  
     } elsif(ref($hashref->{$_})) {  
        $result.='&';  
       #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");  
     } else {  
       $result.=&escape($hashref->{$_}).'&';  
     }  
   }  
   $result=~s/\&$//;  
   $result .= '__END_HASH_REF__';  
   return $result;  
 }  }
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
Line 5974  Place in B<logs/lond.log> Line 7665  Place in B<logs/lond.log>
   
 stores hash in namespace  stores hash in namespace
   
 =item rolesputy  =item rolesput
   
 put a role into a user's environment  put a role into a user's environment
   
Line 6082  to the client, and the connection is clo Line 7773  to the client, and the connection is clo
 IO::Socket  IO::Socket
 IO::File  IO::File
 Apache::File  Apache::File
 Symbol  
 POSIX  POSIX
 Crypt::IDEA  Crypt::IDEA
 LWP::UserAgent()  LWP::UserAgent()
Line 6092  Authen::Krb5 Line 7782  Authen::Krb5
   
 =head1 COREQUISITES  =head1 COREQUISITES
   
   none
   
 =head1 OSNAMES  =head1 OSNAMES
   
 linux  linux
Line 6101  linux Line 7793  linux
 Server/Process  Server/Process
   
 =cut  =cut
   
   
   =pod
   
   =head1 LOG MESSAGES
   
   The messages below can be emitted in the lond log.  This log is located
   in ~httpd/perl/logs/lond.log  Many log messages have HTML encapsulation
   to provide coloring if examined from inside a web page. Some do not.
   Where color is used, the colors are; Red for sometihhng to get excited
   about and to follow up on. Yellow for something to keep an eye on to
   be sure it does not get worse, Green,and Blue for informational items.
   
   In the discussions below, sometimes reference is made to ~httpd
   when describing file locations.  There isn't really an httpd 
   user, however there is an httpd directory that gets installed in the
   place that user home directories go.  On linux, this is usually
   (always?) /home/httpd.
   
   
   Some messages are colorless.  These are usually (not always)
   Green/Blue color level messages.
   
   =over 2
   
   =item (Red)  LocalConnection rejecting non local: <ip> ne 127.0.0.1
   
   A local connection negotiation was attempted by
   a host whose IP address was not 127.0.0.1.
   The socket is closed and the child will exit.
   lond has three ways to establish an encyrption
   key with a client:
   
   =over 2
   
   =item local 
   
   The key is written and read from a file.
   This is only valid for connections from localhost.
   
   =item insecure 
   
   The key is generated by the server and
   transmitted to the client.
   
   =item  ssl (secure)
   
   An ssl connection is negotiated with the client,
   the key is generated by the server and sent to the 
   client across this ssl connection before the
   ssl connectionis terminated and clear text
   transmission resumes.
   
   =back
   
   =item (Red) LocalConnection: caller is insane! init = <init> and type = <type>
   
   The client is local but has not sent an initialization
   string that is the literal "init:local"  The connection
   is closed and the child exits.
   
   =item Red CRITICAL Can't get key file <error>        
   
   SSL key negotiation is being attempted but the call to
   lonssl::KeyFile  failed.  This usually means that the
   configuration file is not correctly defining or protecting
   the directories/files lonCertificateDirectory or
   lonnetPrivateKey
   <error> is a string that describes the reason that
   the key file could not be located.
   
   =item (Red) CRITICAL  Can't get certificates <error>  
   
   SSL key negotiation failed because we were not able to retrives our certificate
   or the CA's certificate in the call to lonssl::CertificateFile
   <error> is the textual reason this failed.  Usual reasons:
   
   =over 2
   
   =item Apache config file for loncapa  incorrect:
   
   one of the variables 
   lonCertificateDirectory, lonnetCertificateAuthority, or lonnetCertificate
   undefined or incorrect
   
   =item Permission error:
   
   The directory pointed to by lonCertificateDirectory is not readable by lond
   
   =item Permission error:
   
   Files in the directory pointed to by lonCertificateDirectory are not readable by lond.
   
   =item Installation error:                         
   
   Either the certificate authority file or the certificate have not
   been installed in lonCertificateDirectory.
   
   =item (Red) CRITICAL SSL Socket promotion failed:  <err> 
   
   The promotion of the connection from plaintext to SSL failed
   <err> is the reason for the failure.  There are two
   system calls involved in the promotion (one of which failed), 
   a dup to produce
   a second fd on the raw socket over which the encrypted data
   will flow and IO::SOcket::SSL->new_from_fd which creates
   the SSL connection on the duped fd.
   
   =item (Blue)   WARNING client did not respond to challenge 
   
   This occurs on an insecure (non SSL) connection negotiation request.
   lond generates some number from the time, the PID and sends it to
   the client.  The client must respond by echoing this information back.
   If the client does not do so, that's a violation of the challenge
   protocols and the connection will be failed.
   
   =item (Red) No manager table. Nobody can manage!!    
   
   lond has the concept of privileged hosts that
   can perform remote management function such
   as update the hosts.tab.   The manager hosts
   are described in the 
   ~httpd/lonTabs/managers.tab file.
   this message is logged if this file is missing.
   
   
   =item (Green) Registering manager <dnsname> as <cluster_name> with <ipaddress>
   
   Reports the successful parse and registration
   of a specific manager. 
   
   =item Green existing host <clustername:dnsname>  
   
   The manager host is already defined in the hosts.tab
   the information in that table, rather than the info in the
   manager table will be used to determine the manager's ip.
   
   =item (Red) Unable to craete <filename>                 
   
   lond has been asked to create new versions of an administrative
   file (by a manager).  When this is done, the new file is created
   in a temp file and then renamed into place so that there are always
   usable administrative files, even if the update fails.  This failure
   message means that the temp file could not be created.
   The update is abandoned, and the old file is available for use.
   
   =item (Green) CopyFile from <oldname> to <newname> failed
   
   In an update of administrative files, the copy of the existing file to a
   backup file failed.  The installation of the new file may still succeed,
   but there will not be a back up file to rever to (this should probably
   be yellow).
   
   =item (Green) Pushfile: backed up <oldname> to <newname>
   
   See above, the backup of the old administrative file succeeded.
   
   =item (Red)  Pushfile: Unable to install <filename> <reason>
   
   The new administrative file could not be installed.  In this case,
   the old administrative file is still in use.
   
   =item (Green) Installed new < filename>.                      
   
   The new administrative file was successfullly installed.                                               
   
   =item (Red) Reinitializing lond pid=<pid>                    
   
   The lonc child process <pid> will be sent a USR2 
   signal.
   
   =item (Red) Reinitializing self                                    
   
   We've been asked to re-read our administrative files,and
   are doing so.
   
   =item (Yellow) error:Invalid process identifier <ident>  
   
   A reinit command was received, but the target part of the 
   command was not valid.  It must be either
   'lond' or 'lonc' but was <ident>
   
   =item (Green) isValideditCommand checking: Command = <command> Key = <key> newline = <newline>
   
   Checking to see if lond has been handed a valid edit
   command.  It is possible the edit command is not valid
   in that case there are no log messages to indicate that.
   
   =item Result of password change for  <username> pwchange_success
   
   The password for <username> was
   successfully changed.
   
   =item Unable to open <user> passwd to change password
   
   Could not rewrite the 
   internal password file for a user
   
   =item Result of password change for <user> : <result>
   
   A unix password change for <user> was attempted 
   and the pipe returned <result>  
   
   =item LWP GET: <message> for <fname> (<remoteurl>)
   
   The lightweight process fetch for a resource failed
   with <message> the local filename that should
   have existed/been created was  <fname> the
   corresponding URI: <remoteurl>  This is emitted in several
   places.
   
   =item Unable to move <transname> to <destname>     
   
   From fetch_user_file_handler - the user file was replicated but could not
   be mv'd to its final location.
   
   =item Looking for <domain> <username>              
   
   From user_has_session_handler - This should be a Debug call instead
   it indicates lond is about to check whether the specified user has a 
   session active on the specified domain on the local host.
   
   =item Client <ip> (<name>) hanging up: <input>     
   
   lond has been asked to exit by its client.  The <ip> and <name> identify the
   client systemand <input> is the full exit command sent to the server.
   
   =item Red CRITICAL: ABNORMAL EXIT. child <pid> for server <hostname> died through a crass with this error->[<message>].
   
   A lond child terminated.  NOte that this termination can also occur when the
   child receives the QUIT or DIE signals.  <pid> is the process id of the child,
   <hostname> the host lond is working for, and <message> the reason the child died
   to the best of our ability to get it (I would guess that any numeric value
   represents and errno value).  This is immediately followed by
   
   =item  Famous last words: Catching exception - <log> 
   
   Where log is some recent information about the state of the child.
   
   =item Red CRITICAL: TIME OUT <pid>                     
   
   Some timeout occured for server <pid>.  THis is normally a timeout on an LWP
   doing an HTTP::GET.
   
   =item child <pid> died                              
   
   The reaper caught a SIGCHILD for the lond child process <pid>
   This should be modified to also display the IP of the dying child
   $children{$pid}
   
   =item Unknown child 0 died                           
   A child died but the wait for it returned a pid of zero which really should not
   ever happen. 
   
   =item Child <which> - <pid> looks like we missed it's death 
   
   When a sigchild is received, the reaper process checks all children to see if they are
   alive.  If children are dying quite quickly, the lack of signal queuing can mean
   that a signal hearalds the death of more than one child.  If so this message indicates
   which other one died. <which> is the ip of a dead child
   
   =item Free socket: <shutdownretval>                
   
   The HUNTSMAN sub was called due to a SIGINT in a child process.  The socket is being shutdown.
   for whatever reason, <shutdownretval> is printed but in fact shutdown() is not documented
   to return anything. This is followed by: 
   
   =item Red CRITICAL: Shutting down                       
   
   Just prior to exit.
   
   =item Free socket: <shutdownretval>                 
   
   The HUPSMAN sub was called due to a SIGHUP.  all children get killsed, and lond execs itself.
   This is followed by:
   
   =item (Red) CRITICAL: Restarting                         
   
   lond is about to exec itself to restart.
   
   =item (Blue) Updating connections                        
   
   (In response to a USR2).  All the children (except the one for localhost)
   are about to be killed, the hosts tab reread, and Apache reloaded via apachereload.
   
   =item (Blue) UpdateHosts killing child <pid> for ip <ip>   
   
   Due to USR2 as above.
   
   =item (Green) keeping child for ip <ip> (pid = <pid>)    
   
   In response to USR2 as above, the child indicated is not being restarted because
   it's assumed that we'll always need a child for the localhost.
   
   
   =item Going to check on the children                
   
   Parent is about to check on the health of the child processes.
   Note that this is in response to a USR1 sent to the parent lond.
   there may be one or more of the next two messages:
   
   =item <pid> is dead                                 
   
   A child that we have in our child hash as alive has evidently died.
   
   =item  Child <pid> did not respond                   
   
   In the health check the child <pid> did not update/produce a pid_.txt
   file when sent it's USR1 signal.  That process is killed with a 9 signal, as it's
   assumed to be hung in some un-fixable way.
   
   =item Finished checking children                   
   
   Master processs's USR1 processing is cojmplete.
   
   =item (Red) CRITICAL: ------- Starting ------            
   
   (There are more '-'s on either side).  Lond has forked itself off to 
   form a new session and is about to start actual initialization.
   
   =item (Green) Attempting to start child (<client>)       
   
   Started a new child process for <client>.  Client is IO::Socket object
   connected to the child.  This was as a result of a TCP/IP connection from a client.
   
   =item Unable to determine who caller was, getpeername returned nothing
   
   In child process initialization.  either getpeername returned undef or
   a zero sized object was returned.  Processing continues, but in my opinion,
   this should be cause for the child to exit.
   
   =item Unable to determine clientip                  
   
   In child process initialization.  The peer address from getpeername was not defined.
   The client address is stored as "Unavailable" and processing continues.
   
   =item (Yellow) INFO: Connection <ip> <name> connection type = <type>
   
   In child initialization.  A good connectionw as received from <ip>.
   
   =over 2
   
   =item <name> 
   
   is the name of the client from hosts.tab.
   
   =item <type> 
   
   Is the connection type which is either 
   
   =over 2
   
   =item manager 
   
   The connection is from a manager node, not in hosts.tab
   
   =item client  
   
   the connection is from a non-manager in the hosts.tab
   
   =item both
   
   The connection is from a manager in the hosts.tab.
   
   =back
   
   =back
   
   =item (Blue) Certificates not installed -- trying insecure auth
   
   One of the certificate file, key file or
   certificate authority file could not be found for a client attempting
   SSL connection intiation.  COnnection will be attemptied in in-secure mode.
   (this would be a system with an up to date lond that has not gotten a 
   certificate from us).
   
   =item (Green)  Successful local authentication            
   
   A local connection successfully negotiated the encryption key. 
   In this case the IDEA key is in a file (that is hopefully well protected).
   
   =item (Green) Successful ssl authentication with <client>  
   
   The client (<client> is the peer's name in hosts.tab), has successfully
   negotiated an SSL connection with this child process.
   
   =item (Green) Successful insecure authentication with <client>
   
   
   The client has successfully negotiated an  insecure connection withthe child process.
   
   =item (Yellow) Attempted insecure connection disallowed    
   
   The client attempted and failed to successfully negotiate a successful insecure
   connection.  This can happen either because the variable londAllowInsecure is false
   or undefined, or becuse the child did not successfully echo back the challenge
   string.
   
   
   =back
   
   =back
   
   
   =cut

Removed from v.1.296  
changed lines
  Added in v.1.501


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