Diff for /loncom/lond between versions 1.163 and 1.178.2.2

version 1.163, 2003/11/17 09:32:17 version 1.178.2.2, 2004/02/23 10:25:52
Line 10 Line 10
 #  #
 # LON-CAPA is free software; you can redistribute it and/or modify  # LON-CAPA is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by  # it under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 2 of the License, or  # the Free Software Foundation; either version 2 of the License, or 
 # (at your option) any later version.  # (at your option) any later version.
 #  #
 # LON-CAPA is distributed in the hope that it will be useful,  # LON-CAPA is distributed in the hope that it will be useful,
Line 20 Line 20
 #  #
 # You should have received a copy of the GNU General Public License  # You should have received a copy of the GNU General Public License
 # along with LON-CAPA; if not, write to the Free Software  # along with LON-CAPA; if not, write to the Free Software
 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA  # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA    
 #  #
 # /home/httpd/html/adm/gpl.txt  # /home/httpd/html/adm/gpl.txt
 #  #
Line 46  use Authen::Krb5; Line 46  use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use localauth;  use localauth;
 use File::Copy;  use File::Copy;
   use LONCAPA::ConfigFileEdit;
   
 my $DEBUG = 0;       # Non zero to enable debug log entries.  my $DEBUG = 1;       # Non zero to enable debug log entries.
   
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
Line 61  my $client; Line 62  my $client;
 my $clientip;  my $clientip;
 my $clientname;  my $clientname;
   
   my $cipher; # Cipher key negotiated with client.
   my $tmpsnum = 0;; # Id of tmpputs.
   
 my $server;  my $server;
 my $thisserver;  my $thisserver;
   
Line 82  my %managers;   # Ip -> manager names Line 86  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.
   
 #  #
   #   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:
   #          A reference to a sub that executes the request corresponding to the keyword.
   #          A flag that is true if the request must be encoded to be acceptable.
   #          A mask with bits as follows:
   #                      CLIENT_OK    - Set when the function is allowed by ordinary clients
   #                      MANAGER_OK   - Set when the function is allowed to manager clients.
   #
   my $CLIENT_OK  = 1;
   my $MANAGER_OK = 2;
   my %Dispatcher;
   
   #
 #  The array below are password error strings."  #  The array below are password error strings."
 #  #
 my $lastpwderror    = 13; # Largest error number from lcpasswd.  my $lastpwderror    = 13; # Largest error number from lcpasswd.
