[BACK]Return to lond CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.336 and 1.480

version 1.336, 2006/07/11 02:28:17 version 1.480, 2011/08/05 04:35:45
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 40  use IO::File; Line 41  use IO::File;
 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 68  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 88  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 %hostname; # DNSname -> ID's mapping.  
 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 142  my @adderrors    = ("ok", Line 141  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 file name does not exist",
        "Destination file name 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 178  sub ResetStatistics { Line 187  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 408  sub isClient { Line 414  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 416  sub ReadManagerTable { Line 423  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 442  sub ReadManagerTable { Line 452  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 503  sub AdjustHostContents { Line 513  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 542  sub AdjustHostContents { Line 551  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 560  sub InstallFile { Line 574  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 572  sub InstallFile { Line 602  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 585  sub ConfigFileFromSelector { Line 617  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 613  sub ConfigFileFromSelector { Line 641  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 629  sub PushFile { Line 660  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 655  sub PushFile { Line 673  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 835  sub AdjustOurHost { Line 874  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 890  sub EditFile { Line 927  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 963  sub read_profile { Line 1000  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++) {
Line 1008  sub ping_handler { Line 1048  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 1034  sub ping_handler { Line 1074  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 1056  sub pong_handler { Line 1096  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 1078  sub establish_key_handler { Line 1118  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 1095  sub establish_key_handler { Line 1135  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 1104  sub establish_key_handler { Line 1144  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 1115  sub load_handler { Line 1157  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 1132  sub load_handler { Line 1174  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 1144  sub load_handler { Line 1186  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 1188  sub user_authorization_type { Line 1230  sub user_authorization_type {
  } else {   } else {
             $type .= ':';              $type .= ':';
         }          }
  &Reply( $replyfd, "$type\n", $userinput);   &Reply( $replyfd, \$type, $userinput);
     }      }
       
     return 1;      return 1;
Line 1210  sub user_authorization_type { Line 1252  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 1218  sub push_file_handler { Line 1260  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 1252  sub push_file_handler { Line 1298  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 1270  sub du_handler { Line 1316  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 1283  sub du_handler { Line 1330  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 1344  sub ls_handler { Line 1455  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 1413  sub ls2_handler { Line 1525  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", \&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 1441  sub reinit_process_handler { Line 1791  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 1525  sub authenticate_handler { Line 1875  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'};
                   }
                   my $loncaparev = $clientversion;
                   if ($loncaparev eq '') {
                       $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
                   }
                   $canhost = &Apache::lonnet::can_host_session($udom,$clientname,
                                                                $loncaparev,
                                                                $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 1576  sub change_password_handler { Line 1962  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 1597  sub change_password_handler { Line 1995  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 1619  sub change_password_handler { Line 2020  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 1670  sub add_user_handler { Line 2074  sub add_user_handler {
     }      }
     unless ($fperror) {      unless ($fperror) {
  my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);   my $result=&make_passwd_file($uname, $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 1739  sub change_authentication_handler { Line 2143  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, $umode,$npass,$passfilename);
Line 1760  sub change_authentication_handler { Line 2164  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 1806  sub is_home_handler { Line 2210  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 1839  sub update_resource_handler { Line 2237  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);   &devalidate_meta_cache($fname);
  unlink("$fname");   unlink("$fname");
  unlink("$fname.meta");   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 1860  sub update_resource_handler { Line 2268  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 1876  sub update_resource_handler { Line 2286  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);      &devalidate_meta_cache($fname);
  }   }
Line 1895  sub devalidate_meta_cache { Line 2306  sub devalidate_meta_cache {
     my ($url) = @_;      my ($url) = @_;
     use Cache::Memcached;      use Cache::Memcached;
     my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});      my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
     $url = &declutter($url);      $url = &Apache::lonnet::declutter($url);
     $url =~ s-\.meta$--;      $url =~ s-\.meta$--;
     my $id = &escape('meta:'.$url);      my $id = &escape('meta:'.$url);
     $memcache->delete($id);      $memcache->delete($id);
 }  }
   
 sub declutter {  
     my $thisfn=shift;  
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;  
     $thisfn=~s/^\///;  
     $thisfn=~s|^adm/wrapper/||;  
     $thisfn=~s|^adm/coursedocs/showdoc/||;  
     $thisfn=~s/^res\///;  
     $thisfn=~s/\?.+$//;  
     return $thisfn;  
 }  
 #  #
 #   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 1947  sub fetch_user_file_handler { Line 2348  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 $remoteurl=$clientprotocol.'://'.$clientip.'/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 2109  sub rename_user_file_handler { Line 2512  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 2124  sub token_auth_user_file_handler { Line 2557  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")) {
  flock(ENVIN,LOCK_SH);   flock(ENVIN,LOCK_SH);
  while (my $line=<ENVIN>) {   tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
     my ($envname)=split(/=/,$line,2);   if (exists($disk_env{"userfile.$fname"})) {
     $envname=&unescape($envname);      $reply="ok";
     if ($envname=~ m|^userfile\.\Q$fname\E|) { $reply="ok\n"; }   } 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 2194  sub subscribe_handler { Line 2634  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 2558  sub get_profile_entry { Line 2998  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 2595  sub get_profile_entry_encrypted { Line 3036  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 2701  sub get_profile_keys { Line 3142  sub get_profile_keys {
  }   }
  if (&untie_user_hash($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 2771  sub dump_profile_database { Line 3212  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 2815  sub dump_with_regexp { Line 3256  sub dump_with_regexp {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);      my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);
     if (defined($regexp)) {      if (defined($regexp)) {
  $regexp=&unescape($regexp);   $regexp=&unescape($regexp);
     } else {      } else {
Line 2833  sub dump_with_regexp { Line 3274  sub dump_with_regexp {
     }      }
     my $hashref = &tie_user_hash($udom, $uname, $namespace,      my $hashref = &tie_user_hash($udom, $uname, $namespace,
  &GDBM_READER());   &GDBM_READER());
       my $skipcheck;
     if ($hashref) {      if ($hashref) {
         my $qresult='';          my $qresult='';
  my $count=0;   my $count=0;
           if ($extra ne '') {
               $extra = &Apache::lonnet::thaw_unescape($extra);
               $skipcheck = $extra->{'skipcheck'};
           }
           my @ids = &Apache::lonnet::current_machine_ids();
           my (%homecourses,$major,$minor,$now);
           if (($namespace eq 'roles') && (!$skipcheck)) {
               my $loncaparev = $clientversion;
               if ($loncaparev eq '') {
                   $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
               }
               if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
                   $major = $1;
                   $minor = $2;
               }
               $now = time;
           }
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
               if ($namespace eq 'roles') {
                   if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) {
                       my $cdom = $1;
                       my $cnum = $2;
                       unless ($skipcheck) {
                           my ($role,$end,$start) = split(/\_/,$value);
                           if (!$end || $end > $now) {
                               next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
                                                               $minor,\%homecourses,\@ids));
                           }
                       }
                   }
               }
     if ($regexp eq '.') {      if ($regexp eq '.') {
  $count++;   $count++;
  if (defined($range) && $count >= $end)   { last; }   if (defined($range) && $count >= $end)   { last; }
Line 2853  sub dump_with_regexp { Line 3325  sub dump_with_regexp {
     }      }
  }   }
  if (&untie_user_hash($hashref)) {   if (&untie_user_hash($hashref)) {
               if (($namespace eq 'roles') && (!$skipcheck)) {
                   if (keys(%homecourses) > 0) {
                       $qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count,
                                                      $range,$start,$end,$major,$minor);
                   }
               }
     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 dump\n", $userinput);       "while attempting dump\n", $userinput);
Line 3040  sub restore_handler { Line 3518  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 $qresult='';      my $qresult='';
     my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());      my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
Line 3062  sub restore_handler { Line 3540  sub restore_handler {
  }   }
  if (&untie_user_hash($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 restore\n", $userinput);      "while attempting restore\n", $userinput);
Line 3143  sub retrieve_chat_handler { Line 3621  sub retrieve_chat_handler {
  $reply.=&escape($_).':';   $reply.=&escape($_).':';
     }      }
     $reply=~s/\:$//;      $reply=~s/\:$//;
     &Reply($client, $reply."\n", $userinput);      &Reply($client, \$reply, $userinput);
   
   
     return 1;      return 1;
Line 3216  sub reply_query_handler { Line 3694  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 3280  sub put_course_id_handler { Line 3758  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 <= $numcurrent) { # flushcourselogs() from pre 2.2                   if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 
Line 3295  sub put_course_id_handler { Line 3790  sub put_course_id_handler {
                     }                      }
                 }                  }
             }              }
     $hashref->{$key}=$courseinfo.':'.$now;              $hashref->{$key}=$courseinfo.':'.$now;
  }   }
  if (&untie_domain_hash($hashref)) {   if (&untie_domain_hash($hashref)) {
     &Reply( $client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
Line 3309  sub put_course_id_handler { Line 3804  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 3341  sub put_course_id_handler { Line 3878  sub put_course_id_handler {
 #                            owner matches the supplied username and/or domain  #                            owner matches the supplied username and/or domain
 #                            will be returned. Pre-2.2.0 legacy entries from   #                            will be returned. Pre-2.2.0 legacy entries from 
 #                            nohist_courseiddump will only contain usernames.  #                            nohist_courseiddump will only contain usernames.
   #                 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 3348  sub put_course_id_handler { Line 3918  sub put_course_id_handler {
 #   a reply is written to $client.  #   a reply is written to $client.
 sub dump_course_id_handler {  sub dump_course_id_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
         $typefilter) =split(/:/,$tail);          $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 3389  sub dump_course_id_handler { Line 3962  sub dump_course_id_handler {
     } else {      } else {
         $typefilter='.';          $typefilter='.';
     }      }
       if (defined($regexp_ok)) {
     unless (defined($since)) { $since=0; }          $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 '.' && $coursefilter 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,$type);              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,$type)=@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) {
                       $unesc_val{'owner'} = &unescape($val{'owner'});
                   }
                 if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {                  if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
                     if ($unescapeOwner =~ /:/) {                      if ($unesc_val{'owner'} =~ /:/) {
                         if (eval('$unescapeOwner !~                           if (eval{$unesc_val{'owner'} !~ 
                              /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i')) {                               /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
                             $match = 0;                              $match = 0;
                         }                           } 
                     } else {                      } else {
                         if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {                          if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                             $match = 0;                              $match = 0;
                         }                          }
                     }                      }
                 } elsif ($ownerunamefilter ne '') {                  } elsif ($ownerunamefilter ne '') {
                     if ($unescapeOwner =~ /:/) {                      if ($unesc_val{'owner'} =~ /:/) {
                         if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E:[^:]+$/i')) {                          if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
                              $match = 0;                               $match = 0;
                         }                          }
                     } else {                      } else {
                         if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {                          if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                             $match = 0;                              $match = 0;
                         }                          }
                     }                      }
                 } elsif ($ownerdomfilter ne '') {                  } elsif ($ownerdomfilter ne '') {
                     if ($unescapeOwner =~ /:/) {                      if ($unesc_val{'owner'} =~ /:/) {
                         if (eval('$unescapeOwner!~/^[^:]+:\Q$ownerdomfilter\E/')) {                          if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
                              $match = 0;                               $match = 0;
                         }                          }
                     } else {                      } else {
Line 3448  sub dump_course_id_handler { Line 4204  sub dump_course_id_handler {
                     }                      }
                 }                  }
             }              }
             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;
                 }                  }
             }              }
             unless ($typefilter eq '.' || !defined($typefilter)) {              if ($typefilter ne '.') {
                 my $unescapeType = &unescape($type);                  if (!$is_hash) {
                 if (!defined($type)) {                      $unesc_val{'type'} = &unescape($val{'type'});
                   }
                   if ($unesc_val{'type'} eq '') {
                     if ($typefilter ne 'Course') {                      if ($typefilter ne 'Course') {
                         $match = 0;                          $match = 0;
                     }                      }
                 } else {                   } else {
                     unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) {                      if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
                         $match = 0;                          $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_domain_hash($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 3481  sub dump_course_id_handler { Line 4265  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 3570  sub get_id_handler { Line 4492  sub get_id_handler {
  }   }
  if (&untie_domain_hash($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 3604  sub get_id_handler { Line 4526  sub get_id_handler {
 sub put_dcmail_handler {  sub put_dcmail_handler {
     my ($cmd,$tail,$client) = @_;      my ($cmd,$tail,$client) = @_;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
                                                                                   
   
     my ($udom,$what)=split(/:/,$tail);      my ($udom,$what)=split(/:/,$tail);
     chomp($what);      chomp($what);
     my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
Line 3694  sub dump_dcmail_handler { Line 4617  sub dump_dcmail_handler {
         }          }
         if (&untie_domain_hash($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 dcmaildump\n", $userinput);                      "while attempting dcmaildump\n", $userinput);
Line 3793  sub dump_domainroles_handler { Line 4716  sub dump_domainroles_handler {
         $rolesfilter=&unescape($rolesfilter);          $rolesfilter=&unescape($rolesfilter);
  @roles = split(/\&/,$rolesfilter);   @roles = split(/\&/,$rolesfilter);
     }      }
                                                                                              
     my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
         my $qresult = '';          my $qresult = '';
         while (my ($key,$value) = each(%$hashref)) {          while (my ($key,$value) = each(%$hashref)) {
             my $match = 1;              my $match = 1;
             my ($start,$end) = split(/:/,&unescape($value));              my ($end,$start) = split(/:/,&unescape($value));
             my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));              my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
             unless ($startfilter eq '.' || !defined($startfilter)) {              unless (@roles < 1) {
                 if ($start >= $startfilter) {                  unless (grep/^\Q$trole\E$/,@roles) {
                     $match = 0;                      $match = 0;
                       next;
                 }                  }
             }              }
             unless ($endfilter eq '.' || !defined($endfilter)) {              unless ($startfilter eq '.' || !defined($startfilter)) {
                 if ($end <= $endfilter) {                  if ((defined($start)) && ($start >= $startfilter)) {
                     $match = 0;                      $match = 0;
                       next;
                 }                  }
             }              }
             unless (@roles < 1) {              unless ($endfilter eq '.' || !defined($endfilter)) {
                 unless (grep/^$trole$/,@roles) {                  if ((defined($end)) && (($end > 0) && ($end <= $endfilter))) {
                     $match = 0;                      $match = 0;
                       next;
                 }                  }
             }              }
             if ($match == 1) {              if ($match == 1) {
Line 3822  sub dump_domainroles_handler { Line 4748  sub dump_domainroles_handler {
         }          }
         if (&untie_domain_hash($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 domrolesdump\n", $userinput);                      "while attempting domrolesdump\n", $userinput);
Line 3858  sub tmp_put_handler { Line 4784  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 3902  sub tmp_get_handler { Line 4836  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 4083  sub enrollment_enabled_handler { Line 5017  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) = 
           &localenroll::validate_instcode($dom,$instcode,$owner);
       my $result = &escape($outcome).'&'.&escape($description);
       &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 4112  sub get_sections_handler { Line 5084  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 4137  sub get_sections_handler { Line 5109  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);
       
     $owner = &unescape($owner);      $owner = &unescape($owner);
     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);      $coowners = &unescape($coowners);
     &Reply($client, "$outcome\n", $userinput);      my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);
       &Reply($client, \$outcome, $userinput);
   
   
   
Line 4172  sub validate_course_section_handler { Line 5145  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 4180  sub validate_course_section_handler { Line 5153  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 4263  sub retrieve_auto_file_handler { Line 5267  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 4296  sub get_institutional_code_format_handle Line 5355  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 4316  sub get_institutional_code_format_handle Line 5375  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  # Get domain specific conditions for import of student photographs to a course
 #  #
 # Retrieves information from photo_permission subroutine in localenroll.  # Retrieves information from photo_permission subroutine in localenroll.
Line 4443  sub student_photo_handler { Line 5756  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 4706  sub catchexception { Line 6048  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 4759  if (-e $pidfile) { Line 6101  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 4817  sub HUPSMAN {                      # sig Line 6159  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.   
     $hostname{$id}=$name;     # LonCAPA name -> DNS name  
     $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 4908  sub UpdateHosts { Line 6193  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 4999  sub Debug { Line 6283  sub Debug {
 #  #
 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 5054  sub logstatus { Line 6343  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 5074  sub status { Line 6363  sub status {
     $0='lond: '.$what.' '.$local;      $0='lond: '.$what.' '.$local;
 }  }
   
 # ----------------------------------------------------------- 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'}/".$hostname{$server};  
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",  
                                       Type    => SOCK_STREAM,  
                                       Timeout => 10)  
        or return "con_lost";  
     print $sclient "sethost:$server:$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'}/".$hostname{$server});  
         }  
         $answer=subreply($cmd,$server);  
     }  
   } else {  
     $answer='self_reply';  
   }   
   return $answer;  
 }  
   
 # -------------------------------------------------------------- Talk to lonsql  # -------------------------------------------------------------- Talk to lonsql
   
 sub sql_reply {  sub sql_reply {
Line 5199  $SIG{USR1} = \&checkchildren; Line 6431  $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 5261  sub make_new_child { Line 6500  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 5269  sub make_new_child { Line 6509  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 5279  sub make_new_child { Line 6526  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();
  unless (($dist eq 'fedora4') || ($dist eq 'suse9.3')) {   unless (($dist eq 'fedora5') || ($dist eq 'fedora4') ||  
    ($dist eq 'fedora6') || ($dist eq 'suse9.3')) {
     &Authen::Krb5::init_ets();      &Authen::Krb5::init_ets();
  }   }
   
Line 5289  sub make_new_child { Line 6537  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 5320  sub make_new_child { Line 6566  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);   (my $i, my $inittype, $clientversion) = split(/:/, $remotereq);
   
  # 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 5346  sub make_new_child { Line 6592  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 5353  sub make_new_child { Line 6600  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 5408  sub make_new_child { Line 6655  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'}/".$hostname{$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 5580  sub rewrite_password_file { Line 6825  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 5618  sub get_auth_type Line 6861  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 5642  sub validate_user { Line 6884  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 5665  sub validate_user { Line 6920  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 5726  sub validate_user { Line 6968  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 5939  sub subscribe { Line 7239  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 5982  sub change_unix_password { Line 7284  sub change_unix_password {
   
 sub make_passwd_file {  sub make_passwd_file {
     my ($uname, $umode,$npass,$passfilename)=@_;      my ($uname, $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 6050  sub make_passwd_file { Line 7352  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 6074  sub make_passwd_file { Line 7376  sub make_passwd_file {
     }      }
  }   }
     } else {      } else {
  $result="auth_mode_error\n";   $result="auth_mode_error";
     }      }
     return $result;      return $result;
 }  }
Line 6093  sub sethost { Line 7395  sub sethost {
     }      }
   
     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 6111  sub version { Line 7414  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'};  sub releasereqd_check {
     if ($maxuserload) {      my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
  $userloadpercent=100*$numusers/$maxuserload;      my $home = &Apache::lonnet::homeserver($cnum,$cdom);
     }      return if ($home eq 'no_host');
     $userloadpercent=sprintf("%.2f",$userloadpercent);      my ($reqdmajor,$reqdminor,$displayrole);
     return $userloadpercent;      if ($cnum =~ /$LONCAPA::match_community/) {
 }          if ($major eq '' && $minor eq '') {
               return unless ((ref($ids) eq 'ARRAY') && 
 # Routines for serializing arrays and hashes (copies from lonnet)                             (grep(/^\Q$home\E$/,@{$ids})));
           } else {
 sub array2str {              $reqdmajor = 2;
   my (@array) = @_;              $reqdminor = 9;
   my $result=&arrayref2str(\@array);              return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
   $result=~s/^__ARRAY_REF__//;          }
   $result=~s/__END_ARRAY_REF__$//;      }
   return $result;      my $hashid = $cdom.':'.$cnum;
 }      my ($courseinfo,$cached) =
                                                                                            &Apache::lonnet::is_cached_new('courseinfo',$hashid);
 sub arrayref2str {      if (defined($cached)) {
   my ($arrayref) = @_;          if (ref($courseinfo) eq 'HASH') {
   my $result='__ARRAY_REF__';              if (exists($courseinfo->{'releaserequired'})) {
   foreach my $elem (@$arrayref) {                  my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
     if(ref($elem) eq 'ARRAY') {                  return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
       $result.=&arrayref2str($elem).'&';              }
     } elsif(ref($elem) eq 'HASH') {          }
       $result.=&hashref2str($elem).'&';      } else {
     } elsif(ref($elem)) {          if (ref($ids) eq 'ARRAY') {
       #print("Got a ref of ".(ref($elem))." skipping.");              if (grep(/^\Q$home\E$/,@{$ids})) {
     } else {                  if (ref($homecourses) eq 'HASH') {
       $result.=&escape($elem).'&';                      if (ref($homecourses->{$hashid}) eq 'ARRAY') {
     }                          push(@{$homecourses->{$hashid}},{$key=>$value});
   }                      } else {
   $result=~s/\&$//;                          $homecourses->{$hashid} = [{$key=>$value}];
   $result .= '__END_ARRAY_REF__';                      }
   return $result;                  }
 }                  return;
                                                                                                }
 sub hash2str {          }
   my (%hash) = @_;          my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
   my $result=&hashref2str(\%hash);          if (ref($courseinfo) eq 'HASH') {
   $result=~s/^__HASH_REF__//;              if (exists($courseinfo->{'releaserequired'})) {
   $result=~s/__END_HASH_REF__$//;                  my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
   return $result;                  return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
 }              }
                                                                                            } else {
 sub hashref2str {              return;
   my ($hashref)=@_;          }
   my $result='__HASH_REF__';      }
   foreach (sort(keys(%$hashref))) {      return 1;
     if (ref($_) eq 'ARRAY') {  }
       $result.=&arrayref2str($_).'=';  
     } elsif (ref($_) eq 'HASH') {  sub get_courseinfo_hash {
       $result.=&hashref2str($_).'=';      my ($cnum,$cdom,$home) = @_;
     } elsif (ref($_)) {      my %info;
       $result.='=';      eval {
       #print("Got a ref of ".(ref($_))." skipping.");          local($SIG{ALRM}) = sub { die "timeout\n"; };
     } else {          local($SIG{__DIE__})='DEFAULT';
         if ($_) {$result.=&escape($_).'=';} else { last; }          alarm(3);
     }          %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
           alarm(0);
     if(ref($hashref->{$_}) eq 'ARRAY') {      };
       $result.=&arrayref2str($hashref->{$_}).'&';      if ($@) {
     } elsif(ref($hashref->{$_}) eq 'HASH') {          if ($@ eq "timeout\n") {
       $result.=&hashref2str($hashref->{$_}).'&';              &logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
     } elsif(ref($hashref->{$_})) {          } else {
        $result.='&';              &logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
       #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");          }
     } else {      } else {
       $result.=&escape($hashref->{$_}).'&';          if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
     }              my $hashid = $cdom.':'.$cnum;
   }              return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
   $result=~s/\&$//;          }
   $result .= '__END_HASH_REF__';      }
   return $result;      return;
   }
   
   sub check_homecourses {
       my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
       my ($result,%addtocache);
       my $yesterday = time - 24*3600; 
       if (ref($homecourses) eq 'HASH') {
           my (%okcourses,%courseinfo,%recent);
           my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
           if ($hashref) {
               while (my ($key,$value) = each(%$hashref)) {
                   my $unesc_key = &unescape($key);
                   if ($unesc_key =~ /^lasttime:(\w+)$/) {
                       my $cid = $1;
                       $cid =~ s/_/:/;
                       if ($value > $yesterday ) {
                           $recent{$cid} = 1;
                       }
                       next;
                   }
                   my $items = &Apache::lonnet::thaw_unescape($value);
                   if (ref($items) eq 'HASH') {
                       my $hashid = $unesc_key;
                       $hashid =~ s/_/:/;
                       $courseinfo{$hashid} = $items;
                       if (ref($homecourses->{$hashid}) eq 'ARRAY') {
                           my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
                           if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
                               $okcourses{$hashid} = 1;
                           }
                       }
                   }
               }
               unless (&untie_domain_hash($hashref)) {
                   &logthis('Failed to untie tied hash for nohist_courseids.db');
               }
           } else {
               &logthis('Failed to tie hash for nohist_courseids.db');
               return;
           }
           foreach my $hashid (keys(%recent)) {
               my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
               unless ($cached) {
                   &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
               }
           }
           foreach my $hashid (keys(%{$homecourses})) {
               next if ($recent{$hashid});
               &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
           }
           foreach my $hashid (keys(%okcourses)) {
               if (ref($homecourses->{$hashid}) eq 'ARRAY') {
                   foreach my $role (@{$homecourses->{$hashid}}) {
                       if (ref($role) eq 'HASH') {
                           while (my ($key,$value) = each(%{$role})) {
                               if ($regexp eq '.') {
                                   $count++;
                                   if (defined($range) && $count >= $end)   { last; }
                                   if (defined($range) && $count <  $start) { next; }
                                   $result.=$key.'='.$value.'&';
                               } else {
                                   my $unescapeKey = &unescape($key);
                                   if (eval('$unescapeKey=~/$regexp/')) {
                                       $count++;
                                       if (defined($range) && $count >= $end)   { last; }
                                       if (defined($range) && $count <  $start) { next; }
                                       $result.="$key=$value&";
                                   }
                               }
                           }
                       }
                   }
               }
           }
       }
       return $result;
   }
   
   sub useable_role {
       my ($reqdmajor,$reqdminor,$major,$minor) = @_; 
       if ($reqdmajor ne '' && $reqdminor ne '') {
           return if (($major eq '' && $minor eq '') ||
                      ($major < $reqdmajor) ||
                      (($major == $reqdmajor) && ($minor < $reqdminor)));
       }
       return 1;
   }
   
   sub distro_and_arch {
       return $dist.':'.$arch;
 }  }
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
Line 6535  linux Line 7928  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.336  
changed lines
  Added in v.1.480

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