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

Diff for /loncom/lond between versions 1.174 and 1.177

version 1.174, 2004/02/06 05:25:16 version 1.177, 2004/02/18 10:35:56
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 62  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 83  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 119  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);
      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) {
         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.
         #
         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);
      
      
   # ------------------------------------------------------------- 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];
         
         #  Validate the request:
         
         my $ok = 1;
         if($NeedEncode && (!$wasenc)) {
            Reply($client, "refused\n", $userinput);
            $ok = 0;
         }
         if(isClient && (($ClientTypes & $CLIENT_OK) == 0)) {
            Reply($client, "refused\n", $userinput);
            $ok = 0;
         }
         if(isManager && (($ClientTypes & $MANAGER_OK) == 0)) {
            Reply($client, "refused\n", $userinput);
            $ok = 0;
         }
         if($ok) {
            $KeepGoing = &$Handler($command, $tail, $client);
         }
   
   
   
   
   
   # ---------------------------------------------------------------------- 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 137  sub GetCertificate { Line 2649  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 1004  sub Debug { Line 3504  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 1012  sub Reply { Line 3515  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 {
     &status("Doing logging");     &status("Doing logging");
     my $docdir=$perlvar{'lonDocRoot'};     my $docdir=$perlvar{'lonDocRoot'};
     {     {
     my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");        my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
     print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";        print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";
     $fh->close();        $fh->close();
     }     }
     &status("Finished londstatus.txt");     &status("Finished londstatus.txt");
     {     {
  my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");        my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
         print $fh $status."\n".$lastlog."\n".time;        print $fh $status."\n".$lastlog."\n".time;
         $fh->close();        $fh->close();
     }     }
     &status("Finished logging");     ResetStatistics;
      &status("Finished logging");
      
 }  }
   
 sub initnewstatus {  sub initnewstatus {
Line 1051  sub status { Line 3583  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 1211  $SIG{USR2} = \&UpdateHosts; Line 3746  $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
Line 1226  while (1) { Line 3762  while (1) {
   
 sub make_new_child {  sub make_new_child {
     my $pid;      my $pid;
     my $cipher;  
     my $sigset;      my $sigset;
   
     $client = shift;      $client = shift;
Line 1273  sub make_new_child { Line 3808  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 1348  sub make_new_child { Line 3883  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);  
  }  
 #------------------------------------------------------------------------- edit  
     } elsif ($userinput =~ /^edit/) {    # encoded and manager:  
  if(($wasenc ==1) && (isManager)) {  
     my $cert = GetCertificate($userinput);  
     if(ValidManager($cert)) {  
                my($command, $filetype, $script) = split(/:/, $userinput);  
                if (($filetype eq "hosts") || ($filetype eq "domain")) {  
                   if($script ne "") {  
       Reply($client, EditFile($userinput));  
                   } else {  
                      Reply($client,"refused\n",$userinput);  
                   }  
                } else {  
                   Reply($client,"refused\n",$userinput);  
                }  
             } else {  
                Reply($client,"refused\n",$userinput);  
             }  
          } else {  
      Reply($client,"refused\n",$userinput);  
  }  
 # ------------------------------------------------------------------------ auth  
     } elsif ($userinput =~ /^auth/) { # Encoded and client only.  
     if (($wasenc==1) && isClient) {  
  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";  
     }  
  }  
     }  
     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);  
   
     }      ResetStatistics();
 # ---------------------------------------------------------------------- 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);  
   
     }  # ------------------------------------------------------------ Process requests
 # -------------------------------------- fetch a user file from a remote server      my $KeepGoing = 1;
  } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.      while ((my $userinput=GetRequest) && $KeepGoing) {
     if(isClient) {   $KeepGoing = ProcessRequest($userinput);
  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 $obs;  
  my $rights;  
  my ($cmd,$ulsdir)=split(/:/,$userinput);  
  my $ulsout='';  
  my $ulsfn;  
  if (-e $ulsdir) {  
     if(-d $ulsdir) {  
  if (opendir(LSDIR,$ulsdir)) {  
     while ($ulsfn=readdir(LSDIR)) {  
  undef $obs, $rights;   
  my @ulsstats=stat($ulsdir.'/'.$ulsfn);  
  #We do some obsolete checking here  
  if(-e $ulsdir.'/'.$ulsfn.".meta") {   
     open(FILE, $ulsdir.'/'.$ulsfn.".meta");  
     my @obsolete=<FILE>;  
     foreach my $obsolete (@obsolete) {  
         if($obsolete =~ m|(<obsolete>)(on)|) { $obs = 1; }   
  if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }  
     }  
  }  
  $ulsout.=$ulsfn.'&'.join('&',@ulsstats);  
  if($obs eq '1') { $ulsout.="&1"; }  
  else { $ulsout.="&0"; }  
  if($rights eq '1') { $ulsout.="&1:"; }  
  else { $ulsout.="&0:"; }  
     }  
     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->shutdown(2);        # shutdown the socket forcibly.  
     $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 2859  sub ManagePermissions Line 3936  sub ManagePermissions
     my $authtype= shift;      my $authtype= shift;
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
       &logthis("ruequest is $request");
     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
  my $execdir = $perlvar{'lonDaemons'};   my $execdir = $perlvar{'lonDaemons'};
  my $userhome= "/home/$user" ;   my $userhome= "/home/$user" ;
Line 3163  sub version { Line 4241  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.174  
changed lines
  Added in v.1.177

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.