Line 118  my @adderrors    = ("ok", Line 135  my @adderrors    = ("ok",
     "lcuseradd Could not add user.",      "lcuseradd Could not add user.",
     "lcuseradd Password mismatch");      "lcuseradd Password mismatch");
   
   #
   #   Statistics that are maintained and dislayed in the status line.
   #
   my $Transactions; # Number of attempted transactions.
   my $Failures; # Number of transcations failed.
   
   #   ResetStatistics: 
   #      Resets the statistics counters:
   #
   sub ResetStatistics {
       $Transactions = 0;
       $Failures     = 0;
   }
   
   #
   #   Return true if client is a manager.
   #
   sub isManager {
       return (($ConnectionType eq "manager") || ($ConnectionType eq "both"));
   }
   #
   #   Return tru if client can do client functions
   #
   sub isClient {
       return (($ConnectionType eq "client") || ($ConnectionType eq "both"));
   }
   
   
   #
   #   Get a Request:
   #   Gets a Request message from the client.  The transaction
   #   is defined as a 'line' of text.  We remove the new line
   #   from the text line.  
   #   
   sub GetRequest {
       my $input = <$client>;
       chomp($input);
   
       Debug("Request = $input\n");
   
       &status('Processing '.$clientname.':'.$input);
   
       return $input;
   }
   #
   #   Decipher encoded traffic
   #  Parameters:
   #     input      - Encoded data.
   #  Returns:
   #     Decoded data or undef if encryption key was not yet negotiated.
   #  Implicit input:
   #     cipher  - This global holds the negotiated encryption key.
   #
   sub Decipher {
      my $input  = shift;
      my $output = '';
      
      
      if($cipher) {
         my($enc, $enclength, $encinput) = split(/:/, $input);
         for(my $encidx = 0; $encidx < length($encinput); $encidx += 16) {
            $output .= 
               $cipher->decrypt(pack("H16", substr($encinput, $encidx, 16)));
         }
         return substr($output, 0, $enclength);
      } else {
         return undef;
      }
      
   }
   
   #
   #   Register a command processor.  This function is invoked to register a sub
   #   to process a request.  Once registered, the ProcessRequest sub can automatically
   #   dispatch requests to an appropriate sub, and do the top level validity checking
   #   as well:
   #    - Is the keyword recognized.
   #    - Is the proper client type attempting the request.
   #    - Is the request encrypted if it has to be.
   #   Parameters:
   #    $RequestName         - Name of the request being registered.
   #                           This is the command request that will match
   #                           against the hash keywords to lookup the information
   #                           associated with the dispatch information.
   #    $Procedure           - Reference to a sub to call to process the request.
   #                           All subs get called as follows:
   #                             Procedure($cmd, $tail, $replyfd, $key)
   #                             $cmd    - the actual keyword that invoked us.
   #                             $tail   - the tail of the request that invoked us.
   #                             $replyfd- File descriptor connected to the client
   #    $MustEncode          - True if the request must be encoded to be good.
   #    $ClientOk            - True if it's ok for a client to request this.
   #    $ManagerOk           - True if it's ok for a manager to request this.
   # Side effects:
   #      - On success, the Dispatcher hash has an entry added for the key $RequestName
   #      - On failure, the program will die as it's a bad internal bug to try to 
   #        register a duplicate command handler.
   #
   sub RegisterHandler {
      my $RequestName    = shift;
      my $Procedure      = shift;
      my $MustEncode     = shift;
      my $ClientOk       = shift;
      my $ManagerOk      = shift;
      
      #  Don't allow duplication#
      
      if (defined $Dispatcher{$RequestName}) {
         die "Attempting to define a duplicate request handler for $RequestName\n";
      }
      #   Build the client type mask:
      
      my $ClientTypeMask = 0;
      if($ClientOk) {
         $ClientTypeMask  |= $CLIENT_OK;
      }
      if($ManagerOk) {
         $ClientTypeMask  |= $MANAGER_OK;
      }
      
      #  Enter the hash:
         
      my @entry = ($Procedure, $MustEncode, $ClientTypeMask);
      
      $Dispatcher{$RequestName} = \@entry;
      
      
   }
   
   #--------------------- Request Handlers --------------------------------------------
   #
   #   By convention each request handler registers itself prior to the sub declaration:
   #
   
   #  Handles ping requests.
   #  Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host we are
   #                       known as.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Side effects:
   #      Reply information is sent to the client.
   
   sub PingHandler {
      my $cmd    = shift;
      my $tail   = shift;
      my $client = shift;
      
      Reply( $client,"$currenthostid\n","$cmd:$tail");
      
      return 1;
   }
   RegisterHandler("ping", \&PingHandler, 0, 1, 1);       # Ping unencoded, client or manager.
   #
   # Handles pong reequests:
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host we are
   #                       connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Side effects:
   #      Reply information is sent to the client.
   
   sub PongHandler {
      my $cmd     = shift;
      my $tail    = shift;
      my $replyfd = shift;
   
      my $reply=&reply("ping",$clientname);
      Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); 
      return 1;
   }
   RegisterHandler("pong", \&PongHandler, 0, 1, 1);       # Pong unencoded, client or manager
   
   #
   #   EstablishKeyHandler:
   #      Called to establish an encrypted session key with the remote client.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host
   #                       known as.
   #      $clientname    - Global variable that carries the name of the hsot we're connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Implicit Outputs:
   #      Reply information is sent to the client.
   #      $cipher is set with a reference to a new IDEA encryption object.
   #
   sub EstablishKeyHandler {
      my $cmd      = shift;
      my $tail     = shift;
      my $replyfd  = shift;
   
      my $buildkey=time.$$.int(rand 100000);
      $buildkey=~tr/1-6/A-F/;
      $buildkey=int(rand 100000).$buildkey.int(rand 100000);
      my $key=$currenthostid.$clientname;
      $key=~tr/a-z/A-Z/;
      $key=~tr/G-P/0-9/;
      $key=~tr/Q-Z/0-9/;
      $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;
      $key=substr($key,0,32);
      my $cipherkey=pack("H32",$key);
      $cipher=new IDEA $cipherkey;
      Reply($replyfd, "$buildkey\n", "$cmd:$tail"); 
      
      return 1;
   
   }
   RegisterHandler("ekey", \&EstablishKeyHandler, 0, 1,1);
   
   #  LoadHandler:
   #     Handler for the load command.  Returns the current system load average
   #     to the requestor.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host
   #                       known as.
   #      $clientname    - Global variable that carries the name of the hsot we're connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit.
   #  Side effects:
   #      Reply information is sent to the client.
   sub LoadHandler {
      my $cmd     = shift;
      my $tail    = shift;
      my $replyfd = shift;
   
      # 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
   
      my $loadavg;
      my $loadfile=IO::File->new('/proc/loadavg');
      
      $loadavg=<$loadfile>;
      $loadavg =~ s/\s.*//g;                       # Extract the first field only.
      
      my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
   
      Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");
      
      return 1;
   }
   RegisterHandler("load", \&LoadHandler, 0, 1, 0);
   
   
   #
   #   Process the userload request.  This sub returns to the client the current
   #  user load average.  It can be invoked either by clients or managers.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Implicit Inputs:
   #      $currenthostid - Global variable that carries the name of the host
   #                       known as.
   #      $clientname    - Global variable that carries the name of the hsot we're connected to.
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   # Implicit inputs:
   #     whatever the userload() function requires.
   #  Implicit outputs:
   #     the reply is written to the client.
   #
   sub UserLoadHandler {
      my $cmd     = shift;
      my $tail    = shift;
      my $replyfd = shift;
   
      my $userloadpercent=&userload();
      Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");
   
      return 1;
   }
   RegisterHandler("userload", \&UserLoadHandler, 0, 1, 0);
   
   #   Process a request for the authorization type of a user:
   #   (userauth).
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $replyfd- File descriptor connected to the client
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   # Implicit outputs:
   #    The user authorization type is written to the client.
   #
   sub UserAuthorizationType {
      my $cmd     = shift;
      my $tail    = shift;
      my $replyfd = shift;
      
      my $userinput = "$cmd:$tail";
      
      #  Pull the domain and username out of the command tail.
      # and call GetAuthType to determine the authentication type.
      
      my ($udom,$uname)=split(/:/,$tail);
      my $result = GetAuthType($udom, $uname);
      if($result eq "nouser") {
         Failure( $replyfd, "unknown_user\n", $userinput);
      } else {
         Reply( $replyfd, "$result\n", $userinput);
      }
     
      return 1;
   }
   RegisterHandler("currentauth", \&UserAuthorizationType, 1, 1, 0);
   #
   #   Process a request by a manager to push a hosts or domain table 
   #   to us.  We pick apart the command and pass it on to the subs
   #   that already exist to do this.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $client - File descriptor connected to the client
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   # Implicit Output:
   #    a reply is written to the client.
   
   sub PushFileHandler {
      my $cmd    = shift;
      my $tail   = shift;
      my $client = shift;
   
      my $userinput = "$cmd:$tail";
   
      # At this time we only know that the IP of our partner is a valid manager
      # the code below is a hook to do further authentication (e.g. to resolve
      # spoofing).
   
      my $cert = GetCertificate($userinput);
      if(ValidManager($cert)) { 
   
         # Now presumably we have the bona fides of both the peer host and the
         # process making the request.
         
         my $reply = PushFile($userinput);
         Reply($client, "$reply\n", $userinput);
   
      } else {
         Failure( $client, "refused\n", $userinput);
      } 
   }
   RegisterHandler("pushfile", \&PushFileHandler, 1, 0, 1);
   
   
   
   #   Process a reinit request.  Reinit requests that either
   #   lonc or lond be reinitialized so that an updated 
   #   host.tab or domain.tab can be processed.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $client - File descriptor connected to the client
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   #  Implicit output:
   #     a reply is sent to the client.
   #
   sub ReinitProcessHandler {
      my $cmd    = shift;
      my $tail   = shift;
      my $client = shift;
      
      my $userinput = "$cmd:$tail";
      
      my $cert = GetCertificate($userinput);
      if(ValidManager($cert)) {
         chomp($userinput);
         my $reply = ReinitProcess($userinput);
         Reply( $client,  "$reply\n", $userinput);
      } else {
         Failure( $client, "refused\n", $userinput);
    }
      return 1;
   }
   
   RegisterHandler("reinit", \&ReinitProcessHandler, 1, 0, 1);
   
   #  Process the editing script for a table edit operation.
   #  the editing operation must be encrypted and requested by
   #  a manager host.
   #
   # Parameters:
   #      $cmd    - the actual keyword that invoked us.
   #      $tail   - the tail of the request that invoked us.
   #      $client - File descriptor connected to the client
   #  Returns:
   #      1       - Ok to continue processing.
   #      0       - Program should exit
   #  Implicit output:
   #     a reply is sent to the client.
   #
   sub EditTableHandler {
      my $command    = shift;
      my $tail       = shift;
      my $client     = shift;
      
      my $userinput = "$command:$tail";
   
      my $cert = GetCertificate($userinput);
      if(ValidManager($cert)) {
         my($filetype, $script) = split(/:/, $tail);
         if (($filetype eq "hosts") || 
             ($filetype eq "domain")) {
            if($script ne "") {
               Reply($client,            # BUGBUG - EditFile
                     EditFile($userinput), #   could fail.
                     $userinput);
            } else {
               Failure($client,"refused\n",$userinput);
            }
         } else {
            Failure($client,"refused\n",$userinput);
         }
      } else {
         Failure($client,"refused\n",$userinput);
      }
      return 1;
   }
   RegisterHandler("edit", \&EditTableHandler, 1, 0, 1);
   
   
   #
   #   Authenticate a user against the LonCAPA authentication
   #   database.  Note that there are several authentication
   #   possibilities:
   #   - unix     - The user can be authenticated against the unix
   #                password file.
   #   - internal - The user can be authenticated against a purely 
   #                internal per user password file.
   #   - kerberos - The user can be authenticated against either a kerb4 or kerb5
   #                ticket granting authority.
   #   - user     - The person tailoring LonCAPA can supply a user authentication mechanism
   #                that is per system.
   #
   # 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.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub AuthenticateHandler {
      my $cmd        = shift;
      my $tail       = shift;
      my $client     = shift;
      
      #  Regenerate the full input line 
      
      my $userinput  = $cmd.":".$tail;
   
      #  udom    - User's domain.
      #  uname   - Username.
      #  upass   - User's password.
      
      my ($udom,$uname,$upass)=split(/:/,$tail);
      Debug(" Authenticate domain = $udom, user = $uname, password = $upass");
      chomp($upass);
      $upass=unescape($upass);
      my $proname=propath($udom,$uname);
      my $passfilename="$proname/passwd";
      
      #   The user's 'personal' loncapa passworrd file describes how to authenticate:
      
      if (-e $passfilename) {
        Debug("Located password file: $passfilename");
   
         my $pf = IO::File->new($passfilename);
         my $realpasswd=<$pf>;
         chomp($realpasswd);
         my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
         my $pwdcorrect=0;
         #
         #   Authenticate against password stored in the internal file.
         #
        Debug("Authenticating via $howpwd");
         if ($howpwd eq 'internal') {
            &Debug("Internal auth");
            $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);
         #
         #   Authenticate against the unix password file.
         #
         } elsif ($howpwd eq 'unix') {
            &Debug("Unix auth");
            if((getpwnam($uname))[1] eq "") { #no such user!
               $pwdcorrect = 0;
            } else {
               $contentpwd=(getpwnam($uname))[1];
               my $pwauth_path="/usr/local/sbin/pwauth";
               unless ($contentpwd eq 'x') {
                  $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);
               } elsif (-e $pwauth_path) {
                  open PWAUTH, "|$pwauth_path" or
                     die "Cannot invoke authentication";
                  print PWAUTH "$uname\n$upass\n";
                  close PWAUTH;
                  $pwdcorrect=!$?;
               }
            }
         #
         #   Authenticate against a Kerberos 4 server:
         #
         } elsif ($howpwd eq 'krb4') {
            my $null=pack("C",0);
            unless ($upass=~/$null/) {
               my $krb4_error = &Authen::Krb4::get_pw_in_tkt($uname,
                                                             "",
                                                             $contentpwd,
                                                             'krbtgt',
                                                            $contentpwd,
                                                            1,
                                                            $upass);
               if (!$krb4_error) {
                  $pwdcorrect = 1;
               } else { 
                  $pwdcorrect=0; 
                  # log error if it is not a bad password
                  if ($krb4_error != 62) {
                     &logthis('krb4:'.$uname.','.$contentpwd.','.
                              &Authen::Krb4::get_err_txt($Authen::Krb4::error));
                  }
               }
            }
         #
         #   Authenticate against a Kerberos 5 server:
         #
         } elsif ($howpwd eq 'krb5') {
            my $null=pack("C",0);
            unless ($upass=~/$null/) {
               my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$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,
                                                                       $upass,
                                                                       $credentials);
               $pwdcorrect = ($krbreturn == 1);
            } else { 
               $pwdcorrect=0; 
            }
         #
         #  Finally, the user may have written in an authentication module.
         #  in that case, if requested, authenticate against it.
         #
         } elsif ($howpwd eq 'localauth') {
            $pwdcorrect=&localauth::localauth($uname,$upass,$contentpwd);
         }
         #
         #   Successfully authorized.
         #
         if ($pwdcorrect) {
            Reply( $client, "authorized\n", $userinput);
         #
         #  Bad credentials: Failed to authorize
         #
         } else {
            Failure( $client, "non_authorized\n", $userinput);
         }
      #
      #  User bad... note it may be bad security practice to differntiate to the
      #  caller a bad user from a  bad passwd... since that supplies covert channel
      #  information (you have a good user but bad password e.g.) to guessers.
      #
      } else {
         Failure( $client, "unknown_user\n", $userinput);
      }
      return 1;
   }
   RegisterHandler("auth", \&AuthenticateHandler, 1, 1, 0);
   
   #
   #   Change a user's password.  Note that this function is complicated by
   #   the fact that a user may be authenticated in more than one way:
   #   At present, we are not able to change the password for all types of
   #   authentication methods.  Only for:
   #      unix    - unix password or shadow passoword style authentication.
   #      local   - Locally written authentication mechanism.
   #   For now, kerb4 and kerb5 password changes are not supported and result
   #   in an error.
   # FUTURE WORK:
   #    Support kerberos passwd changes?
   # 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.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   sub ChangePasswordHandler {
      my $cmd     = shift;
      my $tail    = shift;
      my $client  = shift;
      
      my $userinput = $cmd.":".$tail;           # Reconstruct client's string.
   
      #
      #  udom  - user's domain.
      #  uname - Username.
      #  upass - Current password.
      #  npass - New password.
      
      my ($udom,$uname,$upass,$npass)=split(/:/,$tail);
      chomp($npass);
      $upass=&unescape($upass);
      $npass=&unescape($npass);
      &Debug("Trying to change password for $uname");
      my $proname=propath($udom,$uname);
      my $passfilename="$proname/passwd";
      if (-e $passfilename) {
         my $realpasswd;
         { 
            my $pf = IO::File->new($passfilename);
            $realpasswd=<$pf>; 
         }
         chomp($realpasswd);
         my ($howpwd,$contentpwd)=split(/:/,$realpasswd);
         if ($howpwd eq 'internal') {
            &Debug("internal auth");
            if (crypt($upass,$contentpwd) eq $contentpwd) {
               my $salt=time;
               $salt=substr($salt,6,2);
               my $ncpass=crypt($npass,$salt);
                  {
                     my $pf = IO::File->new(">$passfilename");
                     if ($pf) {
                        print $pf "internal:$ncpass\n";
                        &logthis("Result of password change for "
                                 ."$uname: pwchange_success");
                        Reply($client, "ok\n", $userinput);
                     } else {
                        &logthis("Unable to open $uname passwd "               
                                 ."to change password");
                        Failure( $client, "non_authorized\n",$userinput);
                     }
                  }             
            } else {
               Failure($client, "non_authorized\n", $userinput);
            }
         } elsif ($howpwd eq 'unix') {
            # Unix means we have to access /etc/password
            # one way or another.
            # First: Make sure the current password is
            #        correct
            &Debug("auth is unix");
            $contentpwd=(getpwnam($uname))[1];
            my $pwdcorrect = "0";
            my $pwauth_path="/usr/local/sbin/pwauth";
            unless ($contentpwd eq 'x') {
               $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd);
            } elsif (-e $pwauth_path) {
               open PWAUTH, "|$pwauth_path" or
                  die "Cannot invoke authentication";
               print PWAUTH "$uname\n$upass\n";
               close PWAUTH;
               &Debug("exited pwauth with $? ($uname,$upass) ");
               $pwdcorrect=($? == 0);
            }
            if ($pwdcorrect) {
               my $execdir=$perlvar{'lonDaemons'};
               &Debug("Opening lcpasswd pipeline");
               my $pf = IO::File->new("|$execdir/lcpasswd > "
                                       ."$perlvar{'lonDaemons'}"
                                       ."/logs/lcpasswd.log");
               print $pf "$uname\n$npass\n$npass\n";
               close $pf;
               my $err = $?;
               my $result = ($err>0 ? 'pwchange_failure' : 'ok');
               &logthis("Result of password change for $uname: ".
               &lcpasswdstrerror($?));
               Reply($client, "$result\n", $userinput);
            } else {
               Reply($client, "non_authorized\n", $userinput);
            }
         } else {
            Reply( $client, "auth_mode_error\n", $userinput);
         }  
      } else {
               Reply( $client, "unknown_user\n", $userinput);
      }
      return 1;
   }
   RegisterHandler("passwd", \&ChangePasswordHandler, 1, 1, 0);
   
   #
   #   Create a new user.  User in this case means a lon-capa user.
   #   The user must either already exist in some authentication realm
   #   like kerberos or the /etc/passwd.  If not, a user completely local to
   #   this loncapa system is created.
   #
   # 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.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   sub AddUserHandler {
      my $cmd     = shift;
      my $tail    = shift;
      my $client  = shift;
      
      my $userinput = $cmd.":".$tail;   
   
      my $oldumask=umask(0077);
      my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
      &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname);
      chomp($npass);
      $npass=&unescape($npass);
      my $proname=propath($udom,$uname);
      my $passfilename="$proname/passwd";
      &Debug("Password file created will be:".$passfilename);
      if (-e $passfilename) {
         Failure( $client, "already_exists\n", $userinput);
      } elsif ($udom ne $currentdomainid) {
         Failure($client, "not_right_domain\n", $userinput);
      } else {
         my @fpparts=split(/\//,$proname);
         my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];
         my $fperror='';
         for (my $i=3;$i<=$#fpparts;$i++) {
            $fpnow.='/'.$fpparts[$i]; 
            unless (-e $fpnow) {
               unless (mkdir($fpnow,0777)) {
                  $fperror="error: ".($!+0)." mkdir failed while attempting "
                          ."makeuser";
               }
            }
         }
         unless ($fperror) {
            my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
            Reply($client, $result, $userinput);     #BUGBUG - could be fail
         } else {
            Failure($client, "$fperror\n", $userinput);
         }
      }
      umask($oldumask);
      return 1;
   
   }
   RegisterHandler("makeuser", \&AddUserHandler, 1, 1, 0);
   
   #
   #   Change the authentication method of a user.  Note that this may
   #   also implicitly change the user's password if, for example, the user is
   #   joining an existing authentication realm.  Known authentication realms at
   #   this time are:
   #    internal   - Purely internal password file (only loncapa knows this user)
   #    local      - Institutionally written authentication module.
   #    unix       - Unix user (/etc/passwd with or without /etc/shadow).
   #    kerb4      - kerberos version 4
   #    kerb5      - kerberos version 5
   #
   # 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.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub ChangeAuthenticationHandler {
      my $cmd     = shift;
      my $tail    = shift;
      my $client  = shift;
      
      my $userinput  = "$cmd:$tail";              # Reconstruct user input.
   
      my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
      chomp($npass);
      &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode);
      $npass=&unescape($npass);
      my $proname=&propath($udom,$uname);
      my $passfilename="$proname/passwd";
      if ($udom ne $currentdomainid) {
         Failure( $client, "not_right_domain\n", $client);
      } else {
         my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
         Reply($client, $result, $userinput);
      }
      return 1;
   }
   RegisterHandler("changeuserauth", \&ChangeAuthenticationHandler, 1,1, 0);
   
   #
   #   Determines if this is the home server for a user.  The home server
   #   for a user will have his/her lon-capa passwd file.  Therefore all we need
   #   to do is determine if this file exists.
   #
   # 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.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub IsHomeHandler {
      my $cmd     = shift;
      my $tail    = shift;
      my $client  = shift;
      
      my $userinput  = "$cmd:$tail";
      
      my ($udom,$uname)=split(/:/,$tail);
      chomp($uname);
      my $proname=propath($udom,$uname);
      if (-e $proname) {
         Reply( $client, "found\n", $userinput);
      } else {
         Failure($client, "not_found\n", $userinput);
      }
      return 1;
   }
   RegisterHandler("home", \&IsHomeHandler, 0,1,0);
   #
   #   Process an update request for a resource?? I think what's going on here is
   #   that 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
   #   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:
   #    $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.
   # Implicit inputs:
   #    The authentication systems describe above have their own forms of implicit
   #    input into the authentication process that are described above.
   #
   sub UpdateResourceHandler {
      my $cmd    = shift;
      my $tail   = shift;
      my $client = shift;
      
      my $userinput = "$cmd:$tail";
      
      my $fname=$tail;
      my $ownership=ishome($fname);
      if ($ownership eq 'not_owner') {
         if (-e $fname) {
            my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
                $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
            my $now=time;
            my $since=$now-$atime;
            if ($since>$perlvar{'lonExpire'}) {
               my $reply=&reply("unsub:$fname","$clientname");
               unlink("$fname");
            } else {
               my $transname="$fname.in.transfer";
               my $remoteurl=&reply("sub:$fname","$clientname");
               my $response;
               alarm(120);
               {
                  my $ua=new LWP::UserAgent;
                  my $request=new HTTP::Request('GET',"$remoteurl");
                  $response=$ua->request($request,$transname);
               }
               alarm(0);
               if ($response->is_error()) {
                  unlink($transname);
                  my $message=$response->status_line;
                  &logthis("LWP GET: $message for $fname ($remoteurl)");
               } else {
                  if ($remoteurl!~/\.meta$/) {
                     alarm(120);
                     {
                        my $ua=new LWP::UserAgent;
                        my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
                        my $mresponse=$ua->request($mrequest,$fname.'.meta');
                        if ($mresponse->is_error()) {
                           unlink($fname.'.meta');
                        }
                     }
                     alarm(0);
                  }
                  rename($transname,$fname);
               }
            }
                  Reply( $client, "ok\n", $userinput);
         } else {
            Failure($client, "not_found\n", $userinput);
         }
      } else {
         Failure($client, "rejected\n", $userinput);
      }
      return 1;
   }
   RegisterHandler("update", \&UpdateResourceHandler, 0 ,1, 0);
   
   #
   #   Fetch a user file from a remote server:
   # 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.
   #
   sub FetchUserFileHandler {
      my $cmd     = shift;
      my $tail    = shift;
      my $client  = shift;
      
      my $userinput = "$cmd:$tail";
      my $fname           = $tail;
      my ($udom,$uname,$ufile)=split(/\//,$fname);
      my $udir=propath($udom,$uname).'/userfiles';
      unless (-e $udir) {
         mkdir($udir,0770); 
      }
      if (-e $udir) {
         $ufile=~s/^[\.\~]+//;
         $ufile=~s/\///g;
         my $destname=$udir.'/'.$ufile;
         my $transname=$udir.'/'.$ufile.'.in.transit';
         my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
         my $response;
         alarm(120);
         {
            my $ua=new LWP::UserAgent;
            my $request=new HTTP::Request('GET',"$remoteurl");
            $response=$ua->request($request,$transname);
         }
         alarm(0);
         if ($response->is_error()) {
            unlink($transname);
            my $message=$response->status_line;
            &logthis("LWP GET: $message for $fname ($remoteurl)");
            Failure($client, "failed\n", $userinput);
         } else {
            if (!rename($transname,$destname)) {
               &logthis("Unable to move $transname to $destname");
               unlink($transname);
               Failure($client, "failed\n", $userinput);
            } else {
               Reply($client, "ok\n", $userinput);
            }
         }   
      } else {
         Failure($client, "not_home\n", $userinput);
      }
      return 1;
   }
   RegisterHandler("fetchuserfile", \&FetchUserFileHandler, 0, 1, 0);
   #
   #   Authenticate access to a user file.  Question?   The token for athentication
   #   is allowed to be sent as cleartext is this really what we want?  This token
   #   represents the user's session id.  Once it is forged does this allow too much access??
   #
   # 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.
   sub AuthenticateUserFileAccess {
      my $cmd   = shift;
      my $tail    = shift;
      my $client = shift;
      my $userinput = "$cmd:$tail";
   
      my ($fname,$session)=split(/:/,$tail);
      chomp($session);
      my $reply='non_auth';
      if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.$session.'.id')) {
         while (my $line=<ENVIN>) {
            if ($line=~/userfile\.$fname\=/) { 
               $reply='ok'; 
            }
         }
         close(ENVIN);
         Reply($client, $reply."\n", $userinput);
      } else {
         Failure($client, "invalid_token\n", $userinput);
      }
      return 1;
      
   }
   RegisterHandler("tokenauthuserfile", \&AuthenticateUserFileAccess, 0, 1, 0);
   #
   #   Unsubscribe from a resource.
   #
   # 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.
   #
   sub UnsubscribeHandler {
      my $cmd      = shift;
      my $tail     = shift;
      my $client   = shift;
      my $userinput= "$cmd:$tail";
   
      my $fname = $tail;
      if (-e $fname) {
         Reply($client, &unsub($client,$fname,$clientip), $userinput);
      } else {
         Failure($client, "not_found\n", $userinput);
      }
      return 1;
   }
   RegisterHandler("unusb", \&UnsubscribeHandler, 0, 1, 0);
   
   #   Subscribe to a resource.
   #
   # 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.
   #
   sub SubscribeHandler {
      my $cmd        = shift;
      my $tail       = shift;
      my $client     = shift;
      my $userinput  = "$cmd:$tail";
   
      Reply( $client, &subscribe($userinput,$clientip), $userinput);
    
      return 1;
   }
   RegisterHandler("sub", \&SubscribeHandler, 0, 1, 0);
   
   #
   #   Determine the version of a resource (?) Or is it return
   #   the top version of the resource?  Not yet clear from the
   #   code in currentversion.
   #
   # 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.
   #
   sub CurrentVersionHandler {
      my $cmd      = shift;
      my $tail     = shift;
      my $client   = shift;
      my $userinput= "$cmd:$tail";
      
      my $fname   = $tail;
      Reply( $client, &currentversion($fname)."\n", $userinput);
      return 1;
   
   }
   RegisterHandler("currentversion", \&CurrentVersionHandler, 0, 1, 0);
   
   
   #  Make an entry in a user's activity log.
   #
   # 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.
   #
   sub ActivityLogEntryHandler {
      my $cmd      = shift;
      my $tail     = shift;
      my $client   = shift;
      my $userinput= "$cmd:$tail";
   
      my ($udom,$uname,$what)=split(/:/,$tail);
      chomp($what);
      my $proname=propath($udom,$uname);
      my $now=time;
      my $hfh;
      if ($hfh=IO::File->new(">>$proname/activity.log")) { 
         print $hfh "$now:$clientname:$what\n";
         Reply( $client, "ok\n", $userinput); 
      } else {
         Reply($client, "error: ".($!+0)." IO::File->new Failed "
               ."while attempting log\n", 
               $userinput);
      }
   
      return 1;
   }
   RegisterHandler("log", \&ActivityLogEntryHandler, 0, 1, 0);
   #
   #   Put a namespace entry in a user profile hash.
   #   My druthers would be for this to be an encrypted interaction too.
   #   anything that might be an inadvertent covert channel about either
   #   user authentication or user personal information....
   #
   # 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.
   #
   sub PutUserProfileEntry {
      my $cmd       = shift;
      my $tail      = shift;
      my $client    = shift;
      my $userinput = "$cmd:$tail";
   
      my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
      $namespace=~s/\//\_/g;
      $namespace=~s/\W//g;
      if ($namespace ne 'roles') {
         chomp($what);
         my $proname=propath($udom,$uname);
         my $now=time;
         unless ($namespace=~/^nohist\_/) {
            my $hfh;
            if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 
               print $hfh "P:$now:$what\n"; 
            }
         }
         my @pairs=split(/\&/,$what);
         my %hash;
         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
                     &GDBM_WRCREAT(),0640)) {
            foreach my $pair (@pairs) {
               my ($key,$value)=split(/=/,$pair);
               $hash{$key}=$value;
            }
            if (untie(%hash)) {
               Reply( $client, "ok\n", $userinput);
            } else {
               Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
                     "while attempting put\n", 
                     $userinput);
            }
         } else {
            Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
            "while attempting put\n", $userinput);
         }
      } else {
         Failure( $client, "refused\n", $userinput);
      }
      
      return 1;
   }
   RegisterHandler("put", \&PutUserProfileEntry, 0, 1, 0);
   
   # 
   #   Increment a profile entry in the user history file.
   #   The history contains keyword value pairs.  In this case,
   #   The value itself is a pair of numbers.  The first, the current value
   #   the second an increment that this function applies to the current
   #   value.
   #
   # 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.
   #
   sub IncrementUserValueHandler {
      my $cmd         = shift;
      my $tail        = shift;
      my $client      = shift;
      my $userinput   = shift;
   
      my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
      $namespace=~s/\//\_/g;
      $namespace=~s/\W//g;
      if ($namespace ne 'roles') {
         chomp($what);
         my $proname=propath($udom,$uname);
         my $now=time;
         unless ($namespace=~/^nohist\_/) {
            my $hfh;
            if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 
               print $hfh "P:$now:$what\n";
            }
         }
         my @pairs=split(/\&/,$what);
         my %hash;
         if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),
                  0640)) {
            foreach my $pair (@pairs) {
               my ($key,$value)=split(/=/,$pair);
               # We could check that we have a number...
               if (! defined($value) || $value eq '') {
                  $value = 1;
               }
               $hash{$key}+=$value;
            }
            if (untie(%hash)) {
               Reply( $client, "ok\n", $userinput);
            } else {
               Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
                        "while attempting put\n", $userinput);
            }
         } else {
            Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                     "while attempting put\n", $userinput);
         }
      } else {
         Failure($client, "refused\n", $userinput);
      }
   
      return 1;
   }
   RegisterHandler("inc", \&IncrementUserValueHandler, 0, 1, 0);
   #
   #   Put a new role for a user.  Roles are LonCAPA's packaging of permissions.
   #   Each 'role' a user has implies a set of permissions.  Adding a new role
   #   for a person grants the permissions packaged with that role
   #   to that user when the role is selected.
   #
   # Parameters:
   #    $cmd       - The command string (rolesput).
   #    $tail      - The remainder of the request line.  For rolesput this
   #                 consists of a colon separated list that contains:
   #                 The domain and user that is granting the role (logged).
   #                 The domain and user that is getting the role.
   #                 The roles being granted as a set of & separated pairs.
   #                 each pair a key value pair.
   #    $client    - File descriptor connected to the client.
   # Returns:
   #     0         - If the daemon should exit
   #     1         - To continue processing.
   #
   #
   sub RolesPutHandler {
      my $cmd        = shift;
      my $tail       = shift;
      my $client     = shift;
      my $userinput  = "$cmd:$tail";
      
      my ($exedom,$exeuser,$udom,$uname,$what)   =split(/:/,$tail);
      &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
             "what = ".$what);
      my $namespace='roles';
      chomp($what);
      my $proname=propath($udom,$uname);
      my $now=time;
      #
      #  Log the attempt to set a role.  The {}'s here ensure that the file 
      #  handle is open for the minimal amount of time.  Since the flush
      #  is done on close this improves the chances the log will be an un-
      #  corrupted ordered thing.
      {
         my $hfh;
         if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 
            print $hfh "P:$now:$exedom:$exeuser:$what\n";
         }
      }
      my @pairs=split(/\&/,$what);
      my %hash;
      if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_WRCREAT(),0640)) {
         foreach my $pair (@pairs) {
            my ($key,$value)=split(/=/,$pair);
               &ManagePermissions($key, $udom, $uname,
                                  &GetAuthType( $udom, $uname));
               $hash{$key}=$value;
         }
         if (untie(%hash)) {
            Reply($client, "ok\n", $userinput);
         } else {
            Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
                            "while attempting rolesput\n", $userinput);
         }
      } else {
         Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                           "while attempting rolesput\n", $userinput);
      }
      return 1;
   }
   RegisterHandler("rolesput", \&RolesPutHandler, 1,1,0);  # Encoded client only.
   #
   #   Deletes (removes) a role for a user.   This is equivalent to removing
   #  a permissions package associated with the role from the user's profile.
   #
   # Parameters:
   #     $cmd                 - The command (rolesdel)
   #     $tail                - The remainder of the request line. This consists
   #                             of:
   #                             The domain and user requesting the change (logged)
   #                             The domain and user being changed.
   #                             The roles being revoked.  These are shipped to us
   #                             as a bunch of & separated role name keywords.
   #     $client              - The file handle open on the client.
   # Returns:
   #     1                    - Continue processing
   #     0                    - Exit.
   #
   sub RolesDeleteHandler {
      my $cmd          = shift;
      my $tail         = shift;
      my $client       = shift;
      my $userinput    = "$cmd:$tail";
      
      my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail);
      &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
             "what = ".$what);
      my $namespace='roles';
      chomp($what);
      my $proname=propath($udom,$uname);
      my $now=time;
      #
      #   Log the attempt. This {}'ing is done to ensure that the
      #   logfile is flushed and closed as quickly as possible.  Hopefully
      #   this preserves both time ordering and reduces the probability that
      #   messages will be interleaved.
      #
      {
         my $hfh;
         if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 
            print $hfh "D:$now:$exedom:$exeuser:$what\n";
         }
      }
      my @rolekeys=split(/\&/,$what);
      my %hash;
      if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_WRCREAT(),0640)) {
         foreach my $key (@rolekeys) {
            delete $hash{$key};
         }
         if (untie(%hash)) {
            Reply($client, "ok\n", $userinput);
         } else {
            Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
                              "while attempting rolesdel\n", $userinput);
         }
      } else {
         Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                           "while attempting rolesdel\n", $userinput);
      }
   
      return 1;
   }
   RegisterHandler("rolesdel", \&RolesDeleteHandler, 1,1, 0); # Encoded client only
   
   # Unencrypted get from a user's profile database.  See 
   # GetProfileEntryEncrypted for a version that does end-to-end encryption.
   # This function retrieves a keyed item from a specific named database in the
   # user's directory.
   #
   # Parameters:
   #   $cmd             - Command request keyword (get).
   #   $tail            - Tail of the command.  This is a colon separated list
   #                      consisting of the domain and username that uniquely
   #                      identifies the profile,
   #                      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.
   #
   sub GetProfileEntry {
      my $cmd      = shift;
      my $tail     = shift;
      my $client   = shift;
      my $userinput= "$cmd:$tail";
      
      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
      $namespace=~s/\//\_/g;
      $namespace=~s/\W//g;
      chomp($what);
      my @queries=split(/\&/,$what);
      my $proname=propath($udom,$uname);
      my $qresult='';
      my %hash;
      if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_READER(),0640)) {
         for (my $i=0;$i<=$#queries;$i++) {
            $qresult.="$hash{$queries[$i]}&";    # Presumably failure gives empty string.
         }
         if (untie(%hash)) {
            $qresult=~s/\&$//;              # Remove trailing & from last lookup.
            Reply($client, "$qresult\n", $userinput);
         } else {
            Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                             "while attempting get\n", $userinput);
         }
      } else {
         if ($!+0 == 2) {                # +0 coerces errno -> number 2 is ENOENT
            Failure($client, "error:No such file or ".
                             "GDBM reported bad block error\n", $userinput);
         } else {                        # Some other undifferentiated err.
            Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                              "while attempting get\n", $userinput);
         }
      }
      return 1;
   }
   RegisterHandler("get", \&GetProfileEntry, 0,1,0);
   #
   #  Process the encrypted get request.  Note that the request is sent
   #  in clear, but the reply is encrypted.  This is a small covert channel:
   #  information about the sensitive keys is given to the snooper.  Just not
   #  information about the values of the sensitive key.  Hmm if I wanted to
   #  know these I'd snoop for the egets. Get the profile item names from them
   #  and then issue a get for them since there's no enforcement of the
   #  requirement of an encrypted get for particular profile items.  If I
   #  were re-doing this, I'd force the request to be encrypted as well as the
   #  reply.  I'd also just enforce encrypted transactions for all gets since
   #  that would prevent any covert channel snooping.
   #
   #  Parameters:
   #     $cmd               - Command keyword of request (eget).
   #     $tail              - Tail of the command.  See GetProfileEntry #                          for more information about this.
   #     $client            - File open on the client.
   #  Returns:
   #     1      - Continue processing
   #     0      - server should exit.
   sub GetProfileEntryEncrypted {
      my $cmd       = shift;
      my $tail      = shift;
      my $client    = shift;
      my $userinput = "$cmd:$tail";
      
      my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
      $namespace=~s/\//\_/g;
      $namespace=~s/\W//g;
      chomp($what);
      my @queries=split(/\&/,$what);
      my $proname=propath($udom,$uname);
      my $qresult='';
      my %hash;
      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
         for (my $i=0;$i<=$#queries;$i++) {
            $qresult.="$hash{$queries[$i]}&";
         }
         if (untie(%hash)) {
            $qresult=~s/\&$//;
            if ($cipher) {
               my $cmdlength=length($qresult);
               $qresult.="         ";
               my $encqresult='';
               for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
                  $encqresult.= unpack("H16", $cipher->encrypt(substr($qresult,
                                                                      $encidx,
                                                                      8)));
               }
               Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
            } else {
               Failure( $client, "error:no_key\n", $userinput);
            }
         } else {
            Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                                 "while attempting eget\n", $userinput);
         }
      } else {
         Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                          "while attempting eget\n", $userinput);
      }
            
      return 1;
   }
   RegisterHandler("eget", \&GetProfileEncrypted, 0, 1, 0);
   
   #
   #   Deletes a key in a user profile database.
   #   
   #   Parameters:
   #       $cmd                  - Command keyword (del).
   #       $tail                 - Command tail.  IN this case a colon
   #                               separated list containing:
   #                               The domain and user that identifies uniquely
   #                               the identity of the user.
   #                               The profile namespace (name of the profile
   #                               database file).
   #                               & separated list of keywords to delete.
   #       $client              - File open on client socket.
   # Returns:
   #     1   - Continue processing
   #     0   - Exit server.
   #
   #
   sub DeletProfileEntry {
      my $cmd      = shift;
      my $tail     = shift;
      my $client   = shift;
      my $userinput = "cmd:$tail";
   
      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
      $namespace=~s/\//\_/g;
      $namespace=~s/\W//g;
      chomp($what);
      my $proname=propath($udom,$uname);
      my $now=time;
      unless ($namespace=~/^nohist\_/) {
         my $hfh;
         if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { 
            print $hfh "D:$now:$what\n"; 
         }
      }
      my @keys=split(/\&/,$what);
      my %hash;
      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {
         foreach my $key (@keys) {
            delete($hash{$key});
         }
         if (untie(%hash)) {
            Reply($client, "ok\n", $userinput);
         } else {
            Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                              "while attempting del\n", $userinput);
         }
      } else {
         Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                           "while attempting del\n", $userinput);
      }
      return 1;
   }
   RegisterHandler("del", \&DeleteProfileEntry, 0, 1, 0);
   #
   #  List the set of keys that are defined in a profile database file.
   #  A successful reply from this will contain an & separated list of
   #  the keys. 
   # Parameters:
   #     $cmd              - Command request (keys).
   #     $tail             - Remainder of the request, a colon separated
   #                         list containing domain/user that identifies the
   #                         user being queried, and the database namespace
   #                         (database filename essentially).
   #     $client           - File open on the client.
   #  Returns:
   #    1    - Continue processing.
   #    0    - Exit the server.
   #
   sub GetProfileKeys {
      my $cmd       = shift;
      my $tail      = shift;
      my $client    = shift;
      my $userinput = "$cmd:$tail";
   
      my ($udom,$uname,$namespace)=split(/:/,$tail);
      $namespace=~s/\//\_/g;
      $namespace=~s/\W//g;
      my $proname=propath($udom,$uname);
      my $qresult='';
      my %hash;
      if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
         foreach my $key (keys %hash) {
             $qresult.="$key&";
         }
         if (untie(%hash)) {
            $qresult=~s/\&$//;
            Reply($client, "$qresult\n", $userinput);
         } else {
            Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                             "while attempting keys\n", $userinput);
         }
      } else {
         Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                           "while attempting keys\n", $userinput);
      }
      
      return 1;
   }
   RegisterHandler("keys", \&GetProfileKeys, 0, 1, 0);
   #
   #   Dump the contents of a user profile database.
   #   Note that this constitutes a very large covert channel too since
   #   the dump will return sensitive information that is not encrypted.
   #   The naive security assumption is that the session negotiation ensures
   #   our client is trusted and I don't believe that's assured at present.
   #   Sure want badly to go to ssl or tls.  Of course if my peer isn't really
   #   a LonCAPA node they could have negotiated an encryption key too so >sigh<.
   # 
   #  Parameters:
   #     $cmd           - The command request keyword (currentdump).
   #     $tail          - Remainder of the request, consisting of a colon
   #                      separated list that has the domain/username and
   #                      the namespace to dump (database file).
   #     $client        - file open on the remote client.
   # Returns:
   #     1    - Continue processing.
   #     0    - Exit the server.
   #
   sub DumpProfileDatabase {
      my $cmd       = shift;
      my $tail      = shift;
      my $client    = shift;
      my $userinput = "$cmd:$tail";
      
      my ($udom,$uname,$namespace) = split(/:/,$tail);
      $namespace=~s/\//\_/g;
      $namespace=~s/\W//g;
      my $qresult='';
      my $proname=propath($udom,$uname);
      my %hash;
      if (tie(%hash,'GDBM_File',"$proname/$namespace.db", &GDBM_READER(),0640)) {
         # Structure of %data:
         # $data{$symb}->{$parameter}=$value;
         # $data{$symb}->{'v.'.$parameter}=$version;
         # since $parameter will be unescaped, we do not
         # have to worry about silly parameter names...
         my %data = ();                     # A hash of anonymous hashes..
         while (my ($key,$value) = each(%hash)) {
            my ($v,$symb,$param) = split(/:/,$key);
            next if ($v eq 'version' || $symb eq 'keys');
            next if (exists($data{$symb}) && 
                     exists($data{$symb}->{$param}) &&
                     $data{$symb}->{'v.'.$param} > $v);
            $data{$symb}->{$param}=$value;
            $data{$symb}->{'v.'.$param}=$v;
         }
         if (untie(%hash)) {
            while (my ($symb,$param_hash) = each(%data)) {
               while(my ($param,$value) = each (%$param_hash)){
                  next if ($param =~ /^v\./);       # Ignore versions...
                  #
                  #   Just dump the symb=value pairs separated by &
                  #
                  $qresult.=$symb.':'.$param.'='.$value.'&';
               }
            }
            chop($qresult);
            Reply($client , "$qresult\n", $userinput);
         } else {
            Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
                              "while attempting currentdump\n", $userinput);
         }
      } else {
         Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                           "while attempting currentdump\n", $userinput);
      }
   
      return 1;
   }
   RegisterHandler("currentdump", \&DumpProfileDatabase, 0, 1, 0);
   #
   #   Dump a profile database with an optional regular expression
   #   to match against the keys.  In this dump, no effort is made
   #   to separate symb from version information. Presumably the
   #   databases that are dumped by this command are of a different
   #   structure.  Need to look at this and improve the documentation of
   #   both this and the currentdump handler.
   # Parameters:
   #    $cmd                     - The command keyword.
   #    $tail                    - All of the characters after the $cmd:
   #                               These are expected to be a colon
   #                               separated list containing:
   #                               domain/user - identifying the user.
   #                               namespace   - identifying the database.
   #                               regexp      - optional regular expression
   #                                             that is matched against
   #                                             database keywords to do
   #                                             selective dumps.
   #   $client                   - Channel open on the client.
   # Returns:
   #    1    - Continue processing.
   # Side effects:
   #    response is written to $client.
   #
   sub DumpWithRegexp {
     my $cmd    = shift;
     my $tail   = shift;
     my $client = shift;
   
     my $userinput = "$cmd:$tail";
   
     my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);
     $namespace=~s/\//\_/g;
     $namespace=~s/\W//g;
     if (defined($regexp)) {
       $regexp=&unescape($regexp);
     } else {
       $regexp='.';
     }
     my $qresult='';
     my $proname=propath($udom,$uname);
     my %hash;
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
     &GDBM_READER(),0640)) {
       study($regexp);
       while (my ($key,$value) = each(%hash)) {
         if ($regexp eq '.') {
    $qresult.=$key.'='.$value.'&';
         } else {
    my $unescapeKey = &unescape($key);
    if (eval('$unescapeKey=~/$regexp/')) {
     $qresult.="$key=$value&";
    }
         }
       }
       if (untie(%hash)) {
         chop($qresult);
         Reply($client, "$qresult\n", $userinput);
       } else {
         Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
          "while attempting dump\n", $userinput);
       }
     } else {
       Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
       "while attempting dump\n", $userinput);
     }
   
       return 1;
   }
   RegisterHandler("dump", \&DumpWithRegexp, 0, 1, 0);
   
   #  Store an aitem in any database but the roles database.
   #
   #  Parameters:
   #    $cmd                - Request command keyword.
   #    $tail               - Tail of the request.  This is a colon
   #                          separated list containing:
   #                          domain/user - User and authentication domain.
   #                          namespace   - Name of the database being modified
   #                          rid         - Resource keyword to modify.
   #                          what        - new value associated with rid.
   #
   #    $client             - Socket open on the client.
   #
   #
   #  Returns:
   #      1 (keep on processing).
   #  Side-Effects:
   #    Writes to the client
   sub StoreHandler {
     my $cmd    = shift;
     my $tail   = shift;
     my $client = shift;
    
     my $userinput = "$cmd:$tail";
   
     my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail);
     $namespace=~s/\//\_/g;
     $namespace=~s/\W//g;
     if ($namespace ne 'roles') {
       chomp($what);
       my $proname=propath($udom,$uname);
       my $now=time;
       unless ($namespace=~/^nohist\_/) {
         my $hfh;
         if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {
    print $hfh "P:$now:$rid:$what\n"; 
         }
       }
       my @pairs=split(/\&/,$what);
       my %hash;
       if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
       &GDBM_WRCREAT(),0640)) {
         my @previouskeys=split(/&/,$hash{"keys:$rid"});
         my $key;
         $hash{"version:$rid"}++;
         my $version=$hash{"version:$rid"};
         my $allkeys=''; 
         foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    $allkeys.=$key.':';
    $hash{"$version:$rid:$key"}=$value;
         }
         $hash{"$version:$rid:timestamp"}=$now;
         $allkeys.='timestamp';
         $hash{"$version:keys:$rid"}=$allkeys;
         if (untie(%hash)) {
    Reply($client, "ok\n", $userinput);
         } else {
    Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
    "while attempting store\n", $userinput);
         }
       } else {
         Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
          "while attempting store\n", $userinput);
       }
     } else {
       Failure($client, "refused\n", $userinput);
     }
   
     return 1;
   }
   RegisterHandler("store", \&StoreHandler, 0, 1, 0);
   #
   #   Restore a prior version of a resource.
   #
   #  Parameters:
   #     $cmd               - Command keyword.
   #     $tail              - Remainder of the request which consists of:
   #                          domain/user   - User and auth. domain.
   #                          namespace     - name of resource database.
   #                          rid           - Resource id.
   #    $client             - socket open on the client.
   #
   # Returns:
   #      1  indicating the caller should not yet exit.
   # Side-effects:
   #   Writes a reply to the client.
   #
   sub RestoreHandler {
     my $cmd     = shift;
     my $tail    = shift;
     my $client  = shift;
   
     my $userinput = "$cmd:$tail"; # Only used for logging purposes.
   
     my ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);
     $namespace=~s/\//\_/g;
     $namespace=~s/\W//g;
     chomp($rid);
     my $proname=propath($udom,$uname);
     my $qresult='';
     my %hash;
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",
     &GDBM_READER(),0640)) {
       my $version=$hash{"version:$rid"};
       $qresult.="version=$version&";
       my $scope;
       for ($scope=1;$scope<=$version;$scope++) {
         my $vkeys=$hash{"$scope:keys:$rid"};
    my @keys=split(/:/,$vkeys);
         my $key;
         $qresult.="$scope:keys=$vkeys&";
         foreach $key (@keys) {
    $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";
         }                                  
       }
        if (untie(%hash)) {
          $qresult=~s/\&$//;
          Reply( $client, "$qresult\n", $userinput);
        } else {
          Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
          "while attempting restore\n", $userinput);
        }
     } else {
       Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
       "while attempting restore\n", $userinput);
     }
     
     return 1;
   
   
   }
   RegisterHandler("restor", \&RestoreHandler, 0,1,0);
   
   #
   #   Add a chat message to to a discussion board.
   #
   # Parameters:
   #    $cmd                - Request keyword.
   #    $tail               - Tail of the command. A colon separated list
   #                          containing:
   #                          cdom    - Domain on which the chat board lives
   #                          cnum    - Identifier of the discussion group.
   #                          post    - Body of the posting.
   #   $client              - Socket open on the client.
   # Returns:
   #   1    - Indicating caller should keep on processing.
   #
   # Side-effects:
   #   writes a reply to the client.
   #
   #
   sub SendChatHandler {
     my $cmd     = shift;
     my $tail    = shift;
     my $client  = shift;
   
     my $userinput = "$cmd:$tail";
   
     my ($cdom,$cnum,$newpost)=split(/\:/,$tail);
     &chatadd($cdom,$cnum,$newpost);
     Reply($client, "ok\n", $userinput);
   
     return 1;
   }
   RegisterHandler("chatsend", \&SendChatHandler, 0, 1, 0);
   #
   #   Retrieve the set of chat messagss from a discussion board.
   #
   #  Parameters:
   #    $cmd             - Command keyword that initiated the request.
   #    $tail            - Remainder of the request after the command
   #                       keyword.  In this case a colon separated list of
   #                       chat domain    - Which discussion board.
   #                       chat id        - Discussion thread(?)
   #                       domain/user    - Authentication domain and username
   #                                        of the requesting person.
   #   $client           - Socket open on the client program.
   # Returns:
   #    1     - continue processing
   # Side effects:
   #    Response is written to the client.
   #
   sub RetrieveChatHandler {
     my $cmd      = shift;
     my $tail     = shift;
     my $client   = shift;
   
     my $userinput = "$cmd:$tail";
   
     my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);
     my $reply='';
     foreach (&getchat($cdom,$cnum,$udom,$uname)) {
       $reply.=&escape($_).':';
     }
     $reply=~s/\:$//;
     Reply($client, $reply."\n", $userinput);
   
   
     return 1;
   }
   RegisterHandler("chatretr", \&RetrieveChatHandler, 0, 1, 0);
   #
   #  Initiate a query of an sql database.  SQL query repsonses get put in
   #  a file for later retrieval.  This prevents sql query results from
   #  bottlenecking the system.  Note that with loncnew, perhaps this is
   #  less of an issue since multiple outstanding requests can be concurrently
   #  serviced.
   #
   #  Parameters:
   #     $cmd       - COmmand keyword that initiated the request.
   #     $tail      - Remainder of the command after the keyword.
   #                  For this function, this consists of a query and
   #                  3 arguments that are self-documentingly labelled
   #                  in the original arg1, arg2, arg3.
   #     $client    - Socket open on the client.
   # Return:
   #    1   - Indicating processing should continue.
   # Side-effects:
   #    a reply is written to $client.
   #
   sub SendQueryHandler {
     my $cmd     = shift;
     my $tail    = shift;
     my $client  = shift;
   
     my $userinput = "$cmd:$tail";
   
     my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);
     $query=~s/\n*$//g;
     Reply($client, "". sqlreply("$clientname\&$query".
         "\&$arg1"."\&$arg2"."\&$arg3")."\n",
    $userinput);
   
     return 1;
   }
   RegisterHandler("querysend", \&SendQueryHandler, 0, 1, 0);
   
   #
   #   Add a reply to an sql query.  SQL queries are done asyncrhonously.
   #   The query is submitted via a "querysend" transaction.
   #   There it is passed on to the lonsql daemon, queued and issued to
   #   mysql.
   #     This transaction is invoked when the sql transaction is complete
   #   it stores the query results in flie and indicates query completion.
   #   presumably local software then fetches this response... I'm guessing
   #   the sequence is: lonc does a querysend, we ask lonsql to do it.
   #   lonsql on completion of the query interacts with the lond of our
   #   client to do a query reply storing two files:
   #    - id     - The results of the query.
   #    - id.end - Indicating the transaction completed. 
   #    NOTE: id is a unique id assigned to the query and querysend time.
   # Parameters:
   #    $cmd        - Command keyword that initiated this request.
   #    $tail       - Remainder of the tail.  In this case that's a colon
   #                  separated list containing the query Id and the 
   #                  results of the query.
   #    $client     - Socket open on the client.
   # Return:
   #    1           - Indicating that we should continue processing.
   # Side effects:
   #    ok written to the client.
   #
   sub ReplyQueryHandler {
     my $cmd    = shift;
     my $tail   = shift;
     my $client = shift;
   
     my $userinput = "$cmd:$tail";
   
     my ($cmd,$id,$reply)=split(/:/,$userinput); 
     my $store;
     my $execdir=$perlvar{'lonDaemons'};
     if ($store=IO::File->new(">$execdir/tmp/$id")) {
       $reply=~s/\&/\n/g;
            print $store $reply;
       close $store;
       my $store2=IO::File->new(">$execdir/tmp/$id.end");
       print $store2 "done\n";
       close $store2;
       Reply($client, "ok\n", $userinput);
     }
     else {
       Failure($client, "error: ".($!+0)
       ." IO::File->new Failed ".
       "while attempting queryreply\n", $userinput);
     }
    
   
     return 1;
   }
   RegisterHandler("queryreply", \&ReplyQueryHandler, 0, 1, 0);
   #
   #  Process the courseidput query.  Not quite sure what this means
   #  at the system level sense.  It appears a gdbm file in the 
   #  /home/httpd/lonUsers/$domain/nohist_courseids is tied and
   #  a set of entries made in that database.
   #
   # Parameters:
   #   $cmd      - The command keyword that initiated this request.
   #   $tail     - Tail of the command.  In this case consists of a colon
   #               separated list contaning the domain to apply this to and
   #               an ampersand separated list of keyword=value pairs.
   #   $client   - Socket open on the client.
   # Returns:
   #   1    - indicating that processing should continue
   #
   # Side effects:
   #   reply is written to the client.
   #
   sub PutCourseIdHandler {
     my $cmd    = shift;
     my $tail   = shift;
     my $client = shift;
   
     my $userinput = "$cmd:$tail";
   
     my ($udom,$what)=split(/:/,$tail);
     chomp($what);
     $udom=~s/\W//g;
     my $proname=
       "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
     my $now=time;
     my @pairs=split(/\&/,$what);
     my %hash;
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
       foreach my $pair (@pairs) {
         my ($key,$value)=split(/=/,$pair);
         $hash{$key}=$value.':'.$now;
       }
       if (untie(%hash)) {
         Reply($client, "ok\n", $userinput);
       } else {
         Failure( $client, "error: ".($!+0)
          ." untie(GDBM) Failed ".
          "while attempting courseidput\n", $userinput);
       }
     } else {
       Failure( $client, "error: ".($!+0)
        ." tie(GDBM) Failed ".
        "while attempting courseidput\n", $userinput);
     }
   
     return 1;
   }
   RegisterHandler("courseidput", \&PutCourseIdHandler, 0, 1, 0);
   
   #  Retrieves the value of a course id resource keyword pattern
   #  defined since a starting date.  Both the starting date and the
   #  keyword pattern are optional.  If the starting date is not supplied it
   #  is treated as the beginning of time.  If the pattern is not found,
   #  it is treatred as "." matching everything.
   #
   #  Parameters:
   #     $cmd     - Command keyword that resulted in us being dispatched.
   #     $tail    - The remainder of the command that, in this case, consists
   #                of a colon separated list of:
   #                 domain   - The domain in which the course database is 
   #                            defined.
   #                 since    - Optional parameter describing the minimum
   #                            time of definition(?) of the resources that
   #                            will match the dump.
   #                 description - regular expression that is used to filter
   #                            the dump.  Only keywords matching this regexp
   #                            will be used.
   #     $client  - The socket open on the client.
   # Returns:
   #    1     - Continue processing.
   # Side Effects:
   #   a reply is written to $client.
   sub DumpCourseIdHandler {
     my $cmd    = shift;
     my $tail   = shift;
     my $client = shift;
   
     my $userinput = "$cmd:$tail";
   
     my ($udom,$since,$description) =split(/:/,$tail);
     if (defined($description)) {
       $description=&unescape($description);
     } else {
       $description='.';
     }
     unless (defined($since)) { $since=0; }
     my $qresult='';
     my $proname = "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";
     my %hash;
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
       while (my ($key,$value) = each(%hash)) {
         my ($descr,$lasttime)=split(/\:/,$value);
         if ($lasttime<$since) { 
    next; 
         }
         if ($description eq '.') {
    $qresult.=$key.'='.$descr.'&';
         } else {
    my $unescapeVal = &unescape($descr);
    if (eval('$unescapeVal=~/$description/i')) {
     $qresult.="$key=$descr&";
    }
         }
       }
       if (untie(%hash)) {
         chop($qresult);
         Reply($client, "$qresult\n", $userinput);
       } else {
         Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
         "while attempting courseiddump\n", $userinput);
       }
     } else {
       Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
       "while attempting courseiddump\n", $userinput);
     }
   
   
     return 1;
   }
   RegisterHandler("courseiddump", \&DumpCourseIdHandler, 0, 1, 0);
   #
   #  Puts an id to a domains id database. 
   #
   #  Parameters:
   #   $cmd     - The command that triggered us.
   #   $tail    - Remainder of the request other than the command. This is a 
   #              colon separated list containing:
   #              $domain  - The domain for which we are writing the id.
   #              $pairs  - The id info to write... this is and & separated list
   #                        of keyword=value.
   #   $client  - Socket open on the client.
   #  Returns:
   #    1   - Continue processing.
   #  Side effects:
   #     reply is written to $client.
   #
   sub PutIdHandler {
     my $cmd    = shift;
     my $tail   = shift;
     my $client = shift;
   
     my $userinput = "$cmd:$tail";
   
     my ($udom,$what)=split(/:/,$tail);
     chomp($what);
     $udom=~s/\W//g;
     my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
     my $now=time;
     {
       my $hfh;
       if ($hfh=IO::File->new(">>$proname.hist")) { 
         print $hfh "P:$now:$what\n"; 
       }
     }
     my @pairs=split(/\&/,$what);
     my %hash;
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
       foreach my $pair (@pairs) {
         my ($key,$value)=split(/=/,$pair);
         $hash{$key}=$value;
       }
       if (untie(%hash)) {
         Reply($client, "ok\n", $userinput);
       } else {
         Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
         "while attempting idput\n", $userinput);
       }
     } else {
       Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
        "while attempting idput\n", $userinput);
     }
   
     return 1;
   }
   
   RegisterHandler("idput", \&PutIdHandler, 0, 1, 0);
   #
   #  Retrieves a set of id values from the id database.
   #  Returns an & separated list of results, one for each requested id to the
   #  client.
   #
   # Parameters:
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose id table we dump
   #               ids      Consists of an & separated list of
   #                        id keywords whose values will be fetched.
   #                        nonexisting keywords will have an empty value.
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects:
   #   An & separated list of results is written to $client.
   #
   sub GetIdHandler {
     my $cmd    = shift;
     my $tail   = shift;
     my $client = shift;
   
     my $userinput = "$client:$tail";
   
     my ($udom,$what)=split(/:/,$tail);
     chomp($what);
     $udom=~s/\W//g;
     my $proname="$perlvar{'lonUsersDir'}/$udom/ids";
     my @queries=split(/\&/,$what);
     my $qresult='';
     my %hash;
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
       for (my $i=0;$i<=$#queries;$i++) {
         $qresult.="$hash{$queries[$i]}&";
       }
       if (untie(%hash)) {
         $qresult=~s/\&$//;
         Reply($client, "$qresult\n", $userinput);
       } else {
         Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
          "while attempting idget\n",$userinput);
       }
     } else {
       Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                           "while attempting idget\n",$userinput);
     }
   
     return 1;
   }
   RegisterHandler("idget", \&GetIdHandler, 0, 1, 0);
   #------------------------------------------------------------------------------------
   #
   #   Process a Request.  Takes a request from the client validates
   #   it and performs the operation requested by it.  Returns
   #   a response to the client.
   #
   #  Parameters:
   #      request      - A string containing the user's request.
   #  Returns:
   #      0            - Requested to exit, caller should shut down.
   #      1            - Accept additional requests from the client.
   #
   sub ProcessRequest {
      my $Request      = shift;
      my $KeepGoing    = 1; # Assume we're not asked to stop.
       
      my $wasenc=0;
      my $userinput = $Request;   # for compatibility with oldcode <yeach>
   
   
   # ------------------------------------------------------------ See if encrypted
      
      if($userinput =~ /^enc/) {
         $wasenc = 1;
         $userinput = Decipher($userinput);
         if(! $userinput) {
            Failure($client,"error:Encrypted data without negotiating key");
            return 0;                      # Break off with this imposter.
         }
      }
      # Split off the request keyword from the rest of the stuff.
      
      my ($command, $tail) = split(/:/, $userinput, 2);
   
      Debug("Command received: $command, encoded = $wasenc");
   
      
   # ------------------------------------------------------------- Normal commands
   
      # 
      #   If the command is in the hash, then execute it via the hash dispatch:
      #
      if(defined $Dispatcher{$command}) {
   
         my $DispatchInfo = $Dispatcher{$command};
         my $Handler      = $$DispatchInfo[0];
         my $NeedEncode   = $$DispatchInfo[1];
         my $ClientTypes  = $$DispatchInfo[2];
         Debug("Matched dispatch hash: mustencode: $NeedEncode ClientType $ClientTypes");
         
         #  Validate the request:
         
         my $ok = 1;
         my $requesterprivs = 0;
         if(isClient()) {
    $requesterprivs |= $CLIENT_OK;
         }
         if(isManager()) {
    $requesterprivs |= $MANAGER_OK;
         }
         if($NeedEncode && (!$wasenc)) {
    Debug("Must encode but wasn't: $NeedEncode $wasenc");
            $ok = 0;
         }
         if(($ClientTypes & $requesterprivs) == 0) {
    Debug("Client not privileged to do this operation");
    $ok = 0;
         }
   
         if($ok) {
    Debug("Dispatching to handler $command $tail");
            $KeepGoing = &$Handler($command, $tail, $client);
         } else {
    Debug("Refusing to dispatch because ok is false");
    Failure($client, "refused", $userinput);
         }
   
   
   
   
   
   # ---------------------------------------------------------------------- tmpput
      } elsif ($userinput =~ /^tmpput/) {
         if(isClient) {
            my ($cmd,$what)=split(/:/,$userinput);
            my $store;
            $tmpsnum++;
            my $id=$$.'_'.$clientip.'_'.$tmpsnum;
            $id=~s/\W/\_/g;
            $what=~s/\n//g;
            my $execdir=$perlvar{'lonDaemons'};
            if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
               print $store $what;
               close $store;
               Reply($client, "$id\n", $userinput);
            }
            else {
               Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
                              "while attempting tmpput\n", $userinput);
            }
         } else {
            Failure($client, "refused\n", $userinput);
       
         }
   
   # ---------------------------------------------------------------------- tmpget
      } elsif ($userinput =~ /^tmpget/) {
         if(isClient) {
            my ($cmd,$id)=split(/:/,$userinput);
            chomp($id);
            $id=~s/\W/\_/g;
            my $store;
            my $execdir=$perlvar{'lonDaemons'};
            if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
               my $reply=<$store>;
               Reply( $client, "$reply\n", $userinput);
               close $store;
            }
            else {
               Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
                                  "while attempting tmpget\n", $userinput);
            }
         } else {
            Failure($client, "refused\n", $userinput);
       
         }
   # ---------------------------------------------------------------------- tmpdel
      } elsif ($userinput =~ /^tmpdel/) {
         if(isClient) {
            my ($cmd,$id)=split(/:/,$userinput);
            chomp($id);
            $id=~s/\W/\_/g;
            my $execdir=$perlvar{'lonDaemons'};
            if (unlink("$execdir/tmp/$id.tmp")) {
               Reply($client, "ok\n", $userinput);
            } else {
               Failure( $client, "error: ".($!+0)."Unlink tmp Failed ".
                                    "while attempting tmpdel\n", $userinput);
            }
         } else {
            Failure($client, "refused\n", $userinput);
         }
   # -------------------------------------------------------------------------- ls
      } elsif ($userinput =~ /^ls/) {
         if(isClient) {
            my ($cmd,$ulsdir)=split(/:/,$userinput);
            my $ulsout='';
            my $ulsfn;
            if (-e $ulsdir) {
               if(-d $ulsdir) {
                  if (opendir(LSDIR,$ulsdir)) {
                     while ($ulsfn=readdir(LSDIR)) {
                        my @ulsstats=stat($ulsdir.'/'.$ulsfn);
                        $ulsout.=$ulsfn.'&'.
                        join('&',@ulsstats).':';
                     }
                     closedir(LSDIR);
                  }
               } else {
                  my @ulsstats=stat($ulsdir);
                  $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
               }
            } else {
               $ulsout='no_such_dir';
            }
            if ($ulsout eq '') { $ulsout='empty'; }
            Reply($client, "$ulsout\n", $userinput);
         } else {
            Failure($client, "refused\n", $userinput);
       
         }
   # ----------------------------------------------------------------- setannounce
      } elsif ($userinput =~ /^setannounce/) {
         if (isClient) {
            my ($cmd,$announcement)=split(/:/,$userinput);
            chomp($announcement);
            $announcement=&unescape($announcement);
            if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.
                                                '/announcement.txt')) {
               print $store $announcement;
               close $store;
               Reply($client, "ok\n", $userinput);
            } else {
               Failure($client, "error: ".($!+0)."\n", $userinput);
            }
         } else {
            Failure($client, "refused\n", $userinput);
       
         }
   # ------------------------------------------------------------------ Hanging up
      } elsif (($userinput =~ /^exit/) ||
            ($userinput =~ /^init/)) { # no restrictions.
         &logthis("Client $clientip ($clientname) hanging up: $userinput");
         Reply($client, "bye\n", $userinput);
         $client->shutdown(2);        # shutdown the socket forcibly.
         $client->close();
         $KeepGoing = 0; # Flag to exit the program.
   
   # ---------------------------------- set current host/domain
      } elsif ($userinput =~ /^sethost:/) {
         if (isClient) {
            Reply($client, &sethost($userinput)."\n", $userinput);
         } else {
            Failure($client, "refused\n", $userinput);
         }
   #---------------------------------- request file (?) version.
       } elsif ($userinput =~/^version:/) {
    if (isClient) {
       Reply($client, &version($userinput)."\n", $userinput);
    } else {
       Reply( $client, "refused\n", $userinput);
    }
   # ------------------------------------------------------------- unknown command
   
      } else {
    # unknown command
         Failure($client, "unknown_cmd\n", $userinput);
      }
   
       return $KeepGoing;
   }
   
   
 #  #
 #   GetCertificate: Given a transaction that requires a certificate,  #   GetCertificate: Given a transaction that requires a certificate,
Line 136  sub GetCertificate { Line 2664  sub GetCertificate {
     return $clientip;      return $clientip;
 }  }
   
 #  
 #   Return true if client is a manager.  
 #  
 sub isManager {  
     return (($ConnectionType eq "manager") || ($ConnectionType eq "both"));  
 }  
 #  
 #   Return tru if client can do client functions  
 #  
 sub isClient {  
     return (($ConnectionType eq "client") || ($ConnectionType eq "both"));  
 }  
   
   
 #  #
Line 162  sub ReadManagerTable { Line 2678  sub ReadManagerTable {
   
     #   Clean out the old table first..      #   Clean out the old table first..
   
     foreach my $key (keys %managers) {     foreach my $key (keys %managers) {
  delete $managers{$key};        delete $managers{$key};
     }     }
   
     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>');        logthis('<font color="red">No manager table.  Nobody can manage!!</font>');
  return;        return;
     }     }
     while(my $host = <MANAGERS>) {     while(my $host = <MANAGERS>) {
  chomp($host);        chomp($host);
  if (!defined $hostip{$host}) { # This is a non cluster member        if ($host =~ "^#") {                  # Comment line.
            logthis('<font color="green"> Skipping line: '. "$host</font>\n");
            next;
         }
         if (!defined $hostip{$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
     #            the host key.      #            the host key.
     #  hostname- The dns name of the host.      #  hostname- The dns name of the host.
     #      #
                 my($cluname, $dnsname) = split(/:/, $host);
     my($cluname, $dnsname) = split(/:/, $host);            
     open(MGRPIPE, "/usr/bin/host $dnsname |") || die "Can't make host pipeline";            my $ip = gethostbyname($dnsname);
     my $dnsinfo = <MGRPIPE>;            if(defined($ip)) {                 # bad names don't deserve entry.
     chomp $dnsinfo;              my $hostip = inet_ntoa($ip);
     close MGRPIPE;              $managers{$hostip} = $cluname;
     my($jname, $jhas, $jaddress, $hostip) = split(/ /, $dnsinfo);              logthis('<font color="green"> registering manager '.
     $managers{$hostip} = $cluname;                      "$dnsname as $cluname with $hostip </font>\n");
  } else {           }
     $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber        } else {
  }           logthis('<font color="green"> existing host'." $host</font>\n");
     }           $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber
         }
      }
 }  }
   
 #  #
Line 279  sub AdjustHostContents { Line 2800  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 =~ /^ *$/))) {
     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) {
  open(PIPE, " /usr/bin/host $name |") || die "Cant' make host pipeline";            my $ip = gethostbyname($name);
  my $hostinfo = <PIPE>;            my $ipnew = inet_ntoa($ip);
  close PIPE;           $ip = $ipnew;
   
  my ($hostname, $has, $address, $ipnew) = split(/ /,$hostinfo);  
  &logthis('<font color="green">'.  
  "hostname = $hostname me = $me, name = $name   actual ip = $ipnew </font>");  
   
  if ($hostname eq $name) { # Lookup succeeded..  
     &logthis('<font color="green"> look up ok <font>');  
     $ip = $ipnew;  
  } else {  
     &logthis('<font color="green"> Lookup failed: '  
      .$hostname." ne $name </font>");  
  }  
  #  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:
Line 356  sub InstallFile { Line 2865  sub InstallFile {
   
     return 1;      return 1;
 }  }
   #
   #   ConfigFileFromSelector: converts a configuration file selector
   #                 (one of host or domain at this point) into a 
   #                 configuration file pathname.
   #
   #  Parameters:
   #      selector  - Configuration file selector.
   #  Returns:
   #      Full path to the file or undef if the selector is invalid.
   #
   sub ConfigFileFromSelector {
       my $selector   = shift;
       my $tablefile;
   
       my $tabledir = $perlvar{'lonTabDir'}.'/';
       if ($selector eq "hosts") {
    $tablefile = $tabledir."hosts.tab";
       } elsif ($selector eq "domain") {
    $tablefile = $tabledir."domain.tab";
       } else {
    return undef;
       }
       return $tablefile;
   
   }
 #  #
 #   PushFile:  Called to do an administrative push of a file.  #   PushFile:  Called to do an administrative push of a file.
 #              - Ensure the file being pushed is one we support.  #              - Ensure the file being pushed is one we support.
Line 386  sub PushFile { Line 2919  sub PushFile {
     # part of some elaborate spoof that managed somehow to authenticate.      # part of some elaborate spoof that managed somehow to authenticate.
     #      #
   
     my $tablefile = $perlvar{'lonTabDir'}.'/'; # need to precede with dir.  
     if ($filename eq "host") {      my $tablefile = ConfigFileFromSelector($filename);
  $tablefile .= "hosts.tab";      if(! (defined $tablefile)) {
     } elsif ($filename eq "domain") {  
  $tablefile .= "domain.tab";  
     } else {  
  return "refused";   return "refused";
     }      }
     #      #
Line 483  sub ReinitProcess { Line 3013  sub ReinitProcess {
     }      }
     return 'ok';      return 'ok';
 }  }
   #   Validate a line in a configuration file edit script:
   #   Validation includes:
   #     - Ensuring the command is valid.
   #     - Ensuring the command has sufficient parameters
   #   Parameters:
   #     scriptline - A line to validate (\n has been stripped for what it's worth).
   #
   #   Return:
   #      0     - Invalid scriptline.
   #      1     - Valid scriptline
   #  NOTE:
   #     Only the command syntax is checked, not the executability of the
   #     command.
   #
   sub isValidEditCommand {
       my $scriptline = shift;
   
       #   Line elements are pipe separated:
   
       my ($command, $key, $newline)  = split(/\|/, $scriptline);
       &logthis('<font color="green"> isValideditCommand checking: '.
        "Command = '$command', Key = '$key', Newline = '$newline' </font>\n");
       
       if ($command eq "delete") {
    #
    #   key with no newline.
    #
    if( ($key eq "") || ($newline ne "")) {
       return 0; # Must have key but no newline.
    } else {
       return 1; # Valid syntax.
    }
       } elsif ($command eq "replace") {
    #
    #   key and newline:
    #
    if (($key eq "") || ($newline eq "")) {
       return 0;
    } else {
       return 1;
    }
       } elsif ($command eq "append") {
    if (($key ne "") && ($newline eq "")) {
       return 1;
    } else {
       return 0;
    }
       } else {
    return 0; # Invalid command.
       }
       return 0; # Should not get here!!!
   }
   #
   #   ApplyEdit - Applies an edit command to a line in a configuration 
   #               file.  It is the caller's responsiblity to validate the
   #               edit line.
   #   Parameters:
   #      $directive - A single edit directive to apply.  
   #                   Edit directives are of the form:
   #                  append|newline      - Appends a new line to the file.
   #                  replace|key|newline - Replaces the line with key value 'key'
   #                  delete|key          - Deletes the line with key value 'key'.
   #      $editor   - A config file editor object that contains the
   #                  file being edited.
   #
   sub ApplyEdit {
       my $directive   = shift;
       my $editor      = shift;
   
       # Break the directive down into its command and its parameters
       # (at most two at this point.  The meaning of the parameters, if in fact
       #  they exist depends on the command).
   
       my ($command, $p1, $p2) = split(/\|/, $directive);
   
       if($command eq "append") {
    $editor->Append($p1);          # p1 - key p2 null.
       } elsif ($command eq "replace") {
    $editor->ReplaceLine($p1, $p2);   # p1 - key p2 = newline.
       } elsif ($command eq "delete") {
    $editor->DeleteLine($p1);         # p1 - key p2 null.
       } else {          # Should not get here!!!
    die "Invalid command given to ApplyEdit $command"
       }
   }
   #
   # AdjustOurHost:
   #           Adjusts a host file stored in a configuration file editor object
   #           for the true IP address of this host. This is necessary for hosts
   #           that live behind a firewall.
   #           Those hosts have a publicly distributed IP of the firewall, but
   #           internally must use their actual IP.  We assume that a given
   #           host only has a single IP interface for now.
   # Formal Parameters:
   #     editor   - The configuration file editor to adjust.  This
   #                editor is assumed to contain a hosts.tab file.
   # Strategy:
   #    - Figure out our hostname.
   #    - Lookup the entry for this host.
   #    - Modify the line to contain our IP
   #    - Do a replace for this host.
   sub AdjustOurHost {
       my $editor        = shift;
   
       # figure out who I am.
   
       my $myHostName    = $perlvar{'lonHostID'}; # LonCAPA hostname.
   
       #  Get my host file entry.
   
       my $ConfigLine    = $editor->Find($myHostName);
       if(! (defined $ConfigLine)) {
    die "AdjustOurHost - no entry for me in hosts file $myHostName";
       }
       # figure out my IP:
       #   Use the config line to get my hostname.
       #   Use gethostbyname to translate that into an IP address.
       #
       my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
       my $BinaryIp = gethostbyname($name);
       my $ip       = inet_ntoa($ip);
       #
       #  Reassemble the config line from the elements in the list.
       #  Note that if the loncnew items were not present before, they will
       #  be now even if they would be empty
       #
       my $newConfigLine = $id;
       foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {
    $newConfigLine .= ":".$item;
       }
       #  Replace the line:
   
       $editor->ReplaceLine($id, $newConfigLine);
       
   }
   #
   #   ReplaceConfigFile:
   #              Replaces a configuration file with the contents of a
   #              configuration file editor object.
   #              This is done by:
   #              - Copying the target file to <filename>.old
   #              - Writing the new file to <filename>.tmp
   #              - Moving <filename.tmp>  -> <filename>
   #              This laborious process ensures that the system is never without
   #              a configuration file that's at least valid (even if the contents
   #              may be dated).
   #   Parameters:
   #        filename   - Name of the file to modify... this is a full path.
   #        editor     - Editor containing the file.
   #
   sub ReplaceConfigFile {
       my $filename  = shift;
       my $editor    = shift;
   
       CopyFile ($filename, $filename.".old");
   
       my $contents  = $editor->Get(); # Get the contents of the file.
   
       InstallFile($filename, $contents);
   }
   #   
   #
   #   Called to edit a configuration table  file
   #   Parameters:
   #      request           - The entire command/request sent by lonc or lonManage
   #   Return:
   #      The reply to send to the client.
   #
   sub EditFile {
       my $request = shift;
   
       #  Split the command into it's pieces:  edit:filetype:script
   
       my ($request, $filetype, $script) = split(/:/, $request,3); # : in script
   
       #  Check the pre-coditions for success:
   
       if($request != "edit") { # Something is amiss afoot alack.
    return "error:edit request detected, but request != 'edit'\n";
       }
       if( ($filetype ne "hosts")  &&
    ($filetype ne "domain")) {
    return "error:edit requested with invalid file specifier: $filetype \n";
       }
   
       #   Split the edit script and check it's validity.
   
       my @scriptlines = split(/\n/, $script);  # one line per element.
       my $linecount   = scalar(@scriptlines);
       for(my $i = 0; $i < $linecount; $i++) {
    chomp($scriptlines[$i]);
    if(!isValidEditCommand($scriptlines[$i])) {
       return "error:edit with bad script line: '$scriptlines[$i]' \n";
    }
       }
   
       #   Execute the edit operation.
       #   - Create a config file editor for the appropriate file and 
       #   - execute each command in the script:
       #
       my $configfile = ConfigFileFromSelector($filetype);
       if (!(defined $configfile)) {
    return "refused\n";
       }
       my $editor = ConfigFileEdit->new($configfile);
   
       for (my $i = 0; $i < $linecount; $i++) {
    ApplyEdit($scriptlines[$i], $editor);
       }
       # If the file is the host file, ensure that our host is
       # adjusted to have our ip:
       #
       if($filetype eq "host") {
    AdjustOurHost($editor);
       }
       #  Finally replace the current file with our file.
       #
       ReplaceConfigFile($configfile, $editor);
   
       return "ok\n";
   }
 #  #
 #  Convert an error return code from lcpasswd to a string value.  #  Convert an error return code from lcpasswd to a string value.
 #  #
Line 513  sub catchexception { Line 3263  sub catchexception {
     my ($error)=@_;      my ($error)=@_;
     $SIG{'QUIT'}='DEFAULT';      $SIG{'QUIT'}='DEFAULT';
     $SIG{__DIE__}='DEFAULT';      $SIG{__DIE__}='DEFAULT';
       &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 $thisserver died through "
      ."a crash with this error msg->[$error]</font>");       ."a crash with this error msg->[$error]</font>");
Line 523  sub catchexception { Line 3274  sub catchexception {
 }  }
   
 sub timeout {  sub timeout {
       &status("Handling Timeout");
     &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");      &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
     &catchexception('Timeout');      &catchexception('Timeout');
 }  }
Line 579  my $children               = 0;        # Line 3331  my $children               = 0;        #
   
 sub REAPER {                        # takes care of dead children  sub REAPER {                        # takes care of dead children
     $SIG{CHLD} = \&REAPER;      $SIG{CHLD} = \&REAPER;
       &status("Handling child death");
     my $pid = wait;      my $pid = wait;
     if (defined($children{$pid})) {      if (defined($children{$pid})) {
  &logthis("Child $pid died");   &logthis("Child $pid died");
Line 587  sub REAPER {                        # ta Line 3340  sub REAPER {                        # ta
     } else {      } else {
  &logthis("Unknown Child $pid died");   &logthis("Unknown Child $pid died");
     }      }
       &status("Finished Handling child death");
 }  }
   
 sub HUNTSMAN {                      # signal handler for SIGINT  sub HUNTSMAN {                      # signal handler for SIGINT
       &status("Killing children (INT)");
     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children      local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
     kill 'INT' => keys %children;      kill 'INT' => keys %children;
     &logthis("Free socket: ".shutdown($server,2)); # free up socket      &logthis("Free socket: ".shutdown($server,2)); # free up socket
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unlink("$execdir/logs/lond.pid");      unlink("$execdir/logs/lond.pid");
     &logthis("<font color=red>CRITICAL: Shutting down</font>");      &logthis("<font color=red>CRITICAL: Shutting down</font>");
       &status("Done killing children");
     exit;                           # clean up with dignity      exit;                           # clean up with dignity
 }  }
   
 sub HUPSMAN {                      # signal handler for SIGHUP  sub HUPSMAN {                      # signal handler for SIGHUP
     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children      local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
       &status("Killing children for restart (HUP)");
     kill 'INT' => keys %children;      kill 'INT' => keys %children;
     &logthis("Free socket: ".shutdown($server,2)); # free up socket      &logthis("Free socket: ".shutdown($server,2)); # free up socket
     &logthis("<font color=red>CRITICAL: Restarting</font>");      &logthis("<font color=red>CRITICAL: Restarting</font>");
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unlink("$execdir/logs/lond.pid");      unlink("$execdir/logs/lond.pid");
       &status("Restarting self (HUP)");
     exec("$execdir/lond");         # here we go again      exec("$execdir/lond");         # here we go again
 }  }
   
Line 667  sub ReloadApache { Line 3425  sub ReloadApache {
 #     now be honored.  #     now be honored.
 #  #
 sub UpdateHosts {  sub UpdateHosts {
       &status("Reload hosts.tab");
     logthis('<font color="blue"> Updating connections </font>');      logthis('<font color="blue"> Updating connections </font>');
     #      #
     #  The %children hash has the set of IP's we currently have children      #  The %children hash has the set of IP's we currently have children
Line 691  sub UpdateHosts { Line 3450  sub UpdateHosts {
  }   }
     }      }
     ReloadApache;      ReloadApache;
       &status("Finished reloading hosts.tab");
 }  }
   
   
 sub checkchildren {  sub checkchildren {
       &status("Checking on the children (sending signals)");
     &initnewstatus();      &initnewstatus();
     &logstatus();      &logstatus();
     &logthis('Going to check on the children');      &logthis('Going to check on the children');
Line 709  sub checkchildren { Line 3470  sub checkchildren {
     sleep 5;      sleep 5;
     $SIG{ALRM} = sub { die "timeout" };      $SIG{ALRM} = sub { die "timeout" };
     $SIG{__DIE__} = 'DEFAULT';      $SIG{__DIE__} = 'DEFAULT';
       &status("Checking on the children (waiting for reports)");
     foreach (sort keys %children) {      foreach (sort keys %children) {
         unless (-e "$docdir/lon-status/londchld/$_.txt") {          unless (-e "$docdir/lon-status/londchld/$_.txt") {
           eval {            eval {
Line 726  sub checkchildren { Line 3488  sub checkchildren {
     }      }
     $SIG{ALRM} = 'DEFAULT';      $SIG{ALRM} = 'DEFAULT';
     $SIG{__DIE__} = \&catchexception;      $SIG{__DIE__} = \&catchexception;
       &status("Finished checking children");
 }  }
   
 # --------------------------------------------------------------------- Logging  # --------------------------------------------------------------------- Logging
Line 756  sub Debug { Line 3519  sub Debug {
 #     reply   - Text to send to client.  #     reply   - Text to send to client.
 #     request - Original request from client.  #     request - Original request from client.
 #  #
   #  Note: This increments Transactions
   #
 sub Reply {  sub Reply {
       alarm(120);
     my $fd      = shift;      my $fd      = shift;
     my $reply   = shift;      my $reply   = shift;
     my $request = shift;      my $request = shift;
Line 764  sub Reply { Line 3530  sub Reply {
     print $fd $reply;      print $fd $reply;
     Debug("Request was $request  Reply was $reply");      Debug("Request was $request  Reply was $reply");
   
       $Transactions++;
       alarm(0);
   
   
   }
   #
   #    Sub to report a failure.
   #    This function:
   #     -   Increments the failure statistic counters.
   #     -   Invokes Reply to send the error message to the client.
   # Parameters:
   #    fd       - File descriptor open on the client
   #    reply    - Reply text to emit.
   #    request  - The original request message (used by Reply
   #               to debug if that's enabled.
   # Implicit outputs:
   #    $Failures- The number of failures is incremented.
   #    Reply (invoked here) sends a message to the 
   #    client:
   #
   sub Failure {
      my $fd      = shift;
      my $reply   = shift;
      my $request = shift;
      
      $Failures++;
      Reply($fd, $reply, $request);      # That's simple eh?
 }  }
 # ------------------------------------------------------------------ Log status  # ------------------------------------------------------------------ Log status
   
 sub logstatus {  sub logstatus {
     my $docdir=$perlvar{'lonDocRoot'};     &status("Doing logging");
     {     my $docdir=$perlvar{'lonDocRoot'};
     my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");     {
     print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";        my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
     $fh->close();        print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
     }        $fh->close();
     {     }
  my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");     &status("Finished londstatus.txt");
         print $fh $status."\n".$lastlog."\n".time;     {
         $fh->close();        my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
     }        print $fh $status."\n".$lastlog."\n".time;
         $fh->close();
      }
      ResetStatistics;
      &status("Finished logging");
      
 }  }
   
 sub initnewstatus {  sub initnewstatus {
Line 800  sub status { Line 3598  sub status {
     my $what=shift;      my $what=shift;
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     $status=$local.': '.$what;      my $status = "lond: $what $local ";
     $0='lond: '.$what.' '.$local;      if($Transactions) {
          $status .= " Transactions: $Transactions Failed; $Failures";
       }
       $0=$status;
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  # -------------------------------------------------------- Escape Special Chars
Line 960  $SIG{USR2} = \&UpdateHosts; Line 3761  $SIG{USR2} = \&UpdateHosts;
   
 ReadHostTable;  ReadHostTable;
   
   
 # --------------------------------------------------------------  # --------------------------------------------------------------
 #   Accept connections.  When a connection comes in, it is validated  #   Accept connections.  When a connection comes in, it is validated
 #   and if good, a child process is created to process transactions  #   and if good, a child process is created to process transactions
 #   along the connection.  #   along the connection.
   
 while (1) {  while (1) {
       &status('Starting accept');
     $client = $server->accept() or next;      $client = $server->accept() or next;
       &status('Accepted '.$client.' off to spawn');
     make_new_child($client);      make_new_child($client);
       &status('Finished spawning');
 }  }
   
 sub make_new_child {  sub make_new_child {
     my $pid;      my $pid;
     my $cipher;  
     my $sigset;      my $sigset;
   
     $client = shift;      $client = shift;
       &status('Starting new child '.$client);
     &logthis('<font color="green"> Attempting to start child ('.$client.      &logthis('<font color="green"> Attempting to start child ('.$client.
      ")</font>");           ")</font>");    
     # block signal for fork      # block signal for fork
Line 1018  sub make_new_child { Line 3823  sub make_new_child {
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
   
         my $tmpsnum=0;  
 #---------------------------------------------------- kerberos 5 initialization  
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
         &Authen::Krb5::init_ets();          &Authen::Krb5::init_ets();
   
Line 1093  sub make_new_child { Line 3898  sub make_new_child {
     }      }
     &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  
     while (my $userinput=<$client>) {  
                 chomp($userinput);  
  Debug("Request = $userinput\n");  
                 &status('Processing '.$clientname.': '.$userinput);  
                 my $wasenc=0;  
                 alarm(120);  
 # ------------------------------------------------------------ See if encrypted  
  if ($userinput =~ /^enc/) {  
     if ($cipher) {  
  my ($cmd,$cmdlength,$encinput)=split(/:/,$userinput);  
  $userinput='';  
  for (my $encidx=0;$encidx<length($encinput);$encidx+=16) {  
     $userinput.=  
  $cipher->decrypt(  
  pack("H16",substr($encinput,$encidx,16))  
  );  
  }  
  $userinput=substr($userinput,0,$cmdlength);  
  $wasenc=1;  
     }  
  }  
   
 # ------------------------------------------------------------- Normal commands  
 # ------------------------------------------------------------------------ ping  
  if ($userinput =~ /^ping/) { # client only  
     if(isClient) {  
  print $client "$currenthostid\n";  
     } else {  
  Reply($client, "refused\n", $userinput);  
     }  
 # ------------------------------------------------------------------------ pong  
  }elsif ($userinput =~ /^pong/) { # client only  
     if(isClient) {  
  my $reply=&reply("ping",$clientname);  
  print $client "$currenthostid:$reply\n";   
     } else {  
  Reply($client, "refused\n", $userinput);  
     }  
 # ------------------------------------------------------------------------ ekey  
  } elsif ($userinput =~ /^ekey/) { # ok for both clients & mgrs  
     my $buildkey=time.$$.int(rand 100000);  
     $buildkey=~tr/1-6/A-F/;  
     $buildkey=int(rand 100000).$buildkey.int(rand 100000);  
     my $key=$currenthostid.$clientname;  
     $key=~tr/a-z/A-Z/;  
     $key=~tr/G-P/0-9/;  
     $key=~tr/Q-Z/0-9/;  
     $key=$key.$buildkey.$key.$buildkey.$key.$buildkey;  
     $key=substr($key,0,32);  
     my $cipherkey=pack("H32",$key);  
     $cipher=new IDEA $cipherkey;  
     print $client "$buildkey\n";   
 # ------------------------------------------------------------------------ load  
  } elsif ($userinput =~ /^load/) { # client only  
     if (isClient) {  
  my $loadavg;  
  {  
     my $loadfile=IO::File->new('/proc/loadavg');  
     $loadavg=<$loadfile>;  
  }  
  $loadavg =~ s/\s.*//g;  
  my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};  
  print $client "$loadpercent\n";  
     } else {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # -------------------------------------------------------------------- userload  
  } elsif ($userinput =~ /^userload/) { # client only  
     if(isClient) {  
  my $userloadpercent=&userload();  
  print $client "$userloadpercent\n";  
     } else {  
  Reply($client, "refused\n", $userinput);  
        
     }  
 #  
 #        Transactions requiring encryption:  
 #  
 # ----------------------------------------------------------------- currentauth  
  } elsif ($userinput =~ /^currentauth/) {  
     if (($wasenc==1)  && isClient) { # Encoded & client only.  
  my ($cmd,$udom,$uname)=split(/:/,$userinput);  
  my $result = GetAuthType($udom, $uname);  
  if($result eq "nouser") {  
     print $client "unknown_user\n";  
  }  
  else {  
     print $client "$result\n"  
     }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 #--------------------------------------------------------------------- pushfile  
  } elsif($userinput =~ /^pushfile/) { # encoded & manager.  
     if(($wasenc == 1) && isManager) {  
  my $cert = GetCertificate($userinput);  
  if(ValidManager($cert)) {  
     my $reply = PushFile($userinput);  
     print $client "$reply\n";  
  } else {  
     print $client "refused\n";  
  }   
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 #--------------------------------------------------------------------- reinit  
  } elsif($userinput =~ /^reinit/) { # Encoded and manager  
     if (($wasenc == 1) && isManager) {  
  my $cert = GetCertificate($userinput);  
  if(ValidManager($cert)) {  
     chomp($userinput);  
     my $reply = ReinitProcess($userinput);  
     print $client  "$reply\n";  
  } else {  
     print $client "refused\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
       ResetStatistics();
   
     }  # ------------------------------------------------------------ Process requests
 # ------------------------------------------------------------------------ auth      my $KeepGoing = 1;
  } elsif ($userinput =~ /^auth/) { # Encoded and client only.      while ((my $userinput=GetRequest) && $KeepGoing) {
     if (($wasenc==1) && isClient) {   $KeepGoing = ProcessRequest($userinput);
  my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);  
  chomp($upass);  
  $upass=unescape($upass);  
  my $proname=propath($udom,$uname);  
  my $passfilename="$proname/passwd";  
  if (-e $passfilename) {  
     my $pf = IO::File->new($passfilename);  
     my $realpasswd=<$pf>;  
     chomp($realpasswd);  
     my ($howpwd,$contentpwd)=split(/:/,$realpasswd);  
     my $pwdcorrect=0;  
     if ($howpwd eq 'internal') {  
  &Debug("Internal auth");  
  $pwdcorrect=  
     (crypt($upass,$contentpwd) eq $contentpwd);  
     } elsif ($howpwd eq 'unix') {  
  &Debug("Unix auth");  
  if((getpwnam($uname))[1] eq "") { #no such user!  
     $pwdcorrect = 0;  
  } else {  
     $contentpwd=(getpwnam($uname))[1];  
     my $pwauth_path="/usr/local/sbin/pwauth";  
     unless ($contentpwd eq 'x') {  
  $pwdcorrect=  
     (crypt($upass,$contentpwd) eq   
      $contentpwd);  
     }  
       
     elsif (-e $pwauth_path) {  
  open PWAUTH, "|$pwauth_path" or  
     die "Cannot invoke authentication";  
  print PWAUTH "$uname\n$upass\n";  
  close PWAUTH;  
  $pwdcorrect=!$?;  
     }  
  }  
     } elsif ($howpwd eq 'krb4') {  
  my $null=pack("C",0);  
  unless ($upass=~/$null/) {  
     my $krb4_error = &Authen::Krb4::get_pw_in_tkt  
  ($uname,"",$contentpwd,'krbtgt',  
  $contentpwd,1,$upass);  
     if (!$krb4_error) {  
  $pwdcorrect = 1;  
     } else {   
  $pwdcorrect=0;   
  # log error if it is not a bad password  
  if ($krb4_error != 62) {  
     &logthis('krb4:'.$uname.','.$contentpwd.','.  
      &Authen::Krb4::get_err_txt($Authen::Krb4::error));  
  }  
     }  
  }  
     } elsif ($howpwd eq 'krb5') {  
  my $null=pack("C",0);  
  unless ($upass=~/$null/) {  
     my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$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,$upass,$credentials);  
 #  unless ($krbreturn) {  
 #      &logthis("Krb5 Error: ".  
 #       &Authen::Krb5::error());  
 #  }  
     $pwdcorrect = ($krbreturn == 1);  
  } else { $pwdcorrect=0; }  
     } elsif ($howpwd eq 'localauth') {  
  $pwdcorrect=&localauth::localauth($uname,$upass,  
   $contentpwd);  
     }  
     if ($pwdcorrect) {  
  print $client "authorized\n";  
     } else {  
  print $client "non_authorized\n";  
     }    
  } else {  
     print $client "unknown_user\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # ---------------------------------------------------------------------- passwd  
  } elsif ($userinput =~ /^passwd/) { # encoded and client  
     if (($wasenc==1) && isClient) {  
  my   
     ($cmd,$udom,$uname,$upass,$npass)=split(/:/,$userinput);  
  chomp($npass);  
  $upass=&unescape($upass);  
  $npass=&unescape($npass);  
  &Debug("Trying to change password for $uname");  
  my $proname=propath($udom,$uname);  
  my $passfilename="$proname/passwd";  
  if (-e $passfilename) {  
     my $realpasswd;  
     { my $pf = IO::File->new($passfilename);  
       $realpasswd=<$pf>; }  
     chomp($realpasswd);  
     my ($howpwd,$contentpwd)=split(/:/,$realpasswd);  
     if ($howpwd eq 'internal') {  
  &Debug("internal auth");  
  if (crypt($upass,$contentpwd) eq $contentpwd) {  
     my $salt=time;  
     $salt=substr($salt,6,2);  
     my $ncpass=crypt($npass,$salt);  
     {  
  my $pf;  
  if ($pf = IO::File->new(">$passfilename")) {  
     print $pf "internal:$ncpass\n";  
     &logthis("Result of password change for $uname: pwchange_success");  
     print $client "ok\n";  
  } else {  
     &logthis("Unable to open $uname passwd to change password");  
     print $client "non_authorized\n";  
  }  
     }               
       
  } else {  
     print $client "non_authorized\n";  
  }  
     } elsif ($howpwd eq 'unix') {  
  # Unix means we have to access /etc/password  
  # one way or another.  
  # First: Make sure the current password is  
  #        correct  
  &Debug("auth is unix");  
  $contentpwd=(getpwnam($uname))[1];  
  my $pwdcorrect = "0";  
  my $pwauth_path="/usr/local/sbin/pwauth";  
  unless ($contentpwd eq 'x') {  
     $pwdcorrect=  
  (crypt($upass,$contentpwd) eq $contentpwd);  
  } elsif (-e $pwauth_path) {  
     open PWAUTH, "|$pwauth_path" or  
  die "Cannot invoke authentication";  
     print PWAUTH "$uname\n$upass\n";  
     close PWAUTH;  
     &Debug("exited pwauth with $? ($uname,$upass) ");  
     $pwdcorrect=($? == 0);  
  }  
  if ($pwdcorrect) {  
     my $execdir=$perlvar{'lonDaemons'};  
     &Debug("Opening lcpasswd pipeline");  
     my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log");  
     print $pf "$uname\n$npass\n$npass\n";  
     close $pf;  
     my $err = $?;  
     my $result = ($err>0 ? 'pwchange_failure'   
   : 'ok');  
     &logthis("Result of password change for $uname: ".  
      &lcpasswdstrerror($?));  
     print $client "$result\n";  
  } else {  
     print $client "non_authorized\n";  
  }  
     } else {  
  print $client "auth_mode_error\n";  
     }    
  } else {  
     print $client "unknown_user\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # -------------------------------------------------------------------- makeuser  
  } elsif ($userinput =~ /^makeuser/) { # encoded and client.  
     &Debug("Make user received");  
     my $oldumask=umask(0077);  
     if (($wasenc==1) && isClient) {  
  my   
     ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);  
  &Debug("cmd =".$cmd." $udom =".$udom.  
        " uname=".$uname);  
  chomp($npass);  
  $npass=&unescape($npass);  
  my $proname=propath($udom,$uname);  
  my $passfilename="$proname/passwd";  
  &Debug("Password file created will be:".  
        $passfilename);  
  if (-e $passfilename) {  
     print $client "already_exists\n";  
  } elsif ($udom ne $currentdomainid) {  
     print $client "not_right_domain\n";  
  } else {  
     my @fpparts=split(/\//,$proname);  
     my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];  
     my $fperror='';  
     for (my $i=3;$i<=$#fpparts;$i++) {  
  $fpnow.='/'.$fpparts[$i];   
  unless (-e $fpnow) {  
     unless (mkdir($fpnow,0777)) {  
  $fperror="error: ".($!+0)  
     ." mkdir failed while attempting "  
     ."makeuser\n";  
     }  
  }  
     }  
     unless ($fperror) {  
  my $result=&make_passwd_file($uname, $umode,$npass,  
      $passfilename);  
  print $client $result;  
     } else {  
  print $client "$fperror\n";  
     }  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
         
     }  
     umask($oldumask);  
 # -------------------------------------------------------------- changeuserauth  
  } elsif ($userinput =~ /^changeuserauth/) { # encoded & client  
     &Debug("Changing authorization");  
     if (($wasenc==1) && isClient) {  
  my   
     ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);  
  chomp($npass);  
  &Debug("cmd = ".$cmd." domain= ".$udom.  
        "uname =".$uname." umode= ".$umode);  
  $npass=&unescape($npass);  
  my $proname=&propath($udom,$uname);  
  my $passfilename="$proname/passwd";  
  if ($udom ne $currentdomainid) {  
     print $client "not_right_domain\n";  
  } else {  
     my $result=&make_passwd_file($uname, $umode,$npass,  
  $passfilename);  
     print $client $result;  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
      
     }  
 # ------------------------------------------------------------------------ home  
  } elsif ($userinput =~ /^home/) { # client clear or encoded  
     if(isClient) {  
  my ($cmd,$udom,$uname)=split(/:/,$userinput);  
  chomp($uname);  
  my $proname=propath($udom,$uname);  
  if (-e $proname) {  
     print $client "found\n";  
  } else {  
     print $client "not_found\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # ---------------------------------------------------------------------- update  
  } elsif ($userinput =~ /^update/) { # client clear or encoded.  
     if(isClient) {  
  my ($cmd,$fname)=split(/:/,$userinput);  
  my $ownership=ishome($fname);  
  if ($ownership eq 'not_owner') {  
     if (-e $fname) {  
  my ($dev,$ino,$mode,$nlink,  
     $uid,$gid,$rdev,$size,  
     $atime,$mtime,$ctime,  
     $blksize,$blocks)=stat($fname);  
  my $now=time;  
  my $since=$now-$atime;  
  if ($since>$perlvar{'lonExpire'}) {  
     my $reply=  
  &reply("unsub:$fname","$clientname");  
     unlink("$fname");  
  } else {  
     my $transname="$fname.in.transfer";  
     my $remoteurl=  
  &reply("sub:$fname","$clientname");  
     my $response;  
     {  
  my $ua=new LWP::UserAgent;  
  my $request=new HTTP::Request('GET',"$remoteurl");  
  $response=$ua->request($request,$transname);  
     }  
     if ($response->is_error()) {  
  unlink($transname);  
  my $message=$response->status_line;  
  &logthis(  
  "LWP GET: $message for $fname ($remoteurl)");  
     } else {  
  if ($remoteurl!~/\.meta$/) {  
     my $ua=new LWP::UserAgent;  
     my $mrequest=  
  new HTTP::Request('GET',$remoteurl.'.meta');  
     my $mresponse=  
  $ua->request($mrequest,$fname.'.meta');  
     if ($mresponse->is_error()) {  
  unlink($fname.'.meta');  
     }  
  }  
  rename($transname,$fname);  
     }  
  }  
  print $client "ok\n";  
     } else {  
  print $client "not_found\n";  
     }  
  } else {  
     print $client "rejected\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # -------------------------------------- fetch a user file from a remote server  
  } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.  
     if(isClient) {  
  my ($cmd,$fname)=split(/:/,$userinput);  
  my ($udom,$uname,$ufile)=split(/\//,$fname);  
  my $udir=propath($udom,$uname).'/userfiles';  
  unless (-e $udir) { mkdir($udir,0770); }  
  if (-e $udir) {  
     $ufile=~s/^[\.\~]+//;  
     $ufile=~s/\///g;  
     my $destname=$udir.'/'.$ufile;  
     my $transname=$udir.'/'.$ufile.'.in.transit';  
     my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;  
     my $response;  
     {  
  my $ua=new LWP::UserAgent;  
  my $request=new HTTP::Request('GET',"$remoteurl");  
  $response=$ua->request($request,$transname);  
     }  
     if ($response->is_error()) {  
  unlink($transname);  
  my $message=$response->status_line;  
  &logthis("LWP GET: $message for $fname ($remoteurl)");  
  print $client "failed\n";  
     } else {  
  if (!rename($transname,$destname)) {  
     &logthis("Unable to move $transname to $destname");  
     unlink($transname);  
     print $client "failed\n";  
  } else {  
     print $client "ok\n";  
  }  
     }  
  } else {  
     print $client "not_home\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # ------------------------------------------ authenticate access to a user file  
  } elsif ($userinput =~ /^tokenauthuserfile/) { # Client only  
     if(isClient) {  
  my ($cmd,$fname,$session)=split(/:/,$userinput);  
  chomp($session);  
  my $reply='non_auth';  
  if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.  
  $session.'.id')) {  
     while (my $line=<ENVIN>) {  
  if ($line=~/userfile\.$fname\=/) { $reply='ok'; }  
     }  
     close(ENVIN);  
     print $client $reply."\n";  
  } else {  
     print $client "invalid_token\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # ----------------------------------------------------------------- unsubscribe  
  } elsif ($userinput =~ /^unsub/) {  
     if(isClient) {  
  my ($cmd,$fname)=split(/:/,$userinput);  
  if (-e $fname) {  
     print $client &unsub($client,$fname,$clientip);  
  } else {  
     print $client "not_found\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # ------------------------------------------------------------------- subscribe  
  } elsif ($userinput =~ /^sub/) {  
     if(isClient) {  
  print $client &subscribe($userinput,$clientip);  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # ------------------------------------------------------------- current version  
  } elsif ($userinput =~ /^currentversion/) {  
     if(isClient) {  
  my ($cmd,$fname)=split(/:/,$userinput);  
  print $client &currentversion($fname)."\n";  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # ------------------------------------------------------------------------- log  
  } elsif ($userinput =~ /^log/) {  
     if(isClient) {  
  my ($cmd,$udom,$uname,$what)=split(/:/,$userinput);  
  chomp($what);  
  my $proname=propath($udom,$uname);  
  my $now=time;  
  {  
     my $hfh;  
     if ($hfh=IO::File->new(">>$proname/activity.log")) {   
  print $hfh "$now:$clientname:$what\n";  
  print $client "ok\n";   
     } else {  
  print $client "error: ".($!+0)  
     ." IO::File->new Failed "  
     ."while attempting log\n";  
     }  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # ------------------------------------------------------------------------- put  
  } elsif ($userinput =~ /^put/) {  
     if(isClient) {  
  my ($cmd,$udom,$uname,$namespace,$what)  
     =split(/:/,$userinput);  
  $namespace=~s/\//\_/g;  
  $namespace=~s/\W//g;  
  if ($namespace ne 'roles') {  
     chomp($what);  
     my $proname=propath($udom,$uname);  
     my $now=time;  
     unless ($namespace=~/^nohist\_/) {  
  my $hfh;  
  if (  
     $hfh=IO::File->new(">>$proname/$namespace.hist")  
     ) { print $hfh "P:$now:$what\n"; }  
     }  
     my @pairs=split(/\&/,$what);  
     my %hash;  
     if (tie(%hash,'GDBM_File',  
     "$proname/$namespace.db",  
     &GDBM_WRCREAT(),0640)) {  
  foreach my $pair (@pairs) {  
     my ($key,$value)=split(/=/,$pair);  
     $hash{$key}=$value;  
  }  
  if (untie(%hash)) {  
     print $client "ok\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) failed ".  
  "while attempting put\n";  
  }  
     } else {  
  print $client "error: ".($!)  
     ." tie(GDBM) Failed ".  
     "while attempting put\n";  
     }  
  } else {  
     print $client "refused\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # ------------------------------------------------------------------- inc  
  } elsif ($userinput =~ /^inc:/) {  
     if(isClient) {  
  my ($cmd,$udom,$uname,$namespace,$what)  
     =split(/:/,$userinput);  
  $namespace=~s/\//\_/g;  
  $namespace=~s/\W//g;  
  if ($namespace ne 'roles') {  
     chomp($what);  
     my $proname=propath($udom,$uname);  
     my $now=time;  
     unless ($namespace=~/^nohist\_/) {  
  my $hfh;  
  if (  
     $hfh=IO::File->new(">>$proname/$namespace.hist")  
     ) { print $hfh "P:$now:$what\n"; }  
     }  
     my @pairs=split(/\&/,$what);  
     my %hash;  
     if (tie(%hash,'GDBM_File',  
     "$proname/$namespace.db",  
     &GDBM_WRCREAT(),0640)) {  
  foreach my $pair (@pairs) {  
     my ($key,$value)=split(/=/,$pair);  
                                     # We could check that we have a number...  
                                     if (! defined($value) || $value eq '') {  
                                         $value = 1;  
                                     }  
     $hash{$key}+=$value;  
  }  
  if (untie(%hash)) {  
     print $client "ok\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) failed ".  
  "while attempting put\n";  
  }  
     } else {  
  print $client "error: ".($!)  
     ." tie(GDBM) Failed ".  
     "while attempting put\n";  
     }  
  } else {  
     print $client "refused\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # -------------------------------------------------------------------- rolesput  
  } elsif ($userinput =~ /^rolesput/) {  
     if(isClient) {  
  &Debug("rolesput");  
  if ($wasenc==1) {  
     my ($cmd,$exedom,$exeuser,$udom,$uname,$what)  
  =split(/:/,$userinput);  
     &Debug("cmd = ".$cmd." exedom= ".$exedom.  
    "user = ".$exeuser." udom=".$udom.  
    "what = ".$what);  
     my $namespace='roles';  
     chomp($what);  
     my $proname=propath($udom,$uname);  
     my $now=time;  
     {  
  my $hfh;  
  if (  
     $hfh=IO::File->new(">>$proname/$namespace.hist")  
     ) {   
     print $hfh "P:$now:$exedom:$exeuser:$what\n";  
  }  
     }  
     my @pairs=split(/\&/,$what);  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
  foreach my $pair (@pairs) {  
     my ($key,$value)=split(/=/,$pair);  
     &ManagePermissions($key, $udom, $uname,  
        &GetAuthType( $udom,   
      $uname));  
     $hash{$key}=$value;  
  }  
  if (untie(%hash)) {  
     print $client "ok\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting rolesput\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting rolesput\n";  
     }  
  } else {  
     print $client "refused\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
     
     }  
 # -------------------------------------------------------------------- rolesdel  
  } elsif ($userinput =~ /^rolesdel/) {  
     if(isClient) {  
  &Debug("rolesdel");  
  if ($wasenc==1) {  
     my ($cmd,$exedom,$exeuser,$udom,$uname,$what)  
  =split(/:/,$userinput);  
     &Debug("cmd = ".$cmd." exedom= ".$exedom.  
    "user = ".$exeuser." udom=".$udom.  
    "what = ".$what);  
     my $namespace='roles';  
     chomp($what);  
     my $proname=propath($udom,$uname);  
     my $now=time;  
     {  
  my $hfh;  
  if (  
     $hfh=IO::File->new(">>$proname/$namespace.hist")  
     ) {   
     print $hfh "D:$now:$exedom:$exeuser:$what\n";  
  }  
     }  
     my @rolekeys=split(/\&/,$what);  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
  foreach my $key (@rolekeys) {  
     delete $hash{$key};  
  }  
  if (untie(%hash)) {  
     print $client "ok\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting rolesdel\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting rolesdel\n";  
     }  
  } else {  
     print $client "refused\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
         
     }  
 # ------------------------------------------------------------------------- get  
  } elsif ($userinput =~ /^get/) {  
     if(isClient) {  
  my ($cmd,$udom,$uname,$namespace,$what)  
     =split(/:/,$userinput);  
  $namespace=~s/\//\_/g;  
  $namespace=~s/\W//g;  
  chomp($what);  
  my @queries=split(/\&/,$what);  
  my $proname=propath($udom,$uname);  
  my $qresult='';  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
     for (my $i=0;$i<=$#queries;$i++) {  
  $qresult.="$hash{$queries[$i]}&";  
     }  
     if (untie(%hash)) {  
  $qresult=~s/\&$//;  
  print $client "$qresult\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting get\n";  
     }  
  } else {  
     if ($!+0 == 2) {  
  print $client "error:No such file or ".  
     "GDBM reported bad block error\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting get\n";  
     }  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # ------------------------------------------------------------------------ eget  
  } elsif ($userinput =~ /^eget/) {  
     if (isClient) {  
  my ($cmd,$udom,$uname,$namespace,$what)  
     =split(/:/,$userinput);  
  $namespace=~s/\//\_/g;  
  $namespace=~s/\W//g;  
  chomp($what);  
  my @queries=split(/\&/,$what);  
  my $proname=propath($udom,$uname);  
  my $qresult='';  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
     for (my $i=0;$i<=$#queries;$i++) {  
  $qresult.="$hash{$queries[$i]}&";  
     }  
     if (untie(%hash)) {  
  $qresult=~s/\&$//;  
  if ($cipher) {  
     my $cmdlength=length($qresult);  
     $qresult.="         ";  
     my $encqresult='';  
     for   
  (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {  
     $encqresult.=  
  unpack("H16",  
        $cipher->encrypt(substr($qresult,$encidx,8)));  
  }  
     print $client "enc:$cmdlength:$encqresult\n";  
  } else {  
     print $client "error:no_key\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting eget\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting eget\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
       
     }  
 # ------------------------------------------------------------------------- del  
  } elsif ($userinput =~ /^del/) {  
     if(isClient) {  
  my ($cmd,$udom,$uname,$namespace,$what)  
     =split(/:/,$userinput);  
  $namespace=~s/\//\_/g;  
  $namespace=~s/\W//g;  
  chomp($what);  
  my $proname=propath($udom,$uname);  
  my $now=time;  
  unless ($namespace=~/^nohist\_/) {  
     my $hfh;  
     if (  
  $hfh=IO::File->new(">>$proname/$namespace.hist")  
  ) { print $hfh "D:$now:$what\n"; }  
  }  
  my @keys=split(/\&/,$what);  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
     foreach my $key (@keys) {  
  delete($hash{$key});  
     }  
     if (untie(%hash)) {  
  print $client "ok\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting del\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting del\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
   
     }  
 # ------------------------------------------------------------------------ keys  
  } elsif ($userinput =~ /^keys/) {  
     if(isClient) {  
  my ($cmd,$udom,$uname,$namespace)  
     =split(/:/,$userinput);  
  $namespace=~s/\//\_/g;  
  $namespace=~s/\W//g;  
  my $proname=propath($udom,$uname);  
  my $qresult='';  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
     foreach my $key (keys %hash) {  
  $qresult.="$key&";  
     }  
     if (untie(%hash)) {  
  $qresult=~s/\&$//;  
  print $client "$qresult\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting keys\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting keys\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
      
     }  
 # ----------------------------------------------------------------- dumpcurrent  
  } elsif ($userinput =~ /^currentdump/) {  
     if (isClient) {  
  my ($cmd,$udom,$uname,$namespace)  
     =split(/:/,$userinput);  
  $namespace=~s/\//\_/g;  
  $namespace=~s/\W//g;  
  my $qresult='';  
  my $proname=propath($udom,$uname);  
  my %hash;  
  if (tie(%hash,'GDBM_File',  
  "$proname/$namespace.db",  
  &GDBM_READER(),0640)) {  
     # Structure of %data:  
     # $data{$symb}->{$parameter}=$value;  
     # $data{$symb}->{'v.'.$parameter}=$version;  
     # since $parameter will be unescaped, we do not  
     # have to worry about silly parameter names...  
     my %data = ();  
     while (my ($key,$value) = each(%hash)) {  
  my ($v,$symb,$param) = split(/:/,$key);  
  next if ($v eq 'version' || $symb eq 'keys');  
  next if (exists($data{$symb}) &&   
  exists($data{$symb}->{$param}) &&  
  $data{$symb}->{'v.'.$param} > $v);  
  $data{$symb}->{$param}=$value;  
  $data{$symb}->{'v.'.$param}=$v;  
     }  
     if (untie(%hash)) {  
  while (my ($symb,$param_hash) = each(%data)) {  
     while(my ($param,$value) = each (%$param_hash)){  
  next if ($param =~ /^v\./);  
  $qresult.=$symb.':'.$param.'='.$value.'&';  
     }  
  }  
  chop($qresult);  
  print $client "$qresult\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting currentdump\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting currentdump\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
     }  
 # ------------------------------------------------------------------------ dump  
  } elsif ($userinput =~ /^dump/) {  
     if(isClient) {  
  my ($cmd,$udom,$uname,$namespace,$regexp)  
     =split(/:/,$userinput);  
  $namespace=~s/\//\_/g;  
  $namespace=~s/\W//g;  
  if (defined($regexp)) {  
     $regexp=&unescape($regexp);  
  } else {  
     $regexp='.';  
  }  
  my $qresult='';  
  my $proname=propath($udom,$uname);  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
        study($regexp);  
        while (my ($key,$value) = each(%hash)) {  
    if ($regexp eq '.') {  
        $qresult.=$key.'='.$value.'&';  
    } else {  
        my $unescapeKey = &unescape($key);  
        if (eval('$unescapeKey=~/$regexp/')) {  
    $qresult.="$key=$value&";  
        }  
    }  
        }  
        if (untie(%hash)) {  
    chop($qresult);  
    print $client "$qresult\n";  
        } else {  
    print $client "error: ".($!+0)  
        ." untie(GDBM) Failed ".  
                                        "while attempting dump\n";  
        }  
    } else {  
        print $client "error: ".($!+0)  
    ." tie(GDBM) Failed ".  
    "while attempting dump\n";  
    }  
     } else {  
  Reply($client, "refused\n", $userinput);  
     
     }  
 # ----------------------------------------------------------------------- store  
  } elsif ($userinput =~ /^store/) {  
     if(isClient) {  
  my ($cmd,$udom,$uname,$namespace,$rid,$what)  
     =split(/:/,$userinput);  
  $namespace=~s/\//\_/g;  
  $namespace=~s/\W//g;  
  if ($namespace ne 'roles') {  
     chomp($what);  
     my $proname=propath($udom,$uname);  
     my $now=time;  
     unless ($namespace=~/^nohist\_/) {  
  my $hfh;  
  if (  
     $hfh=IO::File->new(">>$proname/$namespace.hist")  
     ) { print $hfh "P:$now:$rid:$what\n"; }  
     }  
     my @pairs=split(/\&/,$what);  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
  my @previouskeys=split(/&/,$hash{"keys:$rid"});  
  my $key;  
  $hash{"version:$rid"}++;  
  my $version=$hash{"version:$rid"};  
  my $allkeys='';   
  foreach my $pair (@pairs) {  
     my ($key,$value)=split(/=/,$pair);  
     $allkeys.=$key.':';  
     $hash{"$version:$rid:$key"}=$value;  
  }  
  $hash{"$version:$rid:timestamp"}=$now;  
  $allkeys.='timestamp';  
  $hash{"$version:keys:$rid"}=$allkeys;  
  if (untie(%hash)) {  
     print $client "ok\n";  
  } else {  
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".  
  "while attempting store\n";  
  }  
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting store\n";  
     }  
  } else {  
     print $client "refused\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
        
     }  
 # --------------------------------------------------------------------- restore  
  } elsif ($userinput =~ /^restore/) {  
     if(isClient) {  
  my ($cmd,$udom,$uname,$namespace,$rid)  
     =split(/:/,$userinput);  
  $namespace=~s/\//\_/g;  
  $namespace=~s/\W//g;  
  chomp($rid);  
  my $proname=propath($udom,$uname);  
  my $qresult='';  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
     my $version=$hash{"version:$rid"};  
     $qresult.="version=$version&";  
     my $scope;  
     for ($scope=1;$scope<=$version;$scope++) {  
  my $vkeys=$hash{"$scope:keys:$rid"};  
  my @keys=split(/:/,$vkeys);  
  my $key;  
  $qresult.="$scope:keys=$vkeys&";  
  foreach $key (@keys) {  
     $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";  
  }                                    
     }  
     if (untie(%hash)) {  
  $qresult=~s/\&$//;  
  print $client "$qresult\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting restore\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting restore\n";  
  }  
     } else  {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # -------------------------------------------------------------------- chatsend  
  } elsif ($userinput =~ /^chatsend/) {  
     if(isClient) {  
  my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);  
  &chatadd($cdom,$cnum,$newpost);  
  print $client "ok\n";  
     } else {  
  Reply($client, "refused\n", $userinput);  
         
     }  
 # -------------------------------------------------------------------- chatretr  
  } elsif ($userinput =~ /^chatretr/) {  
     if(isClient) {  
  my   
     ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);  
  my $reply='';  
  foreach (&getchat($cdom,$cnum,$udom,$uname)) {  
     $reply.=&escape($_).':';  
  }  
  $reply=~s/\:$//;  
  print $client $reply."\n";  
     } else {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # ------------------------------------------------------------------- querysend  
  } elsif ($userinput =~ /^querysend/) {  
     if(isClient) {  
  my ($cmd,$query,  
     $arg1,$arg2,$arg3)=split(/\:/,$userinput);  
  $query=~s/\n*$//g;  
  print $client "".  
     sqlreply("$clientname\&$query".  
      "\&$arg1"."\&$arg2"."\&$arg3")."\n";  
     } else {  
  Reply($client, "refused\n", $userinput);  
         
     }  
 # ------------------------------------------------------------------ queryreply  
  } elsif ($userinput =~ /^queryreply/) {  
     if(isClient) {  
  my ($cmd,$id,$reply)=split(/:/,$userinput);   
  my $store;  
  my $execdir=$perlvar{'lonDaemons'};  
  if ($store=IO::File->new(">$execdir/tmp/$id")) {  
     $reply=~s/\&/\n/g;  
     print $store $reply;  
     close $store;  
     my $store2=IO::File->new(">$execdir/tmp/$id.end");  
     print $store2 "done\n";  
     close $store2;  
     print $client "ok\n";  
  }  
  else {  
     print $client "error: ".($!+0)  
  ." IO::File->new Failed ".  
  "while attempting queryreply\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
        
     }  
 # ----------------------------------------------------------------- courseidput  
  } elsif ($userinput =~ /^courseidput/) {  
     if(isClient) {  
  my ($cmd,$udom,$what)=split(/:/,$userinput);  
  chomp($what);  
  $udom=~s/\W//g;  
  my $proname=  
     "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";  
  my $now=time;  
  my @pairs=split(/\&/,$what);  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {  
     foreach my $pair (@pairs) {  
  my ($key,$value)=split(/=/,$pair);  
  $hash{$key}=$value.':'.$now;  
     }  
     if (untie(%hash)) {  
  print $client "ok\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting courseidput\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting courseidput\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # ---------------------------------------------------------------- courseiddump  
  } elsif ($userinput =~ /^courseiddump/) {  
     if(isClient) {  
  my ($cmd,$udom,$since,$description)  
     =split(/:/,$userinput);  
  if (defined($description)) {  
     $description=&unescape($description);  
  } else {  
     $description='.';  
  }  
  unless (defined($since)) { $since=0; }  
  my $qresult='';  
  my $proname=  
     "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {  
     while (my ($key,$value) = each(%hash)) {  
  my ($descr,$lasttime)=split(/\:/,$value);  
  if ($lasttime<$since) { next; }  
  if ($description eq '.') {  
     $qresult.=$key.'='.$descr.'&';  
  } else {  
     my $unescapeVal = &unescape($descr);  
     if (eval('$unescapeVal=~/$description/i')) {  
  $qresult.="$key=$descr&";  
     }  
  }  
     }  
     if (untie(%hash)) {  
  chop($qresult);  
  print $client "$qresult\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting courseiddump\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting courseiddump\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # ----------------------------------------------------------------------- idput  
  } elsif ($userinput =~ /^idput/) {  
     if(isClient) {  
  my ($cmd,$udom,$what)=split(/:/,$userinput);  
  chomp($what);  
  $udom=~s/\W//g;  
  my $proname="$perlvar{'lonUsersDir'}/$udom/ids";  
  my $now=time;  
  {  
     my $hfh;  
     if (  
  $hfh=IO::File->new(">>$proname.hist")  
  ) { print $hfh "P:$now:$what\n"; }  
  }  
  my @pairs=split(/\&/,$what);  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {  
     foreach my $pair (@pairs) {  
  my ($key,$value)=split(/=/,$pair);  
  $hash{$key}=$value;  
     }  
     if (untie(%hash)) {  
  print $client "ok\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting idput\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting idput\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # ----------------------------------------------------------------------- idget  
  } elsif ($userinput =~ /^idget/) {  
     if(isClient) {  
  my ($cmd,$udom,$what)=split(/:/,$userinput);  
  chomp($what);  
  $udom=~s/\W//g;  
  my $proname="$perlvar{'lonUsersDir'}/$udom/ids";  
  my @queries=split(/\&/,$what);  
  my $qresult='';  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {  
     for (my $i=0;$i<=$#queries;$i++) {  
  $qresult.="$hash{$queries[$i]}&";  
     }  
     if (untie(%hash)) {  
  $qresult=~s/\&$//;  
  print $client "$qresult\n";  
     } else {  
  print $client "error: ".($!+0)  
     ." untie(GDBM) Failed ".  
     "while attempting idget\n";  
     }  
  } else {  
     print $client "error: ".($!+0)  
  ." tie(GDBM) Failed ".  
  "while attempting idget\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # ---------------------------------------------------------------------- tmpput  
  } elsif ($userinput =~ /^tmpput/) {  
     if(isClient) {  
  my ($cmd,$what)=split(/:/,$userinput);  
  my $store;  
  $tmpsnum++;  
  my $id=$$.'_'.$clientip.'_'.$tmpsnum;  
  $id=~s/\W/\_/g;  
  $what=~s/\n//g;  
  my $execdir=$perlvar{'lonDaemons'};  
  if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {  
     print $store $what;  
     close $store;  
     print $client "$id\n";  
  }  
  else {  
     print $client "error: ".($!+0)  
  ."IO::File->new Failed ".  
  "while attempting tmpput\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
       
     }  
       
 # ---------------------------------------------------------------------- tmpget  
  } elsif ($userinput =~ /^tmpget/) {  
     if(isClient) {  
  my ($cmd,$id)=split(/:/,$userinput);  
  chomp($id);  
  $id=~s/\W/\_/g;  
  my $store;  
  my $execdir=$perlvar{'lonDaemons'};  
  if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {  
     my $reply=<$store>;  
     print $client "$reply\n";  
     close $store;  
  }  
  else {  
     print $client "error: ".($!+0)  
  ."IO::File->new Failed ".  
  "while attempting tmpget\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
         
     }  
 # ---------------------------------------------------------------------- tmpdel  
  } elsif ($userinput =~ /^tmpdel/) {  
     if(isClient) {  
  my ($cmd,$id)=split(/:/,$userinput);  
  chomp($id);  
  $id=~s/\W/\_/g;  
  my $execdir=$perlvar{'lonDaemons'};  
  if (unlink("$execdir/tmp/$id.tmp")) {  
     print $client "ok\n";  
  } else {  
     print $client "error: ".($!+0)  
  ."Unlink tmp Failed ".  
  "while attempting tmpdel\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
        
     }  
 # -------------------------------------------------------------------------- ls  
  } elsif ($userinput =~ /^ls/) {  
     if(isClient) {  
  my ($cmd,$ulsdir)=split(/:/,$userinput);  
  my $ulsout='';  
  my $ulsfn;  
  if (-e $ulsdir) {  
     if(-d $ulsdir) {  
  if (opendir(LSDIR,$ulsdir)) {  
     while ($ulsfn=readdir(LSDIR)) {  
  my @ulsstats=stat($ulsdir.'/'.$ulsfn);  
  $ulsout.=$ulsfn.'&'.  
     join('&',@ulsstats).':';  
     }  
     closedir(LSDIR);  
  }  
     } else {  
  my @ulsstats=stat($ulsdir);  
  $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';  
     }  
  } else {  
     $ulsout='no_such_dir';  
  }  
  if ($ulsout eq '') { $ulsout='empty'; }  
  print $client "$ulsout\n";  
     } else {  
  Reply($client, "refused\n", $userinput);  
        
     }  
 # ----------------------------------------------------------------- setannounce  
  } elsif ($userinput =~ /^setannounce/) {  
     if (isClient) {  
  my ($cmd,$announcement)=split(/:/,$userinput);  
  chomp($announcement);  
  $announcement=&unescape($announcement);  
  if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.  
     '/announcement.txt')) {  
     print $store $announcement;  
     close $store;  
     print $client "ok\n";  
  } else {  
     print $client "error: ".($!+0)."\n";  
  }  
     } else {  
  Reply($client, "refused\n", $userinput);  
          
     }  
 # ------------------------------------------------------------------ Hanging up  
  } elsif (($userinput =~ /^exit/) ||  
  ($userinput =~ /^init/)) { # no restrictions.  
     &logthis(  
      "Client $clientip ($clientname) hanging up: $userinput");  
     print $client "bye\n";  
     $client->close();  
     last;  
   
 # ---------------------------------- set current host/domain  
  } elsif ($userinput =~ /^sethost:/) {  
     if (isClient) {  
  print $client &sethost($userinput)."\n";  
     } else {  
  print $client "refused\n";  
     }  
 #---------------------------------- request file (?) version.  
  } elsif ($userinput =~/^version:/) {  
     if (isClient) {  
  print $client &version($userinput)."\n";  
     } else {  
  print $client "refused\n";  
     }  
 # ------------------------------------------------------------- unknown command  
   
  } else {  
     # unknown command  
     print $client "unknown_cmd\n";  
  }  
 # -------------------------------------------------------------------- complete  # -------------------------------------------------------------------- complete
  alarm(0);  
  &status('Listening to '.$clientname);   &status('Listening to '.$clientname);
     }      }
 # --------------------------------------------- client unknown or fishy, refuse  # --------------------------------------------- client unknown or fishy, refuse
Line 2874  sub version { Line 4256  sub version {
     $remoteVERSION=(split(/:/,$userinput))[1];      $remoteVERSION=(split(/:/,$userinput))[1];
     return "version:$VERSION";      return "version:$VERSION";
 }  }
   ############## >>>>>>>>>>>>>>>>>>>>>>>>>> FUTUREWORK <<<<<<<<<<<<<<<<<<<<<<<<<<<<
 #There is a copy of this in lonnet.pm  #There is a copy of this in lonnet.pm
   #   Can we hoist these lil' things out into common places?
   #
 sub userload {  sub userload {
     my $numusers=0;      my $numusers=0;
     {      {

Removed from v.1.163  
changed lines
  Added in v.1.178.2.2


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