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

Diff for /loncom/lond between versions 1.223 and 1.303

version 1.223, 2004/08/05 11:37:05 version 1.303, 2005/12/09 21:17:16
Line 46  use Authen::Krb5; Line 46  use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use localauth;  use localauth;
 use localenroll;  use localenroll;
   use localstudentphoto;
 use File::Copy;  use File::Copy;
   use File::Find;
 use LONCAPA::ConfigFileEdit;  use LONCAPA::ConfigFileEdit;
 use LONCAPA::lonlocal;  use LONCAPA::lonlocal;
 use LONCAPA::lonssl;  use LONCAPA::lonssl;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
   
 my $DEBUG = 1;       # Non zero to enable debug log entries.  my $DEBUG = 0;       # Non zero to enable debug log entries.
   
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
Line 64  my $currentdomainid; Line 66  my $currentdomainid;
   
 my $client;  my $client;
 my $clientip; # IP address of client.  my $clientip; # IP address of client.
 my $clientdns; # DNS name of client.  
 my $clientname; # LonCAPA name of client.  my $clientname; # LonCAPA name of client.
   
 my $server;  my $server;
Line 112  my %Dispatcher; Line 113  my %Dispatcher;
 #  #
 my $lastpwderror    = 13; # Largest error number from lcpasswd.  my $lastpwderror    = 13; # Largest error number from lcpasswd.
 my @passwderrors = ("ok",  my @passwderrors = ("ok",
    "lcpasswd must be run as user 'www'",     "pwchange_failure - lcpasswd must be run as user 'www'",
    "lcpasswd got incorrect number of arguments",     "pwchange_failure - lcpasswd got incorrect number of arguments",
    "lcpasswd did not get the right nubmer of input text lines",     "pwchange_failure - lcpasswd did not get the right nubmer of input text lines",
    "lcpasswd too many simultaneous pwd changes in progress",     "pwchange_failure - lcpasswd too many simultaneous pwd changes in progress",
    "lcpasswd User does not exist.",     "pwchange_failure - lcpasswd User does not exist.",
    "lcpasswd Incorrect current passwd",     "pwchange_failure - lcpasswd Incorrect current passwd",
    "lcpasswd Unable to su to root.",     "pwchange_failure - lcpasswd Unable to su to root.",
    "lcpasswd Cannot set new passwd.",     "pwchange_failure - lcpasswd Cannot set new passwd.",
    "lcpasswd Username has invalid characters",     "pwchange_failure - lcpasswd Username has invalid characters",
    "lcpasswd Invalid characters in password",     "pwchange_failure - lcpasswd Invalid characters in password",
    "lcpasswd User already exists",      "pwchange_failure - lcpasswd User already exists", 
                    "lcpasswd Something went wrong with user addition.",                     "pwchange_failure - lcpasswd Something went wrong with user addition.",
     "lcpasswd Password mismatch",     "pwchange_failure - lcpasswd Password mismatch",
     "lcpasswd Error filename is invalid");     "pwchange_failure - lcpasswd Error filename is invalid");
   
   
 #  The array below are lcuseradd error strings.:  #  The array below are lcuseradd error strings.:
Line 162  sub ResetStatistics { Line 163  sub ResetStatistics {
     $Failures     = 0;      $Failures     = 0;
 }  }
   
   
   
 #------------------------------------------------------------------------  #------------------------------------------------------------------------
 #  #
 #   LocalConnection  #   LocalConnection
Line 179  sub ResetStatistics { Line 178  sub ResetStatistics {
 #   $initcmd     - The full text of the init command.  #   $initcmd     - The full text of the init command.
 #  #
 # Implicit inputs:  # Implicit inputs:
 #    $clientdns  - The DNS name of the remote client.  
 #    $thisserver - Our DNS name.  #    $thisserver - Our DNS name.
 #  #
 # Returns:  # Returns:
Line 188  sub ResetStatistics { Line 186  sub ResetStatistics {
 #  #
 sub LocalConnection {  sub LocalConnection {
     my ($Socket, $initcmd) = @_;      my ($Socket, $initcmd) = @_;
     Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver");      Debug("Attempting local connection: $initcmd client: $clientip me: $thisserver");
     if($clientdns ne $thisserver) {      if($clientip ne "127.0.0.1") {
  &logthis('<font color="red"> LocalConnection rejecting non local: '   &logthis('<font color="red"> LocalConnection rejecting non local: '
  ."$clientdns ne $thisserver </font>");   ."$clientip ne $thisserver </font>");
  close $Socket;   close $Socket;
  return undef;   return undef;
     }       }  else {
     else {  
  chomp($initcmd); # Get rid of \n in filename.   chomp($initcmd); # Get rid of \n in filename.
  my ($init, $type, $name) = split(/:/, $initcmd);   my ($init, $type, $name) = split(/:/, $initcmd);
  Debug(" Init command: $init $type $name ");   Debug(" Init command: $init $type $name ");
Line 326  sub InsecureConnection { Line 323  sub InsecureConnection {
     $answer    =~s/\W//g;      $answer    =~s/\W//g;
     if($challenge eq $answer) {      if($challenge eq $answer) {
  return 1;   return 1;
     }       } else {
     else {  
  logthis("<font color='blue'>WARNING client did not respond to challenge</font>");   logthis("<font color='blue'>WARNING client did not respond to challenge</font>");
  &status("No challenge reqply");   &status("No challenge reqply");
  return 0;   return 0;
Line 335  sub InsecureConnection { Line 331  sub InsecureConnection {
           
   
 }  }
   
 #  #
   #   Safely execute a command (as long as it's not a shel command and doesn
   #   not require/rely on shell escapes.   The function operates by doing a
   #   a pipe based fork and capturing stdout and stderr  from the pipe.
   #
   # Formal Parameters:
   #     $line                    - A line of text to be executed as a command.
   # Returns:
   #     The output from that command.  If the output is multiline the caller
   #     must know how to split up the output.
   #
   #
   sub execute_command {
       my ($line)    = @_;
       my @words     = split(/\s/, $line); # Bust the command up into words.
       my $output    = "";
   
       my $pid = open(CHILD, "-|");
       
       if($pid) { # Parent process
    Debug("In parent process for execute_command");
    my @data = <CHILD>; # Read the child's outupt...
    close CHILD;
    foreach my $output_line (@data) {
       Debug("Adding $output_line");
       $output .= $output_line; # Presumably has a \n on it.
    }
   
       } else { # Child process
    close (STDERR);
    open  (STDERR, ">&STDOUT");# Combine stderr, and stdout...
    exec(@words); # won't return.
       }
       return $output;
   }
   
   
 #   GetCertificate: Given a transaction that requires a certificate,  #   GetCertificate: Given a transaction that requires a certificate,
 #   this function will extract the certificate from the transaction  #   this function will extract the certificate from the transaction
 #   request.  Note that at this point, the only concept of a certificate  #   request.  Note that at this point, the only concept of a certificate
Line 374  sub isClient { Line 405  sub isClient {
 #                     - This allows dynamic changes to the manager table  #                     - This allows dynamic changes to the manager table
 #                       without the need to signal to the lond.  #                       without the need to signal to the lond.
 #  #
   
 sub ReadManagerTable {  sub ReadManagerTable {
   
     #   Clean out the old table first..      #   Clean out the old table first..
Line 443  sub CopyFile { Line 473  sub CopyFile {
   
     my ($oldfile, $newfile) = @_;      my ($oldfile, $newfile) = @_;
   
     #  The file must exist:      if (! copy($oldfile,$newfile)) {
           return 0;
     if(-e $oldfile) {  
   
  # Read the old file.  
   
  my $oldfh = IO::File->new("< $oldfile");  
  if(!$oldfh) {  
     return 0;  
  }  
  my @contents = <$oldfh>;  # Suck in the entire file.  
   
  # write the backup file:  
   
  my $newfh = IO::File->new("> $newfile");  
  if(!(defined $newfh)){  
     return 0;  
  }  
  my $lines = scalar @contents;  
  for (my $i =0; $i < $lines; $i++) {  
     print $newfh ($contents[$i]);  
  }  
   
  $oldfh->close;  
  $newfh->close;  
   
  chmod(0660, $newfile);  
   
  return 1;  
       
     } else {  
  return 0;  
     }      }
       chmod(0660, $newfile);
       return 1;
 }  }
 #  #
 #  Host files are passed out with externally visible host IPs.  #  Host files are passed out with externally visible host IPs.
Line 656  sub PushFile { Line 658  sub PushFile {
  &logthis('<font color="red"> Pushfile: unable to install '   &logthis('<font color="red"> Pushfile: unable to install '
  .$tablefile." $! </font>");   .$tablefile." $! </font>");
  return "error:$!";   return "error:$!";
     }      } else {
     else {  
  &logthis('<font color="green"> Installed new '.$tablefile   &logthis('<font color="green"> Installed new '.$tablefile
  ."</font>");   ."</font>");
   
Line 1019  sub tie_user_hash { Line 1020  sub tie_user_hash {
    $how, 0640)) {     $how, 0640)) {
  # If this is a namespace for which a history is kept,   # If this is a namespace for which a history is kept,
  # make the history log entry:       # make the history log entry:    
  if (($namespace =~/^nohist\_/) && (defined($loghead))) {   if (($namespace !~/^nohist\_/) && (defined($loghead))) {
     my $args = scalar @_;      my $args = scalar @_;
     Debug(" Opening history: $namespace $args");      Debug(" Opening history: $namespace $args");
     my $hfh = IO::File->new(">>$proname/$namespace.hist");       my $hfh = IO::File->new(">>$proname/$namespace.hist"); 
Line 1036  sub tie_user_hash { Line 1037  sub tie_user_hash {
           
 }  }
   
   #   read_profile
   #
   #   Returns a set of specific entries from a user's profile file.
   #   this is a utility function that is used by both get_profile_entry and
   #   get_profile_entry_encrypted.
   #
   # Parameters:
   #    udom       - Domain in which the user exists.
   #    uname      - User's account name (loncapa account)
   #    namespace  - The profile namespace to open.
   #    what       - A set of & separated queries.
   # Returns:
   #    If all ok: - The string that needs to be shipped back to the user.
   #    If failure - A string that starts with error: followed by the failure
   #                 reason.. note that this probabyl gets shipped back to the
   #                 user as well.
   #
   sub read_profile {
       my ($udom, $uname, $namespace, $what) = @_;
       
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_READER());
       if ($hashref) {
           my @queries=split(/\&/,$what);
           my $qresult='';
   
    for (my $i=0;$i<=$#queries;$i++) {
       $qresult.="$hashref->{$queries[$i]}&";    # Presumably failure gives empty string.
    }
    $qresult=~s/\&$//;              # Remove trailing & from last lookup.
    if (untie %$hashref) {
       return $qresult;
    } else {
       return "error: ".($!+0)." untie (GDBM) Failed";
    }
       } else {
    if ($!+0 == 2) {
       return "error:No such file or GDBM reported bad block error";
    } else {
       return "error: ".($!+0)." tie (GDBM) Failed";
    }
       }
   
   }
 #--------------------- Request Handlers --------------------------------------------  #--------------------- Request Handlers --------------------------------------------
 #  #
 #   By convention each request handler registers itself prior to the sub   #   By convention each request handler registers itself prior to the sub 
Line 1057  sub tie_user_hash { Line 1102  sub tie_user_hash {
 #      0       - Program should exit.  #      0       - Program should exit.
 #  Side effects:  #  Side effects:
 #      Reply information is sent to the client.  #      Reply information is sent to the client.
   
 sub ping_handler {  sub ping_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     Debug("$cmd $tail $client .. $currenthostid:");      Debug("$cmd $tail $client .. $currenthostid:");
Line 1085  sub ping_handler { Line 1129  sub ping_handler {
 #      0       - Program should exit.  #      0       - Program should exit.
 #  Side effects:  #  Side effects:
 #      Reply information is sent to the client.  #      Reply information is sent to the client.
   
 sub pong_handler {  sub pong_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
Line 1140  sub establish_key_handler { Line 1183  sub establish_key_handler {
 }  }
 &register_handler("ekey", \&establish_key_handler, 0, 1,1);  &register_handler("ekey", \&establish_key_handler, 0, 1,1);
   
   
 #     Handler for the load command.  Returns the current system load average  #     Handler for the load command.  Returns the current system load average
 #     to the requestor.  #     to the requestor.
 #  #
Line 1175  sub load_handler { Line 1217  sub load_handler {
         
     return 1;      return 1;
 }  }
 register_handler("load", \&load_handler, 0, 1, 0);  &register_handler("load", \&load_handler, 0, 1, 0);
   
 #  #
 #   Process the userload request.  This sub returns to the client the current  #   Process the userload request.  This sub returns to the client the current
Line 1205  sub user_load_handler { Line 1247  sub user_load_handler {
           
     return 1;      return 1;
 }  }
 register_handler("userload", \&user_load_handler, 0, 1, 0);  &register_handler("userload", \&user_load_handler, 0, 1, 0);
   
 #   Process a request for the authorization type of a user:  #   Process a request for the authorization type of a user:
 #   (userauth).  #   (userauth).
Line 1241  sub user_authorization_type { Line 1283  sub user_authorization_type {
  my ($type,$otherinfo) = split(/:/,$result);   my ($type,$otherinfo) = split(/:/,$result);
  if($type =~ /^krb/) {   if($type =~ /^krb/) {
     $type = $result;      $type = $result;
  }   } else {
  &Reply( $replyfd, "$type:\n", $userinput);              $type .= ':';
           }
    &Reply( $replyfd, "$type\n", $userinput);
     }      }
       
     return 1;      return 1;
Line 1262  sub user_authorization_type { Line 1306  sub user_authorization_type {
 #      0       - Program should exit  #      0       - Program should exit
 # Implicit Output:  # Implicit Output:
 #    a reply is written to the client.  #    a reply is written to the client.
   
 sub push_file_handler {  sub push_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
Line 1288  sub push_file_handler { Line 1331  sub push_file_handler {
 }  }
 &register_handler("pushfile", \&push_file_handler, 1, 0, 1);  &register_handler("pushfile", \&push_file_handler, 1, 0, 1);
   
   #
   #   du  - list the disk usuage of a directory recursively. 
   #    
   #   note: stolen code from the ls file handler
   #   under construction by Rick Banghart 
   #    .
   # Parameters:
   #    $cmd        - The command that dispatched us (du).
   #    $ududir     - The directory path to list... I'm not sure what this
   #                  is relative as things like ls:. return e.g.
   #                  no_such_dir.
   #    $client     - Socket open on the client.
   # Returns:
   #     1 - indicating that the daemon should not disconnect.
   # Side Effects:
   #   The reply is written to  $client.
   #
   sub du_handler {
       my ($cmd, $ududir, $client) = @_;
       my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
       my $userinput = "$cmd:$ududir";
   
       if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {
    &Failure($client,"refused\n","$cmd:$ududir");
    return 1;
       }
       #  Since $ududir could have some nasties in it,
       #  we will require that ududir is a valid
       #  directory.  Just in case someone tries to
       #  slip us a  line like .;(cd /home/httpd rm -rf*)
       #  etc.
       #
       if (-d $ududir) {
    my $total_size=0;
    my $code=sub { 
       if ($_=~/\.\d+\./) { return;} 
       if ($_=~/\.meta$/) { return;}
       $total_size+=(stat($_))[7];
    };
    chdir($ududir);
    find($code,$ududir);
    $total_size=int($total_size/1024);
    &Reply($client,"$total_size\n","$cmd:$ududir");
       } else {
    &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); 
       }
       return 1;
   }
   &register_handler("du", \&du_handler, 0, 1, 0);
   
   #
   # The ls_handler routine should be considered obosolete and is retained
   # for communication with legacy servers.  Please see the ls2_handler.
   #
   #   ls  - list the contents of a directory.  For each file in the
   #    selected directory the filename followed by the full output of
   #    the stat function is returned.  The returned info for each
   #    file are separated by ':'.  The stat fields are separated by &'s.
   # Parameters:
   #    $cmd        - The command that dispatched us (ls).
   #    $ulsdir     - The directory path to list... I'm not sure what this
   #                  is relative as things like ls:. return e.g.
   #                  no_such_dir.
   #    $client     - Socket open on the client.
   # Returns:
   #     1 - indicating that the daemon should not disconnect.
   # Side Effects:
   #   The reply is written to  $client.
   #
   sub ls_handler {
       # obsoleted by ls2_handler
       my ($cmd, $ulsdir, $client) = @_;
   
       my $userinput = "$cmd:$ulsdir";
   
       my $obs;
       my $rights;
       my $ulsout='';
       my $ulsfn;
       if (-e $ulsdir) {
    if(-d $ulsdir) {
       if (opendir(LSDIR,$ulsdir)) {
    while ($ulsfn=readdir(LSDIR)) {
       undef($obs);
       undef($rights); 
       my @ulsstats=stat($ulsdir.'/'.$ulsfn);
       #We do some obsolete checking here
       if(-e $ulsdir.'/'.$ulsfn.".meta") { 
    open(FILE, $ulsdir.'/'.$ulsfn.".meta");
    my @obsolete=<FILE>;
    foreach my $obsolete (@obsolete) {
       if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } 
       if($obsolete =~ m|(<copyright>)(default)|) { $rights = 1; }
    }
       }
       $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'; }
       &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.
       
       return 1;
   
   }
   &register_handler("ls", \&ls_handler, 0, 1, 0);
   
   #
   # Please also see the ls_handler, which this routine obosolets.
   # ls2_handler differs from ls_handler in that it escapes its return 
   # values before concatenating them together with ':'s.
   #
   #   ls2  - list the contents of a directory.  For each file in the
   #    selected directory the filename followed by the full output of
   #    the stat function is returned.  The returned info for each
   #    file are separated by ':'.  The stat fields are separated by &'s.
   # Parameters:
   #    $cmd        - The command that dispatched us (ls).
   #    $ulsdir     - The directory path to list... I'm not sure what this
   #                  is relative as things like ls:. return e.g.
   #                  no_such_dir.
   #    $client     - Socket open on the client.
   # Returns:
   #     1 - indicating that the daemon should not disconnect.
   # Side Effects:
   #   The reply is written to  $client.
   #
   sub ls2_handler {
       my ($cmd, $ulsdir, $client) = @_;
   
       my $userinput = "$cmd:$ulsdir";
   
       my $obs;
       my $rights;
       my $ulsout='';
       my $ulsfn;
       if (-e $ulsdir) {
           if(-d $ulsdir) {
               if (opendir(LSDIR,$ulsdir)) {
                   while ($ulsfn=readdir(LSDIR)) {
                       undef($obs);
       undef($rights); 
                       my @ulsstats=stat($ulsdir.'/'.$ulsfn);
                       #We do some obsolete checking here
                       if(-e $ulsdir.'/'.$ulsfn.".meta") { 
                           open(FILE, $ulsdir.'/'.$ulsfn.".meta");
                           my @obsolete=<FILE>;
                           foreach my $obsolete (@obsolete) {
                               if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; } 
                               if($obsolete =~ m|(<copyright>)(default)|) {
                                   $rights = 1;
                               }
                           }
                       }
                       my $tmp = $ulsfn.'&'.join('&',@ulsstats);
                       if ($obs    eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
                       if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
                       $ulsout.= &escape($tmp).':';
                   }
                   closedir(LSDIR);
               }
           } else {
               my @ulsstats=stat($ulsdir);
               $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
           }
       } else {
           $ulsout='no_such_dir';
      }
      if ($ulsout eq '') { $ulsout='empty'; }
      &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.
      return 1;
   }
   &register_handler("ls2", \&ls2_handler, 0, 1, 0);
   
 #   Process a reinit request.  Reinit requests that either  #   Process a reinit request.  Reinit requests that either
 #   lonc or lond be reinitialized so that an updated   #   lonc or lond be reinitialized so that an updated 
Line 1319  sub reinit_process_handler { Line 1545  sub reinit_process_handler {
     }      }
     return 1;      return 1;
 }  }
   
 &register_handler("reinit", \&reinit_process_handler, 1, 0, 1);  &register_handler("reinit", \&reinit_process_handler, 1, 0, 1);
   
 #  Process the editing script for a table edit operation.  #  Process the editing script for a table edit operation.
Line 1361  sub edit_table_handler { Line 1586  sub edit_table_handler {
     }      }
     return 1;      return 1;
 }  }
 register_handler("edit", \&edit_table_handler, 1, 0, 1);  &register_handler("edit", \&edit_table_handler, 1, 0, 1);
   
   
 #  #
 #   Authenticate a user against the LonCAPA authentication  #   Authenticate a user against the LonCAPA authentication
Line 1417  sub authenticate_handler { Line 1641  sub authenticate_handler {
   
     return 1;      return 1;
 }  }
   &register_handler("auth", \&authenticate_handler, 1, 1, 0);
 register_handler("auth", \&authenticate_handler, 1, 1, 0);  
   
 #  #
 #   Change a user's password.  Note that this function is complicated by  #   Change a user's password.  Note that this function is complicated by
Line 1481  sub change_password_handler { Line 1704  sub change_password_handler {
  &Failure( $client, "non_authorized\n",$userinput);   &Failure( $client, "non_authorized\n",$userinput);
     }      }
  } elsif ($howpwd eq 'unix') {   } elsif ($howpwd eq 'unix') {
     # Unix means we have to access /etc/password      my $result = &change_unix_password($uname, $npass);
     &Debug("auth is unix");  
     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: ".      &logthis("Result of password change for $uname: ".
      &lcpasswdstrerror($?));       $result);
     &Reply($client, "$result\n", $userinput);      &Reply($client, "$result\n", $userinput);
  } else {   } else {
     # this just means that the current password mode is not      # this just means that the current password mode is not
Line 1503  sub change_password_handler { Line 1716  sub change_password_handler {
     &Failure( $client, "auth_mode_error\n", $userinput);      &Failure( $client, "auth_mode_error\n", $userinput);
  }     }  
   
     }      } else {
     else {  
  &Failure( $client, "non_authorized\n", $userinput);   &Failure( $client, "non_authorized\n", $userinput);
     }      }
   
     return 1;      return 1;
 }  }
 register_handler("passwd", \&change_password_handler, 1, 1, 0);  &register_handler("passwd", \&change_password_handler, 1, 1, 0);
   
   
 #---------------------------------------------------------------  
 #  #
 #   Getting, decoding and dispatching requests:  #   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 add_user_handler {
   
 #      my ($cmd, $tail, $client) = @_;
 #   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 get_request {  
     my $input = <$client>;  
     chomp($input);  
   
     Debug("get_request: Request = $input\n");  
   
     &status('Processing '.$clientname.':'.$input);      my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
       my $userinput = $cmd.":".$tail; # Reconstruct the full request line.
   
       &Debug("cmd =".$cmd." $udom =".$udom." uname=".$uname);
   
   
       if($udom eq $currentdomainid) { # Reject new users for other domains...
   
    my $oldumask=umask(0077);
    chomp($npass);
    $npass=&unescape($npass);
    my $passfilename  = &password_path($udom, $uname);
    &Debug("Password file created will be:".$passfilename);
    if (-e $passfilename) {
       &Failure( $client, "already_exists\n", $userinput);
    } else {
       my $fperror='';
       if (!&mkpath($passfilename)) {
    $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);
       }  else {
    &Failure($client, "not_right_domain\n",
    $userinput); # Even if we are multihomed.
       
       }
       return 1;
   
     return $input;  
 }  }
 #---------------------------------------------------------------  &register_handler("makeuser", \&add_user_handler, 1, 1, 0);
   
 #  #
 #  Process a request.  This sub should shrink as each action  #   Change the authentication method of a user.  Note that this may
 #  gets farmed out into a separat sub that is registered   #   also implicitly change the user's password if, for example, the user is
 #  with the dispatch hash.    #   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:  # Parameters:
 #    user_input   - The request received from the client (lonc).  #    $cmd      - The command that got us here.
 # Returns:  #    $tail     - Tail of the command (remaining parameters).
 #    true to keep processing, false if caller should exit.  #    $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.
   # NOTE:
   #   This is also used to change the authentication credential values (e.g. passwd).
   #   
 #  #
 sub process_request {  sub change_authentication_handler {
     my ($userinput) = @_;      # Easier for now to break style than to  
                                 # fix all the userinput -> user_input.  
     my $wasenc    = 0; # True if request was encrypted.  
 # ------------------------------------------------------------ See if encrypted  
     if ($userinput =~ /^enc/) {  
  $userinput = decipher($userinput);  
  $wasenc=1;  
  if(!$userinput) { # Cipher not defined.  
     &Failure($client, "error: Encrypted data without negotated key");  
     return 0;  
  }  
     }  
     Debug("process_request: $userinput\n");  
       
     #    
     #   The 'correct way' to add a command to lond is now to  
     #   write a sub to execute it and Add it to the command dispatch  
     #   hash via a call to register_handler..  The comments to that  
     #   sub should give you enough to go on to show how to do this  
     #   along with the examples that are building up as this code  
     #   is getting refactored.   Until all branches of the  
     #   if/elseif monster below have been factored out into  
     #   separate procesor subs, if the dispatch hash is missing  
     #   the command keyword, we will fall through to the remainder  
     #   of the if/else chain below in order to keep this thing in   
     #   working order throughout the transmogrification.  
   
     my ($command, $tail) = split(/:/, $userinput, 2);  
     chomp($command);  
     chomp($tail);  
     $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet.  
     $command =~ s/(\r)//; # And this too for parameterless commands.  
     if(!$tail) {  
  $tail =""; # defined but blank.  
     }  
   
     &Debug("Command received: $command, encoded = $wasenc");  
   
     if(defined $Dispatcher{$command}) {      my ($cmd, $tail, $client) = @_;
      
       my $userinput  = "$cmd:$tail";              # Reconstruct user input.
   
  my $dispatch_info = $Dispatcher{$command};      my ($udom,$uname,$umode,$npass)=split(/:/,$tail);
  my $handler       = $$dispatch_info[0];      &Debug("cmd = ".$cmd." domain= ".$udom."uname =".$uname." umode= ".$umode);
  my $need_encode   = $$dispatch_info[1];      if ($udom ne $currentdomainid) {
  my $client_types  = $$dispatch_info[2];   &Failure( $client, "not_right_domain\n", $client);
  Debug("Matched dispatch hash: mustencode: $need_encode "      } else {
       ."ClientType $client_types");  
          chomp($npass);
  #  Validate the request:  
          $npass=&unescape($npass);
  my $ok = 1;   my $oldauth = &get_auth_type($udom, $uname); # Get old auth info.
  my $requesterprivs = 0;   my $passfilename = &password_path($udom, $uname);
  if(&isClient()) {   if ($passfilename) { # Not allowed to create a new user!!
     $requesterprivs |= $CLIENT_OK;      # If just changing the unix passwd. need to arrange to run
  }      # passwd since otherwise make_passwd_file will run
  if(&isManager()) {      # lcuseradd which fails if an account already exists
     $requesterprivs |= $MANAGER_OK;      # (to prevent an unscrupulous LONCAPA admin from stealing
  }      # an existing account by overwriting it as a LonCAPA account).
  if($need_encode && (!$wasenc)) {  
     Debug("Must encode but wasn't: $need_encode $wasenc");      if(($oldauth =~/^unix/) && ($umode eq "unix")) {
     $ok = 0;   my $result = &change_unix_password($uname, $npass);
  }   &logthis("Result of password change for $uname: ".$result);
  if(($client_types & $requesterprivs) == 0) {   if ($result eq "ok") {
     Debug("Client not privileged to do this operation");      &Reply($client, "$result\n")
     $ok = 0;   } else {
  }      &Failure($client, "$result\n");
    }
       } else {
    my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
    #
    #  If the current auth mode is internal, and the old auth mode was
    #  unix, or krb*,  and the user is an author for this domain,
    #  re-run manage_permissions for that role in order to be able
    #  to take ownership of the construction space back to www:www
    #
   
   
    if( (($oldauth =~ /^unix/) && ($umode eq "internal")) ||
       (($oldauth =~ /^internal/) && ($umode eq "unix")) ) { 
       if(&is_author($udom, $uname)) {
    &Debug(" Need to manage author permissions...");
    &manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
       }
    }
    &Reply($client, $result, $userinput);
       }
          
   
  if($ok) {   } else {       
     Debug("Dispatching to handler $command $tail");      &Failure($client, "non_authorized\n", $userinput); # Fail the user now.
     my $keep_going = &$handler($command, $tail, $client);  
     return $keep_going;  
  } else {  
     Debug("Refusing to dispatch because client did not match requirements");  
     Failure($client, "refused\n", $userinput);  
     return 1;  
  }   }
       }
       return 1;
   }
   &register_handler("changeuserauth", \&change_authentication_handler, 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 is_home_handler {
       my ($cmd, $tail, $client) = @_;
      
       my $userinput  = "$cmd:$tail";
      
       my ($udom,$uname)=split(/:/,$tail);
       chomp($uname);
       my $passfile = &password_filename($udom, $uname);
       if($passfile) {
    &Reply( $client, "found\n", $userinput);
       } else {
    &Failure($client, "not_found\n", $userinput);
       }
       return 1;
   }
   &register_handler("home", \&is_home_handler, 0,1,0);
   
 #------------------- Commands not yet in spearate handlers. --------------  #
   #   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 update_resource_handler {
   
       my ($cmd, $tail, $client) = @_;
      
       my $userinput = "$cmd:$tail";
      
       my $fname= $tail; # This allows interactive testing
   
   
 # -------------------------------------------------------------------- makeuser      my $ownership=ishome($fname);
     if ($userinput =~ /^makeuser/) { # encoded and client.      if ($ownership eq 'not_owner') {
  &Debug("Make user received");   if (-e $fname) {
  my $oldumask=umask(0077);      my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  if (($wasenc==1) && isClient) {   $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
     my       my $now=time;
  ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput);      my $since=$now-$atime;
     &Debug("cmd =".$cmd." $udom =".$udom.      if ($since>$perlvar{'lonExpire'}) {
    " uname=".$uname);   my $reply=&reply("unsub:$fname","$clientname");
     chomp($npass);   unlink("$fname");
     $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);  
  Reply($client, $result, $userinput);  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ------------------------------------------------------------------------ home  
     } elsif ($userinput =~ /^home/) { # client clear or encoded  
  if(isClient) {  
     my ($cmd,$udom,$uname)=split(/:/,$userinput);  
     chomp($uname);  
     my $proname=propath($udom,$uname);  
     if (-e $proname) {  
  print $client "found\n";  
     } else {  
  print $client "not_found\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # ---------------------------------------------------------------------- update  
     } elsif ($userinput =~ /^update/) { # client clear or encoded.  
  if(isClient) {  
     my ($cmd,$fname)=split(/:/,$userinput);  
     my $ownership=ishome($fname);  
     if ($ownership eq 'not_owner') {  
  if (-e $fname) {  
     my ($dev,$ino,$mode,$nlink,  
  $uid,$gid,$rdev,$size,  
  $atime,$mtime,$ctime,  
  $blksize,$blocks)=stat($fname);  
     my $now=time;  
     my $since=$now-$atime;  
     if ($since>$perlvar{'lonExpire'}) {  
  my $reply=  
     &reply("unsub:$fname","$clientname");  
     unlink("$fname");  
     } else {  
  my $transname="$fname.in.transfer";  
  my $remoteurl=  
     &reply("sub:$fname","$clientname");  
  my $response;  
  {  
     my $ua=new LWP::UserAgent;  
     my $request=new HTTP::Request('GET',"$remoteurl");  
     $response=$ua->request($request,$transname);  
  }  
  if ($response->is_error()) {  
     unlink($transname);  
     my $message=$response->status_line;  
     &logthis(  
      "LWP GET: $message for $fname ($remoteurl)");  
  } else {  
     if ($remoteurl!~/\.meta$/) {  
  my $ua=new LWP::UserAgent;  
  my $mrequest=  
     new HTTP::Request('GET',$remoteurl.'.meta');  
  my $mresponse=  
     $ua->request($mrequest,$fname.'.meta');  
  if ($mresponse->is_error()) {  
     unlink($fname.'.meta');  
  }  
     }  
     rename($transname,$fname);  
  }  
     }  
     print $client "ok\n";  
  } else {  
     print $client "not_found\n";  
  }  
     } else {      } else {
  print $client "rejected\n";   my $transname="$fname.in.transfer";
     }   my $remoteurl=&reply("sub:$fname","$clientname");
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }  
 # -------------------------------------- fetch a user file from a remote server  
     } elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.  
  if(isClient) {  
     my ($cmd,$fname)=split(/:/,$userinput);  
     my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);  
     my $udir=propath($udom,$uname).'/userfiles';  
     unless (-e $udir) { mkdir($udir,0770); }  
     if (-e $udir) {  
  $ufile=~s/^[\.\~]+//;  
  my $path = $udir;  
  if ($ufile =~m|(.+)/([^/]+)$|) {  
     my @parts=split('/',$1);  
     foreach my $part (@parts) {  
  $path .= '/'.$part;  
  if ((-e $path)!=1) {  
     mkdir($path,0770);  
  }  
     }  
  }  
  my $destname=$udir.'/'.$ufile;  
  my $transname=$udir.'/'.$ufile.'.in.transit';  
  my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;  
  my $response;   my $response;
    alarm(120);
  {   {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',"$remoteurl");      my $request=new HTTP::Request('GET',"$remoteurl");
     $response=$ua->request($request,$transname);      $response=$ua->request($request,$transname);
  }   }
    alarm(0);
  if ($response->is_error()) {   if ($response->is_error()) {
     unlink($transname);      unlink($transname);
     my $message=$response->status_line;      my $message=$response->status_line;
     &logthis("LWP GET: $message for $fname ($remoteurl)");      &logthis("LWP GET: $message for $fname ($remoteurl)");
     print $client "failed\n";  
  } else {   } else {
     if (!rename($transname,$destname)) {      if ($remoteurl!~/\.meta$/) {
  &logthis("Unable to move $transname to $destname");   alarm(120);
  unlink($transname);   {
  print $client "failed\n";      my $ua=new LWP::UserAgent;
     } else {      my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
  print $client "ok\n";      my $mresponse=$ua->request($mrequest,$fname.'.meta');
     }      if ($mresponse->is_error()) {
  }   unlink($fname.'.meta');
     } else {      }
  print $client "not_home\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
  }  
 # --------------------------------------------------------- remove a user file   
     } elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.  
  if(isClient) {  
     my ($cmd,$fname)=split(/:/,$userinput);  
     my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);  
     &logthis("$udom - $uname - $ufile");  
     if ($ufile =~m|/\.\./|) {  
  # any files paths with /../ in them refuse   
  # to deal with  
  print $client "refused\n";  
     } else {  
  my $udir=propath($udom,$uname);  
  if (-e $udir) {  
     my $file=$udir.'/userfiles/'.$ufile;  
     if (-e $file) {  
  unlink($file);  
  if (-e $file) {  
     print $client "failed\n";  
  } else {  
     print $client "ok\n";  
  }   }
     } else {   alarm(0);
  print $client "not_found\n";  
     }      }
  } else {      rename($transname,$fname);
     print $client "not_home\n";      use Cache::Memcached;
       my $memcache=
    new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
       my $url=$fname;
       $url=~s-^/home/httpd/html--;
       my $id=&escape('meta:'.$url);
       $memcache->delete($id);
  }   }
     }      }
       &Reply( $client, "ok\n", $userinput);
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "not_found\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=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }  
     }  
  close(ENVIN);  
  print $client $reply."\n";  
     } else {  
  print $client "invalid_token\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
       
  }   }
 # ----------------------------------------------------------------- unsubscribe      } else {
     } elsif ($userinput =~ /^unsub/) {   &Failure($client, "rejected\n", $userinput);
  if(isClient) {      }
     my ($cmd,$fname)=split(/:/,$userinput);      return 1;
     if (-e $fname) {  }
  print $client &unsub($fname,$clientip);  &register_handler("update", \&update_resource_handler, 0 ,1, 0);
   
   #
   #   Fetch a user file from a remote server to the user's home directory
   #   userfiles subdir.
   # 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 fetch_user_file_handler {
   
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
       my $fname           = $tail;
       my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
       my $udir=&propath($udom,$uname).'/userfiles';
       unless (-e $udir) {
    mkdir($udir,0770); 
       }
       Debug("fetch user file for $fname");
       if (-e $udir) {
    $ufile=~s/^[\.\~]+//;
   
    # IF necessary, create the path right down to the file.
    # Note that any regular files in the way of this path are
    # wiped out to deal with some earlier folly of mine.
   
    if (!&mkpath($udir.'/'.$ufile)) {
       &Failure($client, "unable_to_create\n", $userinput);    
    }
   
    my $destname=$udir.'/'.$ufile;
    my $transname=$udir.'/'.$ufile.'.in.transit';
    my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
    my $response;
    Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
    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 {
       Debug("Renaming $transname to $destname");
       if (!rename($transname,$destname)) {
    &logthis("Unable to move $transname to $destname");
    unlink($transname);
    &Failure($client, "failed\n", $userinput);
     } else {      } else {
  print $client "not_found\n";   &Reply($client, "ok\n", $userinput);
     }  
  } 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);      } else {
        &Failure($client, "not_home\n", $userinput);
  }      }
 # ------------------------------------------------------------------------- put      return 1;
     } elsif ($userinput =~ /^put/) {  }
  if(isClient) {  &register_handler("fetchuserfile", \&fetch_user_file_handler, 0, 1, 0);
     my ($cmd,$udom,$uname,$namespace,$what)  
  =split(/:/,$userinput,5);  #
     $namespace=~s/\//\_/g;  #   Remove a file from a user's home directory userfiles subdirectory.
     $namespace=~s/\W//g;  # Parameters:
     if ($namespace ne 'roles') {  #    cmd   - the Lond request keyword that got us here.
  chomp($what);  #    tail  - the part of the command past the keyword.
  my $proname=propath($udom,$uname);  #    client- File descriptor connected with the client.
  my $now=time;  #
  my @pairs=split(/\&/,$what);  # Returns:
  my %hash;  #    1    - Continue processing.
  if (tie(%hash,'GDBM_File',  sub remove_user_file_handler {
  "$proname/$namespace.db",      my ($cmd, $tail, $client) = @_;
  &GDBM_WRCREAT(),0640)) {  
     unless ($namespace=~/^nohist\_/) {      my ($fname) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent.
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }      my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
     }      if ($ufile =~m|/\.\./|) {
        # any files paths with /../ in them refuse 
     foreach my $pair (@pairs) {   # to deal with
  my ($key,$value)=split(/=/,$pair);   &Failure($client, "refused\n", "$cmd:$tail");
  $hash{$key}=$value;      } else {
     }   my $udir = &propath($udom,$uname);
     if (untie(%hash)) {   if (-e $udir) {
  print $client "ok\n";      my $file=$udir.'/userfiles/'.$ufile;
     } else {      if (-e $file) {
  print $client "error: ".($!+0)   #
     ." untie(GDBM) failed ".   #   If the file is a regular file unlink is fine...
     "while attempting put\n";   #   However it's possible the client wants a dir.
     }   #   removed, in which case rmdir is more approprate:
  } else {   #
     print $client "error: ".($!)          if (-f $file){
  ." tie(GDBM) Failed ".      unlink($file);
  "while attempting put\n";   } elsif(-d $file) {
       rmdir($file);
  }   }
     } else {   if (-e $file) {
  print $client "refused\n";      #  File is still there after we deleted it ?!?
     }  
  } else {      &Failure($client, "failed\n", "$cmd:$tail");
     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;  
  my @pairs=split(/\&/,$what);  
  my %hash;  
  if (tie(%hash,'GDBM_File',  
  "$proname/$namespace.db",  
  &GDBM_WRCREAT(),0640)) {  
     unless ($namespace=~/^nohist\_/) {  
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "P:$now:$what\n"; }  
     }  
     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 inc\n";  
     }  
  } else {   } else {
     print $client "error: ".($!)      &Reply($client, "ok\n", "$cmd:$tail");
  ." tie(GDBM) Failed ".  
  "while attempting inc\n";  
  }   }
     } else {      } else {
  print $client "refused\n";   &Failure($client, "not_found\n", "$cmd:$tail");
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "not_home\n", "$cmd:$tail");
       
  }   }
 # -------------------------------------------------------------------- rolesput      }
     } elsif ($userinput =~ /^rolesput/) {      return 1;
  if(isClient) {  }
     &Debug("rolesput");  &register_handler("removeuserfile", \&remove_user_file_handler, 0,1,0);
     if ($wasenc==1) {  
  my ($cmd,$exedom,$exeuser,$udom,$uname,$what)  #
     =split(/:/,$userinput);  #   make a directory in a user's home directory userfiles subdirectory.
  &Debug("cmd = ".$cmd." exedom= ".$exedom.  # Parameters:
        "user = ".$exeuser." udom=".$udom.  #    cmd   - the Lond request keyword that got us here.
        "what = ".$what);  #    tail  - the part of the command past the keyword.
  my $namespace='roles';  #    client- File descriptor connected with the client.
  chomp($what);  #
  my $proname=propath($udom,$uname);  # Returns:
  my $now=time;  #    1    - Continue processing.
  my @pairs=split(/\&/,$what);  sub mkdir_user_file_handler {
  my %hash;      my ($cmd, $tail, $client) = @_;
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
     {      my ($dir) = split(/:/, $tail); # Get rid of any tailing :'s lonc may have sent.
  my $hfh;      $dir=&unescape($dir);
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {       my ($udom,$uname,$ufile) = ($dir =~ m|^([^/]+)/([^/]+)/(.+)$|);
     print $hfh "P:$now:$exedom:$exeuser:$what\n";      if ($ufile =~m|/\.\./|) {
  }   # any files paths with /../ in them refuse 
     }   # to deal with
        &Failure($client, "refused\n", "$cmd:$tail");
     foreach my $pair (@pairs) {      } else {
  my ($key,$value)=split(/=/,$pair);   my $udir = &propath($udom,$uname);
  &ManagePermissions($key, $udom, $uname,   if (-e $udir) {
    &get_auth_type( $udom,       my $newdir=$udir.'/userfiles/'.$ufile.'/';
  $uname));      if (!&mkpath($newdir)) {
  $hash{$key}=$value;   &Failure($client, "failed\n", "$cmd:$tail");
     }  
     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 @rolekeys=split(/\&/,$what);  
  my %hash;  
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  
     {  
  my $hfh;  
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {   
     print $hfh "D:$now:$exedom:$exeuser:$what\n";  
  }  
     }  
     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";  
     }      }
       &Reply($client, "ok\n", "$cmd:$tail");
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "not_home\n", "$cmd:$tail");
       
  }   }
 # ------------------------------------------------------------------------- get      }
     } elsif ($userinput =~ /^get/) {      return 1;
  if(isClient) {  }
     my ($cmd,$udom,$uname,$namespace,$what)  &register_handler("mkdiruserfile", \&mkdir_user_file_handler, 0,1,0);
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  #
     $namespace=~s/\W//g;  #   rename a file in a user's home directory userfiles subdirectory.
     chomp($what);  # Parameters:
     my @queries=split(/\&/,$what);  #    cmd   - the Lond request keyword that got us here.
     my $proname=propath($udom,$uname);  #    tail  - the part of the command past the keyword.
     my $qresult='';  #    client- File descriptor connected with the client.
     my %hash;  #
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  # Returns:
  for (my $i=0;$i<=$#queries;$i++) {  #    1    - Continue processing.
     $qresult.="$hash{$queries[$i]}&";  sub rename_user_file_handler {
  }      my ($cmd, $tail, $client) = @_;
  if (untie(%hash)) {  
     $qresult=~s/\&$//;      my ($udom,$uname,$old,$new) = split(/:/, $tail);
     print $client "$qresult\n";      $old=&unescape($old);
  } else {      $new=&unescape($new);
     print $client "error: ".($!+0)      if ($new =~m|/\.\./| || $old =~m|/\.\./|) {
  ." untie(GDBM) Failed ".   # any files paths with /../ in them refuse to deal with
  "while attempting get\n";   &Failure($client, "refused\n", "$cmd:$tail");
  }      } else {
    my $udir = &propath($udom,$uname);
    if (-e $udir) {
       my $oldfile=$udir.'/userfiles/'.$old;
       my $newfile=$udir.'/userfiles/'.$new;
       if (-e $newfile) {
    &Failure($client, "exists\n", "$cmd:$tail");
       } elsif (! -e $oldfile) {
    &Failure($client, "not_found\n", "$cmd:$tail");
     } else {      } else {
  if ($!+0 == 2) {   if (!rename($oldfile,$newfile)) {
     print $client "error:No such file or ".      &Failure($client, "failed\n", "$cmd:$tail");
  "GDBM reported bad block error\n";  
  } else {   } else {
     print $client "error: ".($!+0)      &Reply($client, "ok\n", "$cmd:$tail");
  ." tie(GDBM) Failed ".  
  "while attempting get\n";  
  }   }
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "not_home\n", "$cmd:$tail");
       
  }   }
 # ------------------------------------------------------------------------ eget      }
     } elsif ($userinput =~ /^eget/) {      return 1;
  if (isClient) {  }
     my ($cmd,$udom,$uname,$namespace,$what)  &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);
  =split(/:/,$userinput);  
     $namespace=~s/\//\_/g;  #
     $namespace=~s/\W//g;  #  Authenticate access to a user file by checking that the token the user's 
     chomp($what);  #  passed also exists in their session file
     my @queries=split(/\&/,$what);  #
     my $proname=propath($udom,$uname);  # Parameters:
     my $qresult='';  #   cmd      - The request keyword that dispatched to tus.
     my %hash;  #   tail     - The tail of the request (colon separated parameters).
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  #   client   - Filehandle open on the client.
  for (my $i=0;$i<=$#queries;$i++) {  # Return:
     $qresult.="$hash{$queries[$i]}&";  #    1.
  }  sub token_auth_user_file_handler {
  if (untie(%hash)) {      my ($cmd, $tail, $client) = @_;
     $qresult=~s/\&$//;  
     if ($cipher) {      my ($fname, $session) = split(/:/, $tail);
  my $cmdlength=length($qresult);      
  $qresult.="         ";      chomp($session);
  my $encqresult='';      my $reply="non_auth\n";
  for       if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
     (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {       $session.'.id')) {
  $encqresult.=   while (my $line=<ENVIN>) {
     unpack("H16",      if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; }
    $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   close(ENVIN);
     } elsif ($userinput =~ /^del/) {   &Reply($client, $reply, "$cmd:$tail");
  if(isClient) {      } else {
     my ($cmd,$udom,$uname,$namespace,$what)   &Failure($client, "invalid_token\n", "$cmd:$tail");
  =split(/:/,$userinput);      }
     $namespace=~s/\//\_/g;      return 1;
     $namespace=~s/\W//g;  
     chomp($what);  }
     my $proname=propath($udom,$uname);  &register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);
     my $now=time;  
     my @keys=split(/\&/,$what);  #
     my %hash;  #   Unsubscribe from a resource.
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  #
  unless ($namespace=~/^nohist\_/) {  # Parameters:
     my $hfh;  #    $cmd      - The command that got us here.
     if ($hfh=IO::File->new(">>$proname/$namespace.hist")) { print $hfh "D:$now:$what\n"; }  #    $tail     - Tail of the command (remaining parameters).
  }  #    $client   - File descriptor connected to client.
  foreach my $key (@keys) {  # Returns
     delete($hash{$key});  #     0        - Requested to exit, caller should shut down.
  }  #     1        - Continue processing.
  if (untie(%hash)) {  #
     print $client "ok\n";  sub unsubscribe_handler {
  } else {      my ($cmd, $tail, $client) = @_;
     print $client "error: ".($!+0)  
  ." untie(GDBM) Failed ".      my $userinput= "$cmd:$tail";
  "while attempting del\n";      
  }      my ($fname) = split(/:/,$tail); # Split in case there's extrs.
     } else {  
  print $client "error: ".($!+0)      &Debug("Unsubscribing $fname");
     ." tie(GDBM) Failed ".      if (-e $fname) {
     "while attempting del\n";   &Debug("Exists");
    &Reply($client, &unsub($fname,$clientip), $userinput);
       } else {
    &Failure($client, "not_found\n", $userinput);
       }
       return 1;
   }
   &register_handler("unsub", \&unsubscribe_handler, 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 subscribe_handler {
       my ($cmd, $tail, $client)= @_;
   
       my $userinput  = "$cmd:$tail";
   
       &Reply( $client, &subscribe($userinput,$clientip), $userinput);
   
       return 1;
   }
   &register_handler("sub", \&subscribe_handler, 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 current_version_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput= "$cmd:$tail";
      
       my $fname   = $tail;
       &Reply( $client, &currentversion($fname)."\n", $userinput);
       return 1;
   
   }
   &register_handler("currentversion", \&current_version_handler, 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 activity_log_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       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 {
    &Failure($client, "error: ".($!+0)." IO::File->new Failed "
    ."while attempting log\n", 
    $userinput);
       }
   
       return 1;
   }
   &register_handler("log", \&activity_log_handler, 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 put_user_profile_entry {
       my ($cmd, $tail, $client)  = @_;
   
       my $userinput = "$cmd:$tail";
       
       my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
       if ($namespace ne 'roles') {
    chomp($what);
    my $hashref = &tie_user_hash($udom, $uname, $namespace,
     &GDBM_WRCREAT(),"P",$what);
    if($hashref) {
       my @pairs=split(/\&/,$what);
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    $hashref->{$key}=$value;
     }      }
  } else {      if (untie(%$hashref)) {
     Reply($client, "refused\n", $userinput);   &Reply( $client, "ok\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 {      } else {
  print $client "error: ".($!+0)   &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
     ." tie(GDBM) Failed ".   "while attempting put\n", 
     "while attempting keys\n";   $userinput);
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
            "while attempting put\n", $userinput);
  }   }
 # ----------------------------------------------------------------- dumpcurrent      } else {
     } elsif ($userinput =~ /^currentdump/) {          &Failure( $client, "refused\n", $userinput);
  if (isClient) {      }
     my ($cmd,$udom,$uname,$namespace)      
  =split(/:/,$userinput);      return 1;
     $namespace=~s/\//\_/g;  }
     $namespace=~s/\W//g;  &register_handler("put", \&put_user_profile_entry, 0, 1, 0);
     my $qresult='';  
     my $proname=propath($udom,$uname);  #   Put a piece of new data in hash, returns error if entry already exists
     my %hash;  # Parameters:
     if (tie(%hash,'GDBM_File',  #    $cmd      - The command that got us here.
     "$proname/$namespace.db",  #    $tail     - Tail of the command (remaining parameters).
     &GDBM_READER(),0640)) {  #    $client   - File descriptor connected to client.
     # Structure of %data:  # Returns
  # $data{$symb}->{$parameter}=$value;  #     0        - Requested to exit, caller should shut down.
  # $data{$symb}->{'v.'.$parameter}=$version;  #     1        - Continue processing.
  # since $parameter will be unescaped, we do not  #
  # have to worry about silly parameter names...  sub newput_user_profile_entry {
  my %data = ();      my ($cmd, $tail, $client)  = @_;
  while (my ($key,$value) = each(%hash)) {  
     my ($v,$symb,$param) = split(/:/,$key);      my $userinput = "$cmd:$tail";
     next if ($v eq 'version' || $symb eq 'keys');  
     next if (exists($data{$symb}) &&       my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
      exists($data{$symb}->{$param}) &&      if ($namespace eq 'roles') {
      $data{$symb}->{'v.'.$param} > $v);          &Failure( $client, "refused\n", $userinput);
     $data{$symb}->{$param}=$value;   return 1;
     $data{$symb}->{'v.'.$param}=$v;      }
  }  
  if (untie(%hash)) {      chomp($what);
     while (my ($symb,$param_hash) = each(%data)) {  
  while(my ($param,$value) = each (%$param_hash)){      my $hashref = &tie_user_hash($udom, $uname, $namespace,
     next if ($param =~ /^v\./);   &GDBM_WRCREAT(),"N",$what);
     $qresult.=$symb.':'.$param.'='.$value.'&';      if(!$hashref) {
  }   &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
     }    "while attempting put\n", $userinput);
     chop($qresult);   return 1;
     print $client "$qresult\n";      }
  } else {  
     print $client "error: ".($!+0)      my @pairs=split(/\&/,$what);
  ." untie(GDBM) Failed ".      foreach my $pair (@pairs) {
  "while attempting currentdump\n";   my ($key,$value)=split(/=/,$pair);
  }   if (exists($hashref->{$key})) {
     } else {      &Failure($client, "key_exists: ".$key."\n",$userinput);
  print $client "error: ".($!+0)      return 1;
     ." tie(GDBM) Failed ".  
     "while attempting currentdump\n";  
     }  
  } else {  
     Reply($client, "refused\n", $userinput);  
  }   }
 # ------------------------------------------------------------------------ dump      }
     } elsif ($userinput =~ /^dump/) {  
  if(isClient) {      foreach my $pair (@pairs) {
     my ($cmd,$udom,$uname,$namespace,$regexp)   my ($key,$value)=split(/=/,$pair);
  =split(/:/,$userinput);   $hashref->{$key}=$value;
     $namespace=~s/\//\_/g;      }
     $namespace=~s/\W//g;  
     if (defined($regexp)) {      if (untie(%$hashref)) {
  $regexp=&unescape($regexp);   &Reply( $client, "ok\n", $userinput);
     } else {      } else {
  $regexp='.';   &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
    "while attempting put\n", 
    $userinput);
       }
       return 1;
   }
   &register_handler("newput", \&newput_user_profile_entry, 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 increment_user_value_handler {
       my ($cmd, $tail, $client) = @_;
       
       my $userinput   = "$cmd:$tail";
       
       my ($udom,$uname,$namespace,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
           chomp($what);
    my $hashref = &tie_user_hash($udom, $uname,
        $namespace, &GDBM_WRCREAT(),
        "P",$what);
    if ($hashref) {
       my @pairs=split(/\&/,$what);
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
                   $value = &unescape($value);
    # We could check that we have a number...
    if (! defined($value) || $value eq '') {
       $value = 1;
    }
    $hashref->{$key}+=$value;
                   if ($namespace eq 'nohist_resourcetracker') {
                       if ($hashref->{$key} < 0) {
                           $hashref->{$key} = 0;
                       }
                   }
     }      }
     my $qresult='';      if (untie(%$hashref)) {
     my $proname=propath($udom,$uname);   &Reply( $client, "ok\n", $userinput);
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  
  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 {      } else {
  print $client "error: ".($!+0)   &Failure($client, "error: ".($!+0)." untie(GDBM) failed ".
     ." tie(GDBM) Failed ".   "while attempting inc\n", $userinput);
     "while attempting dump\n";  
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
            "while attempting inc\n", $userinput);
  }   }
 # ----------------------------------------------------------------------- store      } else {
     } elsif ($userinput =~ /^store/) {   &Failure($client, "refused\n", $userinput);
  if(isClient) {      }
     my ($cmd,$udom,$uname,$namespace,$rid,$what)      
  =split(/:/,$userinput);      return 1;
     $namespace=~s/\//\_/g;  }
     $namespace=~s/\W//g;  &register_handler("inc", \&increment_user_value_handler, 0, 1, 0);
     if ($namespace ne 'roles') {  
  chomp($what);  #
  my $proname=propath($udom,$uname);  #   Put a new role for a user.  Roles are LonCAPA's packaging of permissions.
  my $now=time;  #   Each 'role' a user has implies a set of permissions.  Adding a new role
  my @pairs=split(/\&/,$what);  #   for a person grants the permissions packaged with that role
  my %hash;  #   to that user when the role is selected.
  if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) {  #
     unless ($namespace=~/^nohist\_/) {  # Parameters:
  my $hfh;  #    $cmd       - The command string (rolesput).
  if ($hfh=IO::File->new(">>$proname/$namespace.hist")) {  #    $tail      - The remainder of the request line.  For rolesput this
     print $hfh "P:$now:$rid:$what\n";  #                 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.
     my @previouskeys=split(/&/,$hash{"keys:$rid"});  #                 The roles being granted as a set of & separated pairs.
     my $key;  #                 each pair a key value pair.
     $hash{"version:$rid"}++;  #    $client    - File descriptor connected to the client.
     my $version=$hash{"version:$rid"};  # Returns:
     my $allkeys='';   #     0         - If the daemon should exit
     foreach my $pair (@pairs) {  #     1         - To continue processing.
  my ($key,$value)=split(/=/,$pair);  #
  $allkeys.=$key.':';  #
  $hash{"$version:$rid:$key"}=$value;  sub roles_put_handler {
     }      my ($cmd, $tail, $client) = @_;
     $hash{"$version:$rid:timestamp"}=$now;  
     $allkeys.='timestamp';      my $userinput  = "$cmd:$tail";
     $hash{"$version:keys:$rid"}=$allkeys;  
     if (untie(%hash)) {      my ( $exedom, $exeuser, $udom, $uname,  $what) = split(/:/,$tail);
  print $client "ok\n";      
     } else {  
  print $client "error: ".($!+0)      my $namespace='roles';
     ." untie(GDBM) Failed ".      chomp($what);
     "while attempting store\n";      my $hashref = &tie_user_hash($udom, $uname, $namespace,
  }   &GDBM_WRCREAT(), "P",
  } else {   "$exedom:$exeuser:$what");
     print $client "error: ".($!+0)      #
  ." tie(GDBM) Failed ".      #  Log the attempt to set a role.  The {}'s here ensure that the file 
  "while attempting store\n";      #  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-
     } else {      #  corrupted ordered thing.
  print $client "refused\n";      if ($hashref) {
     }   my $pass_entry = &get_auth_type($udom, $uname);
    my ($auth_type,$pwd)  = split(/:/, $pass_entry);
    $auth_type = $auth_type.":";
    my @pairs=split(/\&/,$what);
    foreach my $pair (@pairs) {
       my ($key,$value)=split(/=/,$pair);
       &manage_permissions($key, $udom, $uname,
          $auth_type);
       $hashref->{$key}=$value;
    }
    if (untie($hashref)) {
       &Reply($client, "ok\n", $userinput);
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
            "while attempting rolesput\n", $userinput);
  }   }
 # --------------------------------------------------------------------- restore      } else {
     } elsif ($userinput =~ /^restore/) {   &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting rolesput\n", $userinput);
     my ($cmd,$udom,$uname,$namespace,$rid)      }
  =split(/:/,$userinput);      return 1;
     $namespace=~s/\//\_/g;  }
     $namespace=~s/\W//g;  &register_handler("rolesput", \&roles_put_handler, 1,1,0);  # Encoded client only.
     chomp($rid);  
     my $proname=propath($udom,$uname);  #
     my $qresult='';  #   Deletes (removes) a role for a user.   This is equivalent to removing
     my %hash;  #  a permissions package associated with the role from the user's profile.
     if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {  #
  my $version=$hash{"version:$rid"};  # Parameters:
  $qresult.="version=$version&";  #     $cmd                 - The command (rolesdel)
  my $scope;  #     $tail                - The remainder of the request line. This consists
  for ($scope=1;$scope<=$version;$scope++) {  #                             of:
     my $vkeys=$hash{"$scope:keys:$rid"};  #                             The domain and user requesting the change (logged)
     my @keys=split(/:/,$vkeys);  #                             The domain and user being changed.
     my $key;  #                             The roles being revoked.  These are shipped to us
     $qresult.="$scope:keys=$vkeys&";  #                             as a bunch of & separated role name keywords.
     foreach $key (@keys) {  #     $client              - The file handle open on the client.
  $qresult.="$scope:$key=".$hash{"$scope:$rid:$key"}."&";  # Returns:
     }                                    #     1                    - Continue processing
  }  #     0                    - Exit.
  if (untie(%hash)) {  #
     $qresult=~s/\&$//;  sub roles_delete_handler {
     print $client "$qresult\n";      my ($cmd, $tail, $client)  = @_;
  } else {  
     print $client "error: ".($!+0)      my $userinput    = "$cmd:$tail";
  ." untie(GDBM) Failed ".     
  "while attempting restore\n";      my ($exedom,$exeuser,$udom,$uname,$what)=split(/:/,$tail);
  }      &Debug("cmd = ".$cmd." exedom= ".$exedom."user = ".$exeuser." udom=".$udom.
     } else {     "what = ".$what);
  print $client "error: ".($!+0)      my $namespace='roles';
     ." tie(GDBM) Failed ".      chomp($what);
     "while attempting restore\n";      my $hashref = &tie_user_hash($udom, $uname, $namespace,
     }   &GDBM_WRCREAT(), "D",
  } else  {   "$exedom:$exeuser:$what");
     Reply($client, "refused\n", $userinput);      
           if ($hashref) {
    my @rolekeys=split(/\&/,$what);
   
    foreach my $key (@rolekeys) {
       delete $hashref->{$key};
  }   }
 # -------------------------------------------------------------------- chatsend   if (untie(%$hashref)) {
     } elsif ($userinput =~ /^chatsend/) {      &Reply($client, "ok\n", $userinput);
  if(isClient) {  
     my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput);  
     &chatadd($cdom,$cnum,$newpost);  
     print $client "ok\n";  
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
            "while attempting rolesdel\n", $userinput);
  }   }
 # -------------------------------------------------------------------- chatretr      } else {
     } elsif ($userinput =~ /^chatretr/) {          &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting rolesdel\n", $userinput);
     my       }
  ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput);      
     my $reply='';      return 1;
     foreach (&getchat($cdom,$cnum,$udom,$uname)) {  }
  $reply.=&escape($_).':';  &register_handler("rolesdel", \&roles_delete_handler, 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 get_profile_entry {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput= "$cmd:$tail";
      
       my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
       chomp($what);
   
       my $replystring = read_profile($udom, $uname, $namespace, $what);
       my ($first) = split(/:/,$replystring);
       if($first ne "error") {
    &Reply($client, "$replystring\n", $userinput);
       } else {
    &Failure($client, $replystring." while attempting get\n", $userinput);
       }
       return 1;
   
   
   }
   &register_handler("get", \&get_profile_entry, 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 get_profile_entry_encrypted {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
      
       my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
       chomp($what);
       my $qresult = read_profile($udom, $uname, $namespace, $what);
       my ($first) = split(/:/, $qresult);
       if($first ne "error") {
   
    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=~s/\:$//;      &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
     print $client $reply."\n";  
  } else {   } else {
     Reply($client, "refused\n", $userinput);   &Failure( $client, "error:no_key\n", $userinput);
           }
       } else {
    &Failure($client, "$qresult while attempting eget\n", $userinput);
   
       }
       
       return 1;
   }
   &register_handler("eget", \&get_profile_entry_encrypted, 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 delete_profile_entry {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "cmd:$tail";
   
       my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
       chomp($what);
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_WRCREAT(),
    "D",$what);
       if ($hashref) {
           my @keys=split(/\&/,$what);
    foreach my $key (@keys) {
       delete($hashref->{$key});
  }   }
 # ------------------------------------------------------------------- querysend   if (untie(%$hashref)) {
     } elsif ($userinput =~ /^querysend/) {      &Reply($client, "ok\n", $userinput);
  if (isClient) {  
     my ($cmd,$query,  
  $arg1,$arg2,$arg3)=split(/\:/,$userinput);  
     $query=~s/\n*$//g;  
     print $client "".  
  sqlreply("$clientname\&$query".  
  "\&$arg1"."\&$arg2"."\&$arg3")."\n";  
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
           "while attempting del\n", $userinput);
  }   }
 # ------------------------------------------------------------------ queryreply      } else {
     } elsif ($userinput =~ /^queryreply/) {   &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting del\n", $userinput);
     my ($cmd,$id,$reply)=split(/:/,$userinput);       }
     my $store;      return 1;
     my $execdir=$perlvar{'lonDaemons'};  }
     if ($store=IO::File->new(">$execdir/tmp/$id")) {  &register_handler("del", \&delete_profile_entry, 0, 1, 0);
  $reply=~s/\&/\n/g;  
  print $store $reply;  #
  close $store;  #  List the set of keys that are defined in a profile database file.
  my $store2=IO::File->new(">$execdir/tmp/$id.end");  #  A successful reply from this will contain an & separated list of
  print $store2 "done\n";  #  the keys. 
  close $store2;  # Parameters:
  print $client "ok\n";  #     $cmd              - Command request (keys).
     }  #     $tail             - Remainder of the request, a colon separated
     else {  #                         list containing domain/user that identifies the
  print $client "error: ".($!+0)  #                         user being queried, and the database namespace
     ." IO::File->new Failed ".  #                         (database filename essentially).
     "while attempting queryreply\n";  #     $client           - File open on the client.
     }  #  Returns:
   #    1    - Continue processing.
   #    0    - Exit the server.
   #
   sub get_profile_keys {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace)=split(/:/,$tail);
       my $qresult='';
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
     &GDBM_READER());
       if ($hashref) {
    foreach my $key (keys %$hashref) {
       $qresult.="$key&";
    }
    if (untie(%$hashref)) {
       $qresult=~s/\&$//;
       &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
           "while attempting keys\n", $userinput);
  }   }
 # ----------------------------------------------------------------- courseidput      } else {
     } elsif ($userinput =~ /^courseidput/) {   &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting keys\n", $userinput);
     my ($cmd,$udom,$what)=split(/:/,$userinput);      }
     chomp($what);     
  $udom=~s/\W//g;      return 1;
     my $proname=  }
  "$perlvar{'lonUsersDir'}/$udom/nohist_courseids";  &register_handler("keys", \&get_profile_keys, 0, 1, 0);
     my $now=time;  
     my @pairs=split(/\&/,$what);  #
     my %hash;  #   Dump the contents of a user profile database.
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {  #   Note that this constitutes a very large covert channel too since
  foreach my $pair (@pairs) {  #   the dump will return sensitive information that is not encrypted.
     my ($key,$descr,$inst_code)=split(/=/,$pair);  #   The naive security assumption is that the session negotiation ensures
     $hash{$key}=$descr.':'.$inst_code.':'.$now;  #   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
  if (untie(%hash)) {  #   a LonCAPA node they could have negotiated an encryption key too so >sigh<.
     print $client "ok\n";  # 
  } else {  #  Parameters:
     print $client "error: ".($!+0)  #     $cmd           - The command request keyword (currentdump).
  ." untie(GDBM) Failed ".  #     $tail          - Remainder of the request, consisting of a colon
  "while attempting courseidput\n";  #                      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 dump_profile_database {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
      
       my ($udom,$uname,$namespace) = split(/:/,$tail);
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_READER());
       if ($hashref) {
    # 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 $qresult='';
    my %data = ();                     # A hash of anonymous hashes..
    while (my ($key,$value) = each(%$hashref)) {
       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(%$hashref)) {
       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.'&';
  }   }
     } else {  
  print $client "error: ".($!+0)  
     ." tie(GDBM) Failed ".  
     "while attempting courseidput\n";  
     }      }
       chop($qresult);
       &Reply($client , "$qresult\n", $userinput);
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
            "while attempting currentdump\n", $userinput);
  }   }
 # ---------------------------------------------------------------- courseiddump      } else {
     } elsif ($userinput =~ /^courseiddump/) {   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting currentdump\n", $userinput);
     my ($cmd,$udom,$since,$description)      }
  =split(/:/,$userinput);  
     if (defined($description)) {      return 1;
  $description=&unescape($description);  }
   &register_handler("currentdump", \&dump_profile_database, 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 dump_with_regexp {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$regexp)=split(/:/,$tail);
       if (defined($regexp)) {
    $regexp=&unescape($regexp);
       } else {
    $regexp='.';
       }
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_READER());
       if ($hashref) {
           my $qresult='';
    while (my ($key,$value) = each(%$hashref)) {
       if ($regexp eq '.') {
    $qresult.=$key.'='.$value.'&';
     } else {      } else {
  $description='.';   my $unescapeKey = &unescape($key);
     }   if (eval('$unescapeKey=~/$regexp/')) {
     unless (defined($since)) { $since=0; }      $qresult.="$key=$value&";
     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,$inst_code);  
     if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) {  
  ($descr,$inst_code,$lasttime)=($1,$2,$3);  
     } else {  
  ($descr,$lasttime) = split(/\:/,$value);  
     }  
     if ($lasttime<$since) { next; }  
     if ($description eq '.') {  
  $qresult.=$key.'='.$descr.':'.$inst_code.'&';  
     } else {  
  my $unescapeVal = &unescape($descr);  
  if (eval('$unescapeVal=~/\Q$description\E/i')) {  
     $qresult.=$key.'='.$descr.':'.$inst_code.'&';  
  }  
     }  
  }  
  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   if (untie(%$hashref)) {
     } elsif ($userinput =~ /^idput/) {      chop($qresult);
  if(isClient) {      &Reply($client, "$qresult\n", $userinput);
     my ($cmd,$udom,$what)=split(/:/,$userinput);  
     chomp($what);  
     $udom=~s/\W//g;  
     my $proname="$perlvar{'lonUsersDir'}/$udom/ids";  
     my $now=time;  
     my @pairs=split(/\&/,$what);  
     my %hash;  
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {  
  {  
     my $hfh;  
     if ($hfh=IO::File->new(">>$proname.hist")) {  
  print $hfh "P:$now:$what\n";  
     }  
  }  
  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 {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
            "while attempting dump\n", $userinput);
  }   }
 # ----------------------------------------------------------------------- idget      } else {
     } elsif ($userinput =~ /^idget/) {   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  if(isClient) {   "while attempting dump\n", $userinput);
     my ($cmd,$udom,$what)=split(/:/,$userinput);      }
     chomp($what);  
     $udom=~s/\W//g;      return 1;
     my $proname="$perlvar{'lonUsersDir'}/$udom/ids";  }
     my @queries=split(/\&/,$what);  &register_handler("dump", \&dump_with_regexp, 0, 1, 0);
     my $qresult='';  
     my %hash;  #  Store a set of key=value pairs associated with a versioned name.
     if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {  #
  for (my $i=0;$i<=$#queries;$i++) {  #  Parameters:
     $qresult.="$hash{$queries[$i]}&";  #    $cmd                - Request command keyword.
  }  #    $tail               - Tail of the request.  This is a colon
  if (untie(%hash)) {  #                          separated list containing:
     $qresult=~s/\&$//;  #                          domain/user - User and authentication domain.
     print $client "$qresult\n";  #                          namespace   - Name of the database being modified
  } else {  #                          rid         - Resource keyword to modify.
     print $client "error: ".($!+0)  #                          what        - new value associated with rid.
  ." untie(GDBM) Failed ".  #
  "while attempting idget\n";  #    $client             - Socket open on the client.
  }  #
   #
   #  Returns:
   #      1 (keep on processing).
   #  Side-Effects:
   #    Writes to the client
   sub store_handler {
       my ($cmd, $tail, $client) = @_;
    
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$rid,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
   
    chomp($what);
    my @pairs=split(/\&/,$what);
    my $hashref  = &tie_user_hash($udom, $uname, $namespace,
          &GDBM_WRCREAT(), "S",
          "$rid:$what");
    if ($hashref) {
       my $now = time;
       my @previouskeys=split(/&/,$hashref->{"keys:$rid"});
       my $key;
       $hashref->{"version:$rid"}++;
       my $version=$hashref->{"version:$rid"};
       my $allkeys=''; 
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    $allkeys.=$key.':';
    $hashref->{"$version:$rid:$key"}=$value;
       }
       $hashref->{"$version:$rid:timestamp"}=$now;
       $allkeys.='timestamp';
       $hashref->{"$version:keys:$rid"}=$allkeys;
       if (untie($hashref)) {
    &Reply($client, "ok\n", $userinput);
     } else {      } else {
  print $client "error: ".($!+0)   &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
     ." tie(GDBM) Failed ".   "while attempting store\n", $userinput);
     "while attempting idget\n";  
     }      }
  } else {   } else {
     Reply($client, "refused\n", $userinput);      &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
            "while attempting store\n", $userinput);
  }   }
 # ---------------------------------------------------------------------- tmpput      } else {
     } elsif ($userinput =~ /^tmpput/) {   &Failure($client, "refused\n", $userinput);
  if(isClient) {      }
     my ($cmd,$what)=split(/:/,$userinput);  
     my $store;      return 1;
     $tmpsnum++;  }
     my $id=$$.'_'.$clientip.'_'.$tmpsnum;  &register_handler("store", \&store_handler, 0, 1, 0);
     $id=~s/\W/\_/g;  
     $what=~s/\n//g;  #
     my $execdir=$perlvar{'lonDaemons'};  #  Dump out all versions of a resource that has key=value pairs associated
     if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {  # with it for each version.  These resources are built up via the store
  print $store $what;  # command.
  close $store;  #
  print $client "$id\n";  #  Parameters:
     }  #     $cmd               - Command keyword.
     else {  #     $tail              - Remainder of the request which consists of:
  print $client "error: ".($!+0)  #                          domain/user   - User and auth. domain.
     ."IO::File->new Failed ".  #                          namespace     - name of resource database.
     "while attempting tmpput\n";  #                          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.
   #   The reply is a string of the following shape:
   #   version=current&version:keys=k1:k2...&1:k1=v1&1:k2=v2...
   #    Where the 1 above represents version 1.
   #    this continues for all pairs of keys in all versions.
   #
   #
   #    
   #
   sub restore_handler {
       my ($cmd, $tail, $client) = @_;
   
       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 {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
           "while attempting restore\n", $userinput);
  }   }
       } else {
 # ---------------------------------------------------------------------- tmpget   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
     } elsif ($userinput =~ /^tmpget/) {   "while attempting restore\n", $userinput);
  if(isClient) {      }
     my ($cmd,$id)=split(/:/,$userinput);    
     chomp($id);      return 1;
     $id=~s/\W/\_/g;  
     my $store;  
     my $execdir=$perlvar{'lonDaemons'};  }
     if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {  &register_handler("restore", \&restore_handler, 0,1,0);
  my $reply=<$store>;  
     print $client "$reply\n";  #
  close $store;  #   Add a chat message to to a discussion board.
     }  #
     else {  # Parameters:
  print $client "error: ".($!+0)  #    $cmd                - Request keyword.
     ."IO::File->new Failed ".  #    $tail               - Tail of the command. A colon separated list
     "while attempting tmpget\n";  #                          containing:
     }  #                          cdom    - Domain on which the chat board lives
  } else {  #                          cnum    - Identifier of the discussion group.
     Reply($client, "refused\n", $userinput);  #                          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 send_chat_handler {
       my ($cmd, $tail, $client) = @_;
   
       
       my $userinput = "$cmd:$tail";
   
       my ($cdom,$cnum,$newpost)=split(/\:/,$tail);
       &chat_add($cdom,$cnum,$newpost);
       &Reply($client, "ok\n", $userinput);
   
       return 1;
   }
   &register_handler("chatsend", \&send_chat_handler, 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 retrieve_chat_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput = "$cmd:$tail";
   
       my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);
       my $reply='';
       foreach (&get_chat($cdom,$cnum,$udom,$uname)) {
    $reply.=&escape($_).':';
       }
       $reply=~s/\:$//;
       &Reply($client, $reply."\n", $userinput);
   
   
       return 1;
   }
   &register_handler("chatretr", \&retrieve_chat_handler, 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 send_query_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput = "$cmd:$tail";
   
       my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);
       $query=~s/\n*$//g;
       &Reply($client, "". &sql_reply("$clientname\&$query".
    "\&$arg1"."\&$arg2"."\&$arg3")."\n",
     $userinput);
       
       return 1;
   }
   &register_handler("querysend", \&send_query_handler, 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 reply_query_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       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;
   }
   &register_handler("queryreply", \&reply_query_handler, 0, 1, 0);
   
   #
   #  Process the courseidput request.  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.
   #               Each value is a colon separated list that includes:  
   #               description, institutional code and course owner.
   #               For backward compatibility with versions included
   #               in LON-CAPA 1.1.X (and earlier) and 1.2.X, institutional
   #               code and/or course owner are preserved from the existing 
   #               record when writing a new record in response to 1.1 or 
   #               1.2 implementations of lonnet::flushcourselogs().   
   #                      
   #   $client   - Socket open on the client.
   # Returns:
   #   1    - indicating that processing should continue
   #
   # Side effects:
   #   reply is written to the client.
   #
   sub put_course_id_handler {
       my ($cmd, $tail, $client) = @_;
   
   
       my $userinput = "$cmd:$tail";
   
       my ($udom, $what) = split(/:/, $tail,2);
       chomp($what);
       my $now=time;
       my @pairs=split(/\&/,$what);
   
       my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
    foreach my $pair (@pairs) {
               my ($key,$courseinfo) = split(/=/,$pair,2);
               $courseinfo =~ s/=/:/g;
   
               my @current_items = split(/:/,$hashref->{$key});
               shift(@current_items); # remove description
               pop(@current_items);   # remove last access
               my $numcurrent = scalar(@current_items);
   
               my @new_items = split(/:/,$courseinfo);
               my $numnew = scalar(@new_items);
               if ($numcurrent > 0) {
                   if ($numnew == 1) { # flushcourselogs() from 1.1 or earlier
                       $courseinfo .= ':'.join(':',@current_items);
                   } elsif ($numnew == 2) { # flushcourselogs() from 1.2.X
                       $courseinfo .= ':'.$current_items[$numcurrent-1];
                   }
               }
       $hashref->{$key}=$courseinfo.':'.$now;
  }   }
 # ---------------------------------------------------------------------- tmpdel   if (untie(%$hashref)) {
     } elsif ($userinput =~ /^tmpdel/) {      &Reply( $client, "ok\n", $userinput);
  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 {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)
            ." untie(GDBM) Failed ".
        "while attempting courseidput\n", $userinput);
  }   }
 # ----------------------------------------- portfolio directory list (portls)      } else {
     } elsif ($userinput =~ /^portls/) {   &Failure($client, "error: ".($!+0)
  if(isClient) {   ." tie(GDBM) Failed ".
     my ($cmd,$uname,$udom)=split(/:/,$userinput);   "while attempting courseidput\n", $userinput);
     my $udir=propath($udom,$uname).'/userfiles/portfolio';      }
     my $dirLine='';      
     my $dirContents='';  
     if (opendir(LSDIR,$udir.'/')){      return 1;
  while ($dirLine = readdir(LSDIR)){  }
     $dirContents = $dirContents.$dirLine.'<br />';  &register_handler("courseidput", \&put_course_id_handler, 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.
   #                 institutional code - optional supplied code to filter 
   #                            the dump. Only courses with an institutional code 
   #                            that match the supplied code will be returned.
   #                 owner    - optional supplied username of owner to filter
   #                            the dump.  Only courses for which the course 
   #                            owner matches the supplied username will be
   #                            returned. Implicit assumption that owner
   #                            is a user in the domain in which the
   #                            course database is defined.
   #     $client  - The socket open on the client.
   # Returns:
   #    1     - Continue processing.
   # Side Effects:
   #   a reply is written to $client.
   sub dump_course_id_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail);
       if (defined($description)) {
    $description=&unescape($description);
       } else {
    $description='.';
       }
       if (defined($instcodefilter)) {
           $instcodefilter=&unescape($instcodefilter);
       } else {
           $instcodefilter='.';
       }
       if (defined($ownerfilter)) {
           $ownerfilter=&unescape($ownerfilter);
       } else {
           $ownerfilter='.';
       }
       if (defined($coursefilter)) {
           $coursefilter=&unescape($coursefilter);
       } else {
           $coursefilter='.';
       }
   
       unless (defined($since)) { $since=0; }
       my $qresult='';
       my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
    while (my ($key,$value) = each(%$hashref)) {
       my ($descr,$lasttime,$inst_code,$owner);
               my @courseitems = split(/:/,$value);
               $lasttime = pop(@courseitems);
       ($descr,$inst_code,$owner)=@courseitems;
       if ($lasttime<$since) { next; }
               my $match = 1;
       unless ($description eq '.') {
    my $unescapeDescr = &unescape($descr);
    unless (eval('$unescapeDescr=~/\Q$description\E/i')) {
                       $match = 0;
  }   }
     } else {              }
  $dirContents = "No directory found\n";              unless ($instcodefilter eq '.' || !defined($instcodefilter)) {
                   my $unescapeInstcode = &unescape($inst_code);
                   unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {
                       $match = 0;
                   }
     }      }
     print $client $dirContents."\n";              unless ($ownerfilter eq '.' || !defined($ownerfilter)) {
  } else {                  my $unescapeOwner = &unescape($owner);
     Reply($client, "refused\n", $userinput);                  unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) {
                       $match = 0;
                   }
               }
               unless ($coursefilter eq '.' || !defined($coursefilter)) {
                   my $unescapeCourse = &unescape($key);
                   unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) {
                       $match = 0;
                   }
               }
               if ($match == 1) {
                   $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';
               }
  }   }
 # -------------------------------------------------------------------------- ls   if (untie(%$hashref)) {
     } elsif ($userinput =~ /^ls/) {      chop($qresult);
  if(isClient) {      &Reply($client, "$qresult\n", $userinput);
     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 {   } else {
     Reply($client, "refused\n", $userinput);      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
           "while attempting courseiddump\n", $userinput);
  }   }
 # ----------------------------------------------------------------- setannounce      } else {
     } elsif ($userinput =~ /^setannounce/) {   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  if (isClient) {   "while attempting courseiddump\n", $userinput);
     my ($cmd,$announcement)=split(/:/,$userinput);      }
     chomp($announcement);  
     $announcement=&unescape($announcement);  
     if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}.      return 1;
  '/announcement.txt')) {  }
  print $store $announcement;  &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
  close $store;  
  print $client "ok\n";  #
     } else {  #  Puts an id to a domains id database. 
  print $client "error: ".($!+0)."\n";  #
     }  #  Parameters:
  } else {  #   $cmd     - The command that triggered us.
     Reply($client, "refused\n", $userinput);  #   $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 put_id_handler {
       my ($cmd,$tail,$client) = @_;
   
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my @pairs=split(/\&/,$what);
       my $hashref = &tie_domain_hash($udom, "ids", &GDBM_WRCREAT(),
      "P", $what);
       if ($hashref) {
    foreach my $pair (@pairs) {
       my ($key,$value)=split(/=/,$pair);
       $hashref->{$key}=$value;
  }   }
 # ------------------------------------------------------------------ Hanging up   if (untie(%$hashref)) {
     } elsif (($userinput =~ /^exit/) ||      &Reply($client, "ok\n", $userinput);
      ($userinput =~ /^init/)) { # no restrictions.  
  &logthis(  
  "Client $clientip ($clientname) hanging up: $userinput");  
  print $client "bye\n";  
  $client->shutdown(2);        # shutdown the socket forcibly.  
  $client->close();  
  return 0;  
   
 # ---------------------------------- set current host/domain  
     } elsif ($userinput =~ /^sethost:/) {  
  if (isClient) {  
     print $client &sethost($userinput)."\n";  
  } else {   } else {
     print $client "refused\n";      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
        "while attempting idput\n", $userinput);
  }   }
 #---------------------------------- request file (?) version.      } else {
     } elsif ($userinput =~/^version:/) {   &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
  if (isClient) {    "while attempting idput\n", $userinput);
     print $client &version($userinput)."\n";      }
   
       return 1;
   }
   &register_handler("idput", \&put_id_handler, 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 get_id_handler {
       my ($cmd, $tail, $client) = @_;
   
       
       my $userinput = "$client:$tail";
       
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my @queries=split(/\&/,$what);
       my $qresult='';
       my $hashref = &tie_domain_hash($udom, "ids", &GDBM_READER());
       if ($hashref) {
    for (my $i=0;$i<=$#queries;$i++) {
       $qresult.="$hashref->{$queries[$i]}&";
    }
    if (untie(%$hashref)) {
       $qresult=~s/\&$//;
       &Reply($client, "$qresult\n", $userinput);
  } else {   } else {
     print $client "refused\n";      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
         "while attempting idget\n",$userinput);
  }   }
 #------------------------------- is auto-enrollment enabled?      } else {
     } elsif ($userinput =~/^autorun:/) {   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  if (isClient) {   "while attempting idget\n",$userinput);
     my ($cmd,$cdom) = split(/:/,$userinput);      }
     my $outcome = &localenroll::run($cdom);      
     print $client "$outcome\n";      return 1;
   }
   &register_handler("idget", \&get_id_handler, 0, 1, 0);
   
   #
   # Puts broadcast e-mail sent by Domain Coordinator in nohist_dcmail database 
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose dcmail we are recording
   #               email    Consists of key=value pair 
   #                        where key is unique msgid
   #                        and value is message (in XML)
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply is written to $client.
   #
   sub put_dcmail_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
                                                                                   
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
       if ($hashref) {
           my ($key,$value)=split(/=/,$what);
           $hashref->{$key}=$value;
       }
       if (untie(%$hashref)) {
           &Reply($client, "ok\n", $userinput);
       } else {
           &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                    "while attempting dcmailput\n", $userinput);
       }
       return 1;
   }
   &register_handler("dcmailput", \&put_dcmail_handler, 0, 1, 0);
   
   #
   # Retrieves broadcast e-mail from nohist_dcmail database
   # Returns to client an & separated list of key=value pairs,
   # where key is msgid and value is message information.
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose dcmail table we dump
   #               startfilter - beginning of time window 
   #               endfilter - end of time window
   #               sendersfilter - & separated list of username:domain 
   #                 for senders to search for.
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply (& separated list of msgid=messageinfo pairs) is 
   #     written to $client.
   #
   sub dump_dcmail_handler {
       my ($cmd, $tail, $client) = @_;
                                                                                   
       my $userinput = "$cmd:$tail";
       my ($udom,$startfilter,$endfilter,$sendersfilter) = split(/:/,$tail);
       chomp($sendersfilter);
       my @senders = ();
       if (defined($startfilter)) {
           $startfilter=&unescape($startfilter);
       } else {
           $startfilter='.';
       }
       if (defined($endfilter)) {
           $endfilter=&unescape($endfilter);
       } else {
           $endfilter='.';
       }
       if (defined($sendersfilter)) {
           $sendersfilter=&unescape($sendersfilter);
    @senders = map { &unescape($_) } split(/\&/,$sendersfilter);
       }
   
       my $qresult='';
       my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
       if ($hashref) {
           while (my ($key,$value) = each(%$hashref)) {
               my $match = 1;
               my ($timestamp,$subj,$uname,$udom) = 
    split(/:/,&unescape(&unescape($key)),5); # yes, twice really
               $timestamp = &unescape($timestamp);
               $subj = &unescape($subj);
               $uname = &unescape($uname);
               $udom = &unescape($udom);
               unless ($startfilter eq '.' || !defined($startfilter)) {
                   if ($timestamp < $startfilter) {
                       $match = 0;
                   }
               }
               unless ($endfilter eq '.' || !defined($endfilter)) {
                   if ($timestamp > $endfilter) {
                       $match = 0;
                   }
               }
               unless (@senders < 1) {
                   unless (grep/^$uname:$udom$/,@senders) {
                       $match = 0;
                   }
               }
               if ($match == 1) {
                   $qresult.=$key.'='.$value.'&';
               }
           }
           if (untie(%$hashref)) {
               chop($qresult);
               &Reply($client, "$qresult\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting dcmaildump\n", $userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                   "while attempting dcmaildump\n", $userinput);
       }
       return 1;
   }
   
   &register_handler("dcmaildump", \&dump_dcmail_handler, 0, 1, 0);
   
   #
   # Puts domain roles in nohist_domainroles database
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose roles we are recording  
   #               role -   Consists of key=value pair
   #                        where key is unique role
   #                        and value is start/end date information
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply is written to $client.
   #
   
   sub put_domainroles_handler {
       my ($cmd,$tail,$client) = @_;
   
       my $userinput = "$cmd:$tail";
       my ($udom,$what)=split(/:/,$tail);
       chomp($what);
       my @pairs=split(/\&/,$what);
       my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
       if ($hashref) {
           foreach my $pair (@pairs) {
               my ($key,$value)=split(/=/,$pair);
               $hashref->{$key}=$value;
           }
           if (untie(%$hashref)) {
               &Reply($client, "ok\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                        "while attempting domroleput\n", $userinput);
           }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                     "while attempting domroleput\n", $userinput);
       }
                                                                                     
       return 1;
   }
   
   &register_handler("domroleput", \&put_domainroles_handler, 0, 1, 0);
   
   #
   # Retrieves domain roles from nohist_domainroles database
   # Returns to client an & separated list of key=value pairs,
   # where key is role and value is start and end date information.
   #
   # Parameters
   #   $cmd       - Command keyword that caused us to be dispatched.
   #   $tail      - Tail of the command.  Consists of a colon separated:
   #               domain - the domain whose domain roles table we dump
   #   $client    - Socket open on the client.
   #
   # Returns:
   #    1 - indicating processing should continue.
   # Side effects
   #     reply (& separated list of role=start/end info pairs) is
   #     written to $client.
   #
   sub dump_domainroles_handler {
       my ($cmd, $tail, $client) = @_;
                                                                                              
       my $userinput = "$cmd:$tail";
       my ($udom,$startfilter,$endfilter,$rolesfilter) = split(/:/,$tail);
       chomp($rolesfilter);
       my @roles = ();
       if (defined($startfilter)) {
           $startfilter=&unescape($startfilter);
       } else {
           $startfilter='.';
       }
       if (defined($endfilter)) {
           $endfilter=&unescape($endfilter);
       } else {
           $endfilter='.';
       }
       if (defined($rolesfilter)) {
           $rolesfilter=&unescape($rolesfilter);
    @roles = split(/\&/,$rolesfilter);
       }
                                                                                              
       my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
       if ($hashref) {
           my $qresult = '';
           while (my ($key,$value) = each(%$hashref)) {
               my $match = 1;
               my ($start,$end) = split(/:/,&unescape($value));
               my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
               unless ($startfilter eq '.' || !defined($startfilter)) {
                   if ($start >= $startfilter) {
                       $match = 0;
                   }
               }
               unless ($endfilter eq '.' || !defined($endfilter)) {
                   if ($end <= $endfilter) {
                       $match = 0;
                   }
               }
               unless (@roles < 1) {
                   unless (grep/^$trole$/,@roles) {
                       $match = 0;
                   }
               }
               if ($match == 1) {
                   $qresult.=$key.'='.$value.'&';
               }
           }
           if (untie(%$hashref)) {
               chop($qresult);
               &Reply($client, "$qresult\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting domrolesdump\n", $userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                   "while attempting domrolesdump\n", $userinput);
       }
       return 1;
   }
   
   &register_handler("domrolesdump", \&dump_domainroles_handler, 0, 1, 0);
   
   
   #  Process the tmpput command I'm not sure what this does.. Seems to
   #  create a file in the lonDaemons/tmp directory of the form $id.tmp
   # where Id is the client's ip concatenated with a sequence number.
   # The file will contain some value that is passed in.  Is this e.g.
   # a login token?
   #
   # Parameters:
   #    $cmd     - The command that got us dispatched.
   #    $tail    - The remainder of the request following $cmd:
   #               In this case this will be the contents of the file.
   #    $client  - Socket connected to the client.
   # Returns:
   #    1 indicating processing can continue.
   # Side effects:
   #   A file is created in the local filesystem.
   #   A reply is sent to the client.
   sub tmp_put_handler {
       my ($cmd, $what, $client) = @_;
   
       my $userinput = "$cmd:$what"; # Reconstruct for logging.
   
   
       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);
       }
       return 1;
     
   }
   &register_handler("tmpput", \&tmp_put_handler, 0, 1, 0);
   
   #   Processes the tmpget command.  This command returns the contents
   #  of a temporary resource file(?) created via tmpput.
   #
   # Paramters:
   #    $cmd      - Command that got us dispatched.
   #    $id       - Tail of the command, contain the id of the resource
   #                we want to fetch.
   #    $client   - socket open on the client.
   # Return:
   #    1         - Inidcating processing can continue.
   # Side effects:
   #   A reply is sent to the client.
   #
   sub tmp_get_handler {
       my ($cmd, $id, $client) = @_;
   
       my $userinput = "$cmd:$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);
       }
   
       return 1;
   }
   &register_handler("tmpget", \&tmp_get_handler, 0, 1, 0);
   
   #
   #  Process the tmpdel command.  This command deletes a temp resource
   #  created by the tmpput command.
   #
   # Parameters:
   #   $cmd      - Command that got us here.
   #   $id       - Id of the temporary resource created.
   #   $client   - socket open on the client process.
   #
   # Returns:
   #   1     - Indicating processing should continue.
   # Side Effects:
   #   A file is deleted
   #   A reply is sent to the client.
   sub tmp_del_handler {
       my ($cmd, $id, $client) = @_;
       
       my $userinput= "$cmd:$id";
       
       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);
       }
       
       return 1;
   
   }
   &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);
   
   #
   #   Processes the setannounce command.  This command
   #   creates a file named announce.txt in the top directory of
   #   the documentn root and sets its contents.  The announce.txt file is
   #   printed in its entirety at the LonCAPA login page.  Note:
   #   once the announcement.txt fileis created it cannot be deleted.
   #   However, setting the contents of the file to empty removes the
   #   announcement from the login page of loncapa so who cares.
   #
   # Parameters:
   #    $cmd          - The command that got us dispatched.
   #    $announcement - The text of the announcement.
   #    $client       - Socket open on the client process.
   # Retunrns:
   #   1             - Indicating request processing should continue
   # Side Effects:
   #   The file {DocRoot}/announcement.txt is created.
   #   A reply is sent to $client.
   #
   sub set_announce_handler {
       my ($cmd, $announcement, $client) = @_;
     
       my $userinput    = "$cmd:$announcement";
   
       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);
       }
   
       return 1;
   }
   &register_handler("setannounce", \&set_announce_handler, 0, 1, 0);
   
   #
   #  Return the version of the daemon.  This can be used to determine
   #  the compatibility of cross version installations or, alternatively to
   #  simply know who's out of date and who isn't.  Note that the version
   #  is returned concatenated with the tail.
   # Parameters:
   #   $cmd        - the request that dispatched to us.
   #   $tail       - Tail of the request (client's version?).
   #   $client     - Socket open on the client.
   #Returns:
   #   1 - continue processing requests.
   # Side Effects:
   #   Replies with version to $client.
   sub get_version_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput  = $cmd.$tail;
       
       &Reply($client, &version($userinput)."\n", $userinput);
   
   
       return 1;
   }
   &register_handler("version", \&get_version_handler, 0, 1, 0);
   
   #  Set the current host and domain.  This is used to support
   #  multihomed systems.  Each IP of the system, or even separate daemons
   #  on the same IP can be treated as handling a separate lonCAPA virtual
   #  machine.  This command selects the virtual lonCAPA.  The client always
   #  knows the right one since it is lonc and it is selecting the domain/system
   #  from the hosts.tab file.
   # Parameters:
   #    $cmd      - Command that dispatched us.
   #    $tail     - Tail of the command (domain/host requested).
   #    $socket   - Socket open on the client.
   #
   # Returns:
   #     1   - Indicates the program should continue to process requests.
   # Side-effects:
   #     The default domain/system context is modified for this daemon.
   #     a reply is sent to the client.
   #
   sub set_virtual_host_handler {
       my ($cmd, $tail, $socket) = @_;
     
       my $userinput  ="$cmd:$tail";
   
       &Reply($client, &sethost($userinput)."\n", $userinput);
   
   
       return 1;
   }
   &register_handler("sethost", \&set_virtual_host_handler, 0, 1, 0);
   
   #  Process a request to exit:
   #   - "bye" is sent to the client.
   #   - The client socket is shutdown and closed.
   #   - We indicate to the caller that we should exit.
   # Formal Parameters:
   #   $cmd                - The command that got us here.
   #   $tail               - Tail of the command (empty).
   #   $client             - Socket open on the tail.
   # Returns:
   #   0      - Indicating the program should exit!!
   #
   sub exit_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$cmd:$tail";
   
       &logthis("Client $clientip ($clientname) hanging up: $userinput");
       &Reply($client, "bye\n", $userinput);
       $client->shutdown(2);        # shutdown the socket forcibly.
       $client->close();
   
       return 0;
   }
   &register_handler("exit", \&exit_handler, 0,1,1);
   &register_handler("init", \&exit_handler, 0,1,1);
   &register_handler("quit", \&exit_handler, 0,1,1);
   
   #  Determine if auto-enrollment is enabled.
   #  Note that the original had what I believe to be a defect.
   #  The original returned 0 if the requestor was not a registerd client.
   #  It should return "refused".
   # Formal Parameters:
   #   $cmd       - The command that invoked us.
   #   $tail      - The tail of the command (Extra command parameters.
   #   $client    - The socket open on the client that issued the request.
   # Returns:
   #    1         - Indicating processing should continue.
   #
   sub enrollment_enabled_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = $cmd.":".$tail; # For logging purposes.
   
       
       my $cdom = split(/:/, $tail);   # Domain we're asking about.
       my $outcome  = &localenroll::run($cdom);
       &Reply($client, "$outcome\n", $userinput);
   
       return 1;
   }
   &register_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);
   
   #   Get the official sections for which auto-enrollment is possible.
   #   Since the admin people won't know about 'unofficial sections' 
   #   we cannot auto-enroll on them.
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched here.
   #    $tail    - The remainder of the request.  In our case this
   #               will be split into:
   #               $coursecode   - The course name from the admin point of view.
   #               $cdom         - The course's domain(?).
   #    $client  - Socket open on the client.
   # Returns:
   #    1    - Indiciting processing should continue.
   #
   sub get_sections_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
   
       my ($coursecode, $cdom) = split(/:/, $tail);
       my @secs = &localenroll::get_sections($coursecode,$cdom);
       my $seclist = &escape(join(':',@secs));
   
       &Reply($client, "$seclist\n", $userinput);
       
   
       return 1;
   }
   &register_handler("autogetsections", \&get_sections_handler, 0, 1, 0);
   
   #   Validate the owner of a new course section.  
   #
   # Formal Parameters:
   #   $cmd      - Command that got us dispatched.
   #   $tail     - the remainder of the command.  For us this consists of a
   #               colon separated string containing:
   #                  $inst    - Course Id from the institutions point of view.
   #                  $owner   - Proposed owner of the course.
   #                  $cdom    - Domain of the course (from the institutions
   #                             point of view?)..
   #   $client   - Socket open on the client.
   #
   # Returns:
   #   1        - Processing should continue.
   #
   sub validate_course_owner_handler {
       my ($cmd, $tail, $client)  = @_;
       my $userinput = "$cmd:$tail";
       my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);
   
       my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
       &Reply($client, "$outcome\n", $userinput);
   
   
   
       return 1;
   }
   &register_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0);
   
   #
   #   Validate a course section in the official schedule of classes
   #   from the institutions point of view (part of autoenrollment).
   #
   # Formal Parameters:
   #   $cmd          - The command request that got us dispatched.
   #   $tail         - The tail of the command.  In this case,
   #                   this is a colon separated set of words that will be split
   #                   into:
   #                        $inst_course_id - The course/section id from the
   #                                          institutions point of view.
   #                        $cdom           - The domain from the institutions
   #                                          point of view.
   #   $client       - Socket open on the client.
   # Returns:
   #    1           - Indicating processing should continue.
   #
   sub validate_course_section_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($inst_course_id, $cdom) = split(/:/, $tail);
   
       my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
       &Reply($client, "$outcome\n", $userinput);
   
   
       return 1;
   }
   &register_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);
   
   #
   #   Create a password for a new auto-enrollment user.
   #   I think/guess, this password allows access to the institutions 
   #   AIS class list server/services.  Stuart can correct this comment
   #   when he finds out how wrong I am.
   #
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched.
   #    $tail    - The tail of the command.   In this case this is a colon separated
   #               set of words that will be split into:
   #               $authparam - An authentication parameter (username??).
   #               $cdom      - The domain of the course from the institution's
   #                            point of view.
   #    $client  - The socket open on the client.
   # Returns:
   #    1 - continue processing.
   #
   sub create_auto_enroll_password_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
   
       my ($authparam, $cdom) = split(/:/, $userinput);
   
       my ($create_passwd,$authchk);
       ($authparam,
        $create_passwd,
        $authchk) = &localenroll::create_password($authparam,$cdom);
   
       &Reply($client, &escape($authparam.':'.$create_passwd.':'.$authchk)."\n",
      $userinput);
   
   
       return 1;
   }
   &register_handler("autocreatepassword", \&create_auto_enroll_password_handler, 
     0, 1, 0);
   
   #   Retrieve and remove temporary files created by/during autoenrollment.
   #
   # Formal Parameters:
   #    $cmd      - The command that got us dispatched.
   #    $tail     - The tail of the command.  In our case this is a colon 
   #                separated list that will be split into:
   #                $filename - The name of the file to remove.
   #                            The filename is given as a path relative to
   #                            the LonCAPA temp file directory.
   #    $client   - Socket open on the client.
   #
   # Returns:
   #   1     - Continue processing.
   sub retrieve_auto_file_handler {
       my ($cmd, $tail, $client)    = @_;
       my $userinput                = "cmd:$tail";
   
       my ($filename)   = split(/:/, $tail);
   
       my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
       if ( (-e $source) && ($filename ne '') ) {
    my $reply = '';
    if (open(my $fh,$source)) {
       while (<$fh>) {
    chomp($_);
    $_ =~ s/^\s+//g;
    $_ =~ s/\s+$//g;
    $reply .= $_;
       }
       close($fh);
       &Reply($client, &escape($reply)."\n", $userinput);
   
   #   Does this have to be uncommented??!?  (RF).
   #
   #                                unlink($source);
  } else {   } else {
     print $client "0\n";      &Failure($client, "error\n", $userinput);
  }   }
 #------------------------------- get official sections (for auto-enrollment).      } else {
     } elsif ($userinput =~/^autogetsections:/) {   &Failure($client, "error\n", $userinput);
  if (isClient) {      }
     my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);      
     my @secs = &localenroll::get_sections($coursecode,$cdom);  
     my $seclist = &escape(join(':',@secs));      return 1;
     print $client "$seclist\n";  }
  } else {  &register_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);
     print $client "refused\n";  
   #
   #   Read and retrieve institutional code format (for support form).
   # Formal Parameters:
   #    $cmd        - Command that dispatched us.
   #    $tail       - Tail of the command.  In this case it conatins 
   #                  the course domain and the coursename.
   #    $client     - Socket open on the client.
   # Returns:
   #    1     - Continue processing.
   #
   sub get_institutional_code_format_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
   
       my $reply;
       my($cdom,$course) = split(/:/,$tail);
       my @pairs = split/\&/,$course;
       my %instcodes = ();
       my %codes = ();
       my @codetitles = ();
       my %cat_titles = ();
       my %cat_order = ();
       foreach (@pairs) {
    my ($key,$value) = split/=/,$_;
    $instcodes{&unescape($key)} = &unescape($value);
       }
       my $formatreply = &localenroll::instcode_format($cdom,
       \%instcodes,
       \%codes,
       \@codetitles,
       \%cat_titles,
       \%cat_order);
       if ($formatreply eq 'ok') {
    my $codes_str = &hash2str(%codes);
    my $codetitles_str = &array2str(@codetitles);
    my $cat_titles_str = &hash2str(%cat_titles);
    my $cat_order_str = &hash2str(%cat_order);
    &Reply($client,
          $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
          .$cat_order_str."\n",
          $userinput);
       } else {
    # this else branch added by RF since if not ok, lonc will
    # hang waiting on reply until timeout.
    #
    &Reply($client, "format_error\n", $userinput);
       }
       
       return 1;
   }
   &register_handler("autoinstcodeformat",
     \&get_institutional_code_format_handler,0,1,0);
   
   #
   # Gets a student's photo to exist (in the correct image type) in the user's 
   # directory.
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched.
   #    $tail    - A colon separated set of words that will be split into:
   #               $domain - student's domain
   #               $uname  - student username
   #               $type   - image type desired
   #    $client  - The socket open on the client.
   # Returns:
   #    1 - continue processing.
   sub student_photo_handler {
       my ($cmd, $tail, $client) = @_;
       my ($domain,$uname,$type) = split(/:/, $tail);
   
       my $path=&propath($domain,$uname).
    '/userfiles/internal/studentphoto.'.$type;
       if (-e $path) {
    &Reply($client,"ok\n","$cmd:$tail");
    return 1;
       }
       &mkpath($path);
       my $file=&localstudentphoto::fetch($domain,$uname);
       if (!$file) {
    &Failure($client,"unavailable\n","$cmd:$tail");
    return 1;
       }
       if (!-e $path) { &convert_photo($file,$path); }
       if (-e $path) {
    &Reply($client,"ok\n","$cmd:$tail");
    return 1;
       }
       &Failure($client,"unable_to_convert\n","$cmd:$tail");
       return 1;
   }
   &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);
   
   # mkpath makes all directories for a file, expects an absolute path with a
   # file or a trailing / if just a dir is passed
   # returns 1 on success 0 on failure
   sub mkpath {
       my ($file)=@_;
       my @parts=split(/\//,$file,-1);
       my $now=$parts[0].'/'.$parts[1].'/'.$parts[2];
       for (my $i=3;$i<= ($#parts-1);$i++) {
    $now.='/'.$parts[$i]; 
    if (!-e $now) {
       if  (!mkdir($now,0770)) { return 0; }
  }   }
 #----------------------- validate owner of new course section (for auto-enrollment).      }
     } elsif ($userinput =~/^autonewcourse:/) {      return 1;
  if (isClient) {  }
     my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);  
     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);  #---------------------------------------------------------------
     print $client "$outcome\n";  #
  } else {  #   Getting, decoding and dispatching requests:
     print $client "refused\n";  #
   #
   #   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 get_request {
       my $input = <$client>;
       chomp($input);
   
       &Debug("get_request: Request = $input\n");
   
       &status('Processing '.$clientname.':'.$input);
   
       return $input;
   }
   #---------------------------------------------------------------
   #
   #  Process a request.  This sub should shrink as each action
   #  gets farmed out into a separat sub that is registered 
   #  with the dispatch hash.  
   #
   # Parameters:
   #    user_input   - The request received from the client (lonc).
   # Returns:
   #    true to keep processing, false if caller should exit.
   #
   sub process_request {
       my ($userinput) = @_;      # Easier for now to break style than to
                                   # fix all the userinput -> user_input.
       my $wasenc    = 0; # True if request was encrypted.
   # ------------------------------------------------------------ See if encrypted
       if ($userinput =~ /^enc/) {
    $userinput = decipher($userinput);
    $wasenc=1;
    if(!$userinput) { # Cipher not defined.
       &Failure($client, "error: Encrypted data without negotated key\n");
       return 0;
  }   }
 #-------------- validate course section in schedule of classes (for auto-enrollment).      }
     } elsif ($userinput =~/^autovalidatecourse:/) {      Debug("process_request: $userinput\n");
  if (isClient) {      
     my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);      #  
     my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);      #   The 'correct way' to add a command to lond is now to
     print $client "$outcome\n";      #   write a sub to execute it and Add it to the command dispatch
  } else {      #   hash via a call to register_handler..  The comments to that
     print $client "refused\n";      #   sub should give you enough to go on to show how to do this
       #   along with the examples that are building up as this code
       #   is getting refactored.   Until all branches of the
       #   if/elseif monster below have been factored out into
       #   separate procesor subs, if the dispatch hash is missing
       #   the command keyword, we will fall through to the remainder
       #   of the if/else chain below in order to keep this thing in 
       #   working order throughout the transmogrification.
   
       my ($command, $tail) = split(/:/, $userinput, 2);
       chomp($command);
       chomp($tail);
       $tail =~ s/(\r)//; # This helps people debugging with e.g. telnet.
       $command =~ s/(\r)//; # And this too for parameterless commands.
       if(!$tail) {
    $tail =""; # defined but blank.
       }
   
       &Debug("Command received: $command, encoded = $wasenc");
   
       if(defined $Dispatcher{$command}) {
   
    my $dispatch_info = $Dispatcher{$command};
    my $handler       = $$dispatch_info[0];
    my $need_encode   = $$dispatch_info[1];
    my $client_types  = $$dispatch_info[2];
    Debug("Matched dispatch hash: mustencode: $need_encode "
         ."ClientType $client_types");
         
    #  Validate the request:
         
    my $ok = 1;
    my $requesterprivs = 0;
    if(&isClient()) {
       $requesterprivs |= $CLIENT_OK;
  }   }
 #--------------------------- create password for new user (for auto-enrollment).   if(&isManager()) {
     } elsif ($userinput =~/^autocreatepassword:/) {      $requesterprivs |= $MANAGER_OK;
  if (isClient) {  
     my ($cmd,$authparam,$cdom)=split(/:/,$userinput);  
     my ($create_passwd,$authchk);  
     ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom);  
     print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";  
  } else {  
     print $client "refused\n";  
  }   }
 #---------------------------  read and remove temporary files (for auto-enrollment).   if($need_encode && (!$wasenc)) {
     } elsif ($userinput =~/^autoretrieve:/) {      Debug("Must encode but wasn't: $need_encode $wasenc");
  if (isClient) {      $ok = 0;
     my ($cmd,$filename) = split(/:/,$userinput);  
     my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;  
     if ( (-e $source) && ($filename ne '') ) {  
  my $reply = '';  
  if (open(my $fh,$source)) {  
     while (<$fh>) {  
  chomp($_);  
  $_ =~ s/^\s+//g;  
  $_ =~ s/\s+$//g;  
  $reply .= $_;  
     }  
     close($fh);  
     print $client &escape($reply)."\n";  
 #                                unlink($source);  
  } else {  
     print $client "error\n";  
  }  
     } else {  
  print $client "error\n";  
     }  
  } else {  
     print $client "refused\n";  
  }   }
 #---------------------  read and retrieve institutional code format (for support form).   if(($client_types & $requesterprivs) == 0) {
     } elsif ($userinput =~/^autoinstcodeformat:/) {      Debug("Client not privileged to do this operation");
  if (isClient) {      $ok = 0;
     my $reply;   }
     my($cmd,$cdom,$course) = split(/:/,$userinput);  
     my @pairs = split/\&/,$course;   if($ok) {
     my %instcodes = ();      Debug("Dispatching to handler $command $tail");
     my %codes = ();      my $keep_going = &$handler($command, $tail, $client);
     my @codetitles = ();      return $keep_going;
     my %cat_titles = ();  
     my %cat_order = ();  
     foreach (@pairs) {  
  my ($key,$value) = split/=/,$_;  
  $instcodes{&unescape($key)} = &unescape($value);  
     }  
     my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order);  
     if ($formatreply eq 'ok') {  
  my $codes_str = &hash2str(%codes);  
  my $codetitles_str = &array2str(@codetitles);  
  my $cat_titles_str = &hash2str(%cat_titles);  
  my $cat_order_str = &hash2str(%cat_order);  
  print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n";  
     }  
  } else {   } else {
     print $client "refused\n";      Debug("Refusing to dispatch because client did not match requirements");
       Failure($client, "refused\n", $userinput);
       return 1;
  }   }
 # ------------------------------------------------------------- unknown command  
       }    
     } else {  
  # unknown command      print $client "unknown_cmd\n";
  print $client "unknown_cmd\n";  
     }  
 # -------------------------------------------------------------------- complete  # -------------------------------------------------------------------- complete
     Debug("process_request - returning 1");      Debug("process_request - returning 1");
     return 1;      return 1;
Line 3010  sub register_handler { Line 4488  sub register_handler {
         
     $Dispatcher{$request_name} = \@entry;      $Dispatcher{$request_name} = \@entry;
         
      
 }  }
   
   
Line 3057  sub catchexception { Line 4534  sub catchexception {
     $server->close();      $server->close();
     die($error);      die($error);
 }  }
   
 sub timeout {  sub timeout {
     &status("Handling Timeout");      &status("Handling Timeout");
     &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");      &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
Line 3065  sub timeout { Line 4541  sub timeout {
 }  }
 # -------------------------------- Set signal handlers to record abnormal exits  # -------------------------------- Set signal handlers to record abnormal exits
   
   
 $SIG{'QUIT'}=\&catchexception;  $SIG{'QUIT'}=\&catchexception;
 $SIG{__DIE__}=\&catchexception;  $SIG{__DIE__}=\&catchexception;
   
Line 3190  sub ReadHostTable { Line 4667  sub ReadHostTable {
     open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";      open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
     my $myloncapaname = $perlvar{'lonHostID'};      my $myloncapaname = $perlvar{'lonHostID'};
     Debug("My loncapa name is : $myloncapaname");      Debug("My loncapa name is : $myloncapaname");
       my %name_to_ip;
     while (my $configline=<CONFIG>) {      while (my $configline=<CONFIG>) {
  if (!($configline =~ /^\s*\#/)) {   if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) {
     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);      my ($id,$domain,$role,$name)=split(/:/,$configline);
     chomp($ip); $ip=~s/\D+$//;      $name=~s/\s//g;
       my $ip;
       if (!exists($name_to_ip{$name})) {
    $ip = gethostbyname($name);
    if (!$ip || length($ip) ne 4) {
       &logthis("Skipping host $id name $name no IP found\n");
       next;
    }
    $ip=inet_ntoa($ip);
    $name_to_ip{$name} = $ip;
       } else {
    $ip = $name_to_ip{$name};
       }
     $hostid{$ip}=$id;         # LonCAPA name of host by IP.      $hostid{$ip}=$id;         # LonCAPA name of host by IP.
     $hostdom{$id}=$domain;    # LonCAPA domain name of host.       $hostdom{$id}=$domain;    # LonCAPA domain name of host. 
     $hostip{$id}=$ip;      # IP address of host.      $hostip{$id}=$ip;         # IP address of host.
     $hostdns{$name} = $id;    # LonCAPA name of host by DNS.      $hostdns{$name} = $id;    # LonCAPA name of host by DNS.
   
     if ($id eq $perlvar{'lonHostID'}) {       if ($id eq $perlvar{'lonHostID'}) { 
Line 3333  sub Reply { Line 4823  sub Reply {
     Debug("Request was $request  Reply was $reply");      Debug("Request was $request  Reply was $reply");
   
     $Transactions++;      $Transactions++;
   
   
 }  }
   
   
Line 3377  sub logstatus { Line 4865  sub logstatus {
  flock(LOG,LOCK_EX);   flock(LOG,LOCK_EX);
  print LOG $$."\t".$clientname."\t".$currenthostid."\t"   print LOG $$."\t".$clientname."\t".$currenthostid."\t"
     .$status."\t".$lastlog."\t $keymode\n";      .$status."\t".$lastlog."\t $keymode\n";
  flock(DB,LOCK_UN);   flock(LOG,LOCK_UN);
  close(LOG);   close(LOG);
     }      }
     &status("Finished logging");      &status("Finished logging");
Line 3481  sub reply { Line 4969  sub reply {
   
 # -------------------------------------------------------------- Talk to lonsql  # -------------------------------------------------------------- Talk to lonsql
   
 sub sqlreply {  sub sql_reply {
     my ($cmd)=@_;      my ($cmd)=@_;
     my $answer=subsqlreply($cmd);      my $answer=&sub_sql_reply($cmd);
     if ($answer eq 'con_lost') { $answer=subsqlreply($cmd); }      if ($answer eq 'con_lost') { $answer=&sub_sql_reply($cmd); }
     return $answer;      return $answer;
 }  }
   
 sub subsqlreply {  sub sub_sql_reply {
     my ($cmd)=@_;      my ($cmd)=@_;
     my $unixsock="mysqlsock";      my $unixsock="mysqlsock";
     my $peerfile="$perlvar{'lonSockDir'}/$unixsock";      my $peerfile="$perlvar{'lonSockDir'}/$unixsock";
Line 3562  $SIG{USR2} = \&UpdateHosts; Line 5050  $SIG{USR2} = \&UpdateHosts;
   
 ReadHostTable;  ReadHostTable;
   
   my $dist=`$perlvar{'lonDaemons'}/distprobe`;
   
 # --------------------------------------------------------------  # --------------------------------------------------------------
 #   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 3608  sub make_new_child { Line 5098  sub make_new_child {
     if (defined($iaddr)) {      if (defined($iaddr)) {
  $clientip  = inet_ntoa($iaddr);   $clientip  = inet_ntoa($iaddr);
  Debug("Connected with $clientip");   Debug("Connected with $clientip");
  $clientdns = gethostbyaddr($iaddr, AF_INET);  
  Debug("Connected with $clientdns by name");  
     } else {      } else {
  &logthis("Unable to determine clientip");   &logthis("Unable to determine clientip");
  $clientip='Unavailable';   $clientip='Unavailable';
Line 3639  sub make_new_child { Line 5127  sub make_new_child {
 #        my $tmpsnum=0;            # Now global  #        my $tmpsnum=0;            # Now global
 #---------------------------------------------------- kerberos 5 initialization  #---------------------------------------------------- kerberos 5 initialization
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
         &Authen::Krb5::init_ets();   unless (($dist eq 'fedora4') || ($dist eq 'suse9.3')) {
       &Authen::Krb5::init_ets();
    }
   
  &status('Accepted connection');   &status('Accepted connection');
 # =============================================================================  # =============================================================================
Line 3649  sub make_new_child { Line 5139  sub make_new_child {
   
  ReadManagerTable; # May also be a manager!!   ReadManagerTable; # May also be a manager!!
   
  my $clientrec=($hostid{$clientip}     ne undef);   my $outsideip=$clientip;
  my $ismanager=($managers{$clientip}    ne undef);   if ($clientip eq '127.0.0.1') {
       $outsideip=$hostip{$perlvar{'lonHostID'}};
    }
   
    my $clientrec=($hostid{$outsideip}     ne undef);
    my $ismanager=($managers{$outsideip}    ne undef);
  $clientname  = "[unknonwn]";   $clientname  = "[unknonwn]";
  if($clientrec) { # Establish client type.   if($clientrec) { # Establish client type.
     $ConnectionType = "client";      $ConnectionType = "client";
     $clientname = $hostid{$clientip};      $clientname = $hostid{$outsideip};
     if($ismanager) {      if($ismanager) {
  $ConnectionType = "both";   $ConnectionType = "both";
     }      }
  } else {   } else {
     $ConnectionType = "manager";      $ConnectionType = "manager";
     $clientname = $managers{$clientip};      $clientname = $managers{$outsideip};
  }   }
  my $clientok;   my $clientok;
   
Line 3694  sub make_new_child { Line 5189  sub make_new_child {
  $inittype = ""; # This forces insecure attempt.   $inittype = ""; # This forces insecure attempt.
  &logthis("<font color=\"blue\"> Certificates not "   &logthis("<font color=\"blue\"> Certificates not "
  ."installed -- trying insecure auth</font>");   ."installed -- trying insecure auth</font>");
     }      } else { # SSL certificates are in place so
     else { # SSL certificates are in place so  
     } # Leave the inittype alone.      } # Leave the inittype alone.
  }   }
   
Line 3805  sub make_new_child { Line 5299  sub make_new_child {
     exit;      exit;
           
 }  }
   #
   #   Determine if a user is an author for the indicated domain.
   #
   # Parameters:
   #    domain          - domain to check in .
   #    user            - Name of user to check.
   #
   # Return:
   #     1             - User is an author for domain.
   #     0             - User is not an author for domain.
   sub is_author {
       my ($domain, $user) = @_;
   
       &Debug("is_author: $user @ $domain");
   
       my $hashref = &tie_user_hash($domain, $user, "roles",
    &GDBM_READER());
   
       #  Author role should show up as a key /domain/_au
   
       my $key   = "/$domain/_au";
       my $value = $hashref->{$key};
   
       if(defined($value)) {
    &Debug("$user @ $domain is an author");
       }
   
       return defined($value);
   }
 #  #
 #   Checks to see if the input roleput request was to set  #   Checks to see if the input roleput request was to set
 # an author role.  If so, invokes the lchtmldir script to set  # an author role.  If so, invokes the lchtmldir script to set
Line 3818  sub make_new_child { Line 5339  sub make_new_child {
 #    user      - Name of the user for which the role is being put.  #    user      - Name of the user for which the role is being put.
 #    authtype  - The authentication type associated with the user.  #    authtype  - The authentication type associated with the user.
 #  #
 sub ManagePermissions  sub manage_permissions {
 {  
   
     my ($request, $domain, $user, $authtype) = @_;      my ($request, $domain, $user, $authtype) = @_;
   
       &Debug("manage_permissions: $request $domain $user $authtype");
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
     if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...      if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
  my $execdir = $perlvar{'lonDaemons'};   my $execdir = $perlvar{'lonDaemons'};
  my $userhome= "/home/$user" ;   my $userhome= "/home/$user" ;
  &logthis("system $execdir/lchtmldir $userhome $user $authtype");   &logthis("system $execdir/lchtmldir $userhome $user $authtype");
    &Debug("Setting homedir permissions for $userhome");
  system("$execdir/lchtmldir $userhome $user $authtype");   system("$execdir/lchtmldir $userhome $user $authtype");
     }      }
 }  }
Line 3843  sub ManagePermissions Line 5365  sub ManagePermissions
 #  #
 sub password_path {  sub password_path {
     my ($domain, $user) = @_;      my ($domain, $user) = @_;
       return &propath($domain, $user).'/passwd';
   
     my $path   = &propath($domain, $user);  
     $path  .= "/passwd";  
   
     return $path;  
 }  }
   
 #   Password Filename  #   Password Filename
Line 3923  sub get_auth_type Line 5440  sub get_auth_type
  Debug("Password info = $realpassword\n");   Debug("Password info = $realpassword\n");
  my ($authtype, $contentpwd) = split(/:/, $realpassword);   my ($authtype, $contentpwd) = split(/:/, $realpassword);
  Debug("Authtype = $authtype, content = $contentpwd\n");   Debug("Authtype = $authtype, content = $contentpwd\n");
  my $availinfo = '';   return "$authtype:$contentpwd";     
  if($authtype eq 'krb4' or $authtype eq 'krb5') {      } else {
     $availinfo = $contentpwd;  
  }  
   
  return "$authtype:$availinfo";  
     }  
     else {  
  Debug("Returning nouser");   Debug("Returning nouser");
  return "nouser";   return "nouser";
     }      }
Line 3962  sub validate_user { Line 5473  sub validate_user {
     # At the end of this function. I'll ensure that it's not still that      # At the end of this function. I'll ensure that it's not still that
     # value so we don't just wind up returning some accidental value      # value so we don't just wind up returning some accidental value
     # as a result of executing an unforseen code path that      # as a result of executing an unforseen code path that
     # did not set $validated.      # did not set $validated.  At the end of valid execution paths,
       # validated shoule be 1 for success or 0 for failuer.
   
     my $validated = -3.14159;      my $validated = -3.14159;
   
Line 4010  sub validate_user { Line 5522  sub validate_user {
    $password);     $password);
  if(!$k4error) {   if(!$k4error) {
     $validated = 1;      $validated = 1;
  }   } else {
  else {  
     $validated = 0;      $validated = 0;
     &logthis('krb4: '.$user.', '.$contentpwd.', '.      &logthis('krb4: '.$user.', '.$contentpwd.', '.
      &Authen::Krb4::get_err_txt($Authen::Krb4::error));       &Authen::Krb4::get_err_txt($Authen::Krb4::error));
  }   }
     }      } else {
     else {  
  $validated = 0; # Password has a match with null.   $validated = 0; # Password has a match with null.
     }      }
  }   } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
  elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.  
     if(!($password =~ /$null/)) { # Null password not allowed.      if(!($password =~ /$null/)) { # Null password not allowed.
  my $krbclient = &Authen::Krb5::parse_name($user.'@'   my $krbclient = &Authen::Krb5::parse_name($user.'@'
   .$contentpwd);    .$contentpwd);
Line 4029  sub validate_user { Line 5538  sub validate_user {
  my $krbserver  = &Authen::Krb5::parse_name($krbservice);   my $krbserver  = &Authen::Krb5::parse_name($krbservice);
  my $credentials= &Authen::Krb5::cc_default();   my $credentials= &Authen::Krb5::cc_default();
  $credentials->initialize($krbclient);   $credentials->initialize($krbclient);
  my $krbreturn  = &Authen::KRb5::get_in_tkt_with_password($krbclient,   my $krbreturn  = &Authen::Krb5::get_in_tkt_with_password($krbclient,
  $krbserver,   $krbserver,
  $password,   $password,
  $credentials);   $credentials);
  $validated = ($krbreturn == 1);   $validated = ($krbreturn == 1);
     }      } else {
     else {  
  $validated = 0;   $validated = 0;
     }      }
  }   } elsif ($howpwd eq "localauth") { 
  elsif ($howpwd eq "localauth") {   
     #  Authenticate via installation specific authentcation method:      #  Authenticate via installation specific authentcation method:
     $validated = &localauth::localauth($user,       $validated = &localauth::localauth($user, 
        $password,          $password, 
        $contentpwd);         $contentpwd);
  }   } else { # Unrecognized auth is also bad.
  else { # Unrecognized auth is also bad.  
     $validated = 0;      $validated = 0;
  }   }
     } else {      } else {
Line 4056  sub validate_user { Line 5562  sub validate_user {
     #      #
   
     unless ($validated != -3.14159) {      unless ($validated != -3.14159) {
  die "ValidateUser - failed to set the value of validated";   #  I >really really< want to know if this happens.
    #  since it indicates that user authentication is badly
    #  broken in some code path.
           #
    die "ValidateUser - failed to set the value of validated $domain, $user $password";
     }      }
     return $validated;      return $validated;
 }  }
Line 4082  sub addline { Line 5592  sub addline {
     return $found;      return $found;
 }  }
   
 sub getchat {  sub get_chat {
     my ($cdom,$cname,$udom,$uname)=@_;      my ($cdom,$cname,$udom,$uname)=@_;
     my %hash;      my %hash;
     my $proname=&propath($cdom,$cname);      my $proname=&propath($cdom,$cname);
Line 4107  sub getchat { Line 5617  sub getchat {
     return (@participants,@entries);      return (@participants,@entries);
 }  }
   
 sub chatadd {  sub chat_add {
     my ($cdom,$cname,$newchat)=@_;      my ($cdom,$cname,$newchat)=@_;
     my %hash;      my %hash;
     my $proname=&propath($cdom,$cname);      my $proname=&propath($cdom,$cname);
Line 4228  sub thisversion { Line 5738  sub thisversion {
 sub subscribe {  sub subscribe {
     my ($userinput,$clientip)=@_;      my ($userinput,$clientip)=@_;
     my $result;      my $result;
     my ($cmd,$fname)=split(/:/,$userinput);      my ($cmd,$fname)=split(/:/,$userinput,2);
     my $ownership=&ishome($fname);      my $ownership=&ishome($fname);
     if ($ownership eq 'owner') {      if ($ownership eq 'owner') {
 # explitly asking for the current version?  # explitly asking for the current version?
Line 4272  sub subscribe { Line 5782  sub subscribe {
     }      }
     return $result;      return $result;
 }  }
   #  Change the passwd of a unix user.  The caller must have
   #  first verified that the user is a loncapa user.
   #
   # Parameters:
   #    user      - Unix user name to change.
   #    pass      - New password for the user.
   # Returns:
   #    ok    - if success
   #    other - Some meaningfule error message string.
   # NOTE:
   #    invokes a setuid script to change the passwd.
   sub change_unix_password {
       my ($user, $pass) = @_;
   
       &Debug("change_unix_password");
       my $execdir=$perlvar{'lonDaemons'};
       &Debug("Opening lcpasswd pipeline");
       my $pf = IO::File->new("|$execdir/lcpasswd > "
      ."$perlvar{'lonDaemons'}"
      ."/logs/lcpasswd.log");
       print $pf "$user\n$pass\n$pass\n";
       close $pf;
       my $err = $?;
       return ($err < @passwderrors) ? $passwderrors[$err] : 
    "pwchange_falure - unknown error";
   
       
   }
   
   
 sub make_passwd_file {  sub make_passwd_file {
     my ($uname, $umode,$npass,$passfilename)=@_;      my ($uname, $umode,$npass,$passfilename)=@_;
Line 4279  sub make_passwd_file { Line 5818  sub make_passwd_file {
     if ($umode eq 'krb4' or $umode eq 'krb5') {      if ($umode eq 'krb4' or $umode eq 'krb5') {
  {   {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
     print $pf "$umode:$npass\n";      if ($pf) {
    print $pf "$umode:$npass\n";
       } else {
    $result = "pass_file_failed_error";
       }
  }   }
     } elsif ($umode eq 'internal') {      } elsif ($umode eq 'internal') {
  my $salt=time;   my $salt=time;
Line 4288  sub make_passwd_file { Line 5831  sub make_passwd_file {
  {   {
     &Debug("Creating internal auth");      &Debug("Creating internal auth");
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
     print $pf "internal:$ncpass\n";       if($pf) {
    print $pf "internal:$ncpass\n"; 
       } else {
    $result = "pass_file_failed_error";
       }
  }   }
     } elsif ($umode eq 'localauth') {      } elsif ($umode eq 'localauth') {
  {   {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
     print $pf "localauth:$npass\n";      if($pf) {
    print $pf "localauth:$npass\n";
       } else {
    $result = "pass_file_failed_error";
       }
  }   }
     } elsif ($umode eq 'unix') {      } elsif ($umode eq 'unix') {
  {   {
Line 4308  sub make_passwd_file { Line 5859  sub make_passwd_file {
     }      }
   
     my $execpath       ="$perlvar{'lonDaemons'}/"."lcuseradd";      my $execpath       ="$perlvar{'lonDaemons'}/"."lcuseradd";
     my $lc_error_file  = "/tmp/lcuseradd".$$.".status";  
       my $lc_error_file  = $execdir."/tmp/lcuseradd".$$.".status";
     {      {
  &Debug("Executing external: ".$execpath);   &Debug("Executing external: ".$execpath);
  &Debug("user  = ".$uname.", Password =". $npass);   &Debug("user  = ".$uname.", Password =". $npass);
Line 4318  sub make_passwd_file { Line 5870  sub make_passwd_file {
  print $se "$npass\n";   print $se "$npass\n";
  print $se "$lc_error_file\n"; # Status -> unique file.   print $se "$lc_error_file\n"; # Status -> unique file.
     }      }
     my $error = IO::File->new("< $lc_error_file");      if (-r $lc_error_file) {
     my $useraddok = <$error>;   &Debug("Opening error file: $lc_error_file");
     $error->close;   my $error = IO::File->new("< $lc_error_file");
     unlink($lc_error_file);   my $useraddok = <$error>;
    $error->close;
     chomp $useraddok;   unlink($lc_error_file);
   
     if($useraddok > 0) {   chomp $useraddok;
  my $error_text = &lcuseraddstrerror($useraddok);  
  &logthis("Failed lcuseradd: $error_text");   if($useraddok > 0) {
  $result = "lcuseradd_failed:$error_text\n";      my $error_text = &lcuseraddstrerror($useraddok);
     }      &logthis("Failed lcuseradd: $error_text");
     else {      $result = "lcuseradd_failed:$error_text\n";
  my $pf = IO::File->new(">$passfilename");   }  else {
  print $pf "unix:\n";      my $pf = IO::File->new(">$passfilename");
       if($pf) {
    print $pf "unix:\n";
       } else {
    $result = "pass_file_failed_error";
       }
    }
       }  else {
    &Debug("Could not locate lcuseradd error: $lc_error_file");
    $result="bug_lcuseradd_no_output_file";
     }      }
  }   }
     } elsif ($umode eq 'none') {      } elsif ($umode eq 'none') {
  {   {
     my $pf = IO::File->new("> $passfilename");      my $pf = IO::File->new("> $passfilename");
     print $pf "none:\n";      if($pf) {
    print $pf "none:\n";
       } else {
    $result = "pass_file_failed_error";
       }
  }   }
     } else {      } else {
  $result="auth_mode_error\n";   $result="auth_mode_error\n";
Line 4346  sub make_passwd_file { Line 5911  sub make_passwd_file {
     return $result;      return $result;
 }  }
   
   sub convert_photo {
       my ($start,$dest)=@_;
       system("convert $start $dest");
   }
   
 sub sethost {  sub sethost {
     my ($remotereq) = @_;      my ($remotereq) = @_;
     my (undef,$hostid)=split(/:/,$remotereq);      my (undef,$hostid)=split(/:/,$remotereq);
Line 4666  Place in B<logs/lond.log> Line 6236  Place in B<logs/lond.log>
   
 stores hash in namespace  stores hash in namespace
   
 =item rolesput  =item rolesputy
   
 put a role into a user's environment  put a role into a user's environment
   
Removed from v.1.223  
changed lines
  Added in v.1.303

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