Diff for /loncom/lond between versions 1.250 and 1.289

version 1.250, 2004/09/07 14:28:30 version 1.289, 2005/06/27 22:32:37
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 LONCAPA::ConfigFileEdit;  use LONCAPA::ConfigFileEdit;
 use LONCAPA::lonlocal;  use LONCAPA::lonlocal;
Line 64  my $currentdomainid; Line 65  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 112  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 177  sub ResetStatistics { Line 177  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 186  sub ResetStatistics { Line 185  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 {
Line 331  sub InsecureConnection { Line 330  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 438  sub CopyFile { Line 472  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 1013  sub tie_user_hash { Line 1019  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 1030  sub tie_user_hash { Line 1036  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 1051  sub tie_user_hash { Line 1101  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 1079  sub ping_handler { Line 1128  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 1134  sub establish_key_handler { Line 1182  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 1169  sub load_handler { Line 1216  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 1199  sub user_load_handler { Line 1246  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 1235  sub user_authorization_type { Line 1282  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 1256  sub user_authorization_type { Line 1305  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 1299  sub push_file_handler { Line 1347  sub push_file_handler {
 # Side Effects:  # Side Effects:
 #   The reply is written to  $client.  #   The reply is written to  $client.
 #  #
   
 sub du_handler {  sub du_handler {
     my ($cmd, $ududir, $client) = @_;      my ($cmd, $ududir, $client) = @_;
       my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
       my $userinput = "$cmd:$ududir";
   
     if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {      if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {
  &Failure($client,"refused\n","$cmd:$ududir");   &Failure($client,"refused\n","$cmd:$ududir");
  return 1;   return 1;
Line 1314  sub du_handler { Line 1364  sub du_handler {
     #      #
     if (-d $ududir) {      if (-d $ududir) {
  #  And as Shakespeare would say to make   #  And as Shakespeare would say to make
  #  assurance double sure, quote the $ududir   #  assurance double sure, 
  #  This is in case someone manages to first   # use execute_command to ensure that the command is not executed in
  #  e.g. fabricate a valid directory with a ';'   # a shell that can screw us up.
  #  in it.  Quoting the dir will help  
  #  keep $ududir completely interpreted as a    my $duout = execute_command("du -ks $ududir");
  #  directory.  
  #   
  my $duout = `du -ks "$ududir" 2>/dev/null`;  
  $duout=~s/[^\d]//g; #preserve only the numbers   $duout=~s/[^\d]//g; #preserve only the numbers
  &Reply($client,"$duout\n","$cmd:$ududir");   &Reply($client,"$duout\n","$cmd:$ududir");
     } else {      } else {
  &Failure($client, "bad_directory:$ududir","$cmd:$ududir");   
    &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); 
   
     }      }
     return 1;      return 1;
 }  }
 &register_handler("du", \&du_handler, 0, 1, 0);  &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  #   ls  - list the contents of a directory.  For each file in the
 #    selected directory the filename followed by the full output of  #    selected directory the filename followed by the full output of
Line 1349  sub du_handler { Line 1400  sub du_handler {
 #   The reply is written to  $client.  #   The reply is written to  $client.
 #  #
 sub ls_handler {  sub ls_handler {
       # obsoleted by ls2_handler
     my ($cmd, $ulsdir, $client) = @_;      my ($cmd, $ulsdir, $client) = @_;
   
     my $userinput = "$cmd:$ulsdir";      my $userinput = "$cmd:$ulsdir";
Line 1395  sub ls_handler { Line 1447  sub ls_handler {
 }  }
 &register_handler("ls", \&ls_handler, 0, 1, 0);  &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, $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;
                               }
                           }
                       }
                       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 1427  sub reinit_process_handler { Line 1542  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 1469  sub edit_table_handler { Line 1583  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 1525  sub authenticate_handler { Line 1638  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 1589  sub change_password_handler { Line 1701  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 1617  sub change_password_handler { Line 1719  sub change_password_handler {
   
     return 1;      return 1;
 }  }
 register_handler("passwd", \&change_password_handler, 1, 1, 0);  &register_handler("passwd", \&change_password_handler, 1, 1, 0);
   
   
 #  #
 #   Create a new user.  User in this case means a lon-capa user.  #   Create a new user.  User in this case means a lon-capa user.
Line 1657  sub add_user_handler { Line 1758  sub add_user_handler {
  if (-e $passfilename) {   if (-e $passfilename) {
     &Failure( $client, "already_exists\n", $userinput);      &Failure( $client, "already_exists\n", $userinput);
  } else {   } else {
     my @fpparts=split(/\//,$passfilename);  
     my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2];  
     my $fperror='';      my $fperror='';
     for (my $i=3;$i<= ($#fpparts-1);$i++) {      if (!&mkpath($passfilename)) {
  $fpnow.='/'.$fpparts[$i];    $fperror="error: ".($!+0)." mkdir failed while attempting "
  unless (-e $fpnow) {      ."makeuser";
     &logthis("mkdir $fpnow");  
     unless (mkdir($fpnow,0777)) {  
  $fperror="error: ".($!+0)." mkdir failed while attempting "  
     ."makeuser";  
     }  
  }  
     }      }
     unless ($fperror) {      unless ($fperror) {
  my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);   my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
Line 1709  sub add_user_handler { Line 1802  sub add_user_handler {
 # Implicit inputs:  # Implicit inputs:
 #    The authentication systems describe above have their own forms of implicit  #    The authentication systems describe above have their own forms of implicit
 #    input into the authentication process that are described above.  #    input into the authentication process that are described above.
   # NOTE:
   #   This is also used to change the authentication credential values (e.g. passwd).
   #   
 #  #
 sub change_authentication_handler {  sub change_authentication_handler {
   
Line 1725  sub change_authentication_handler { Line 1821  sub change_authentication_handler {
  chomp($npass);   chomp($npass);
   
  $npass=&unescape($npass);   $npass=&unescape($npass);
    my $oldauth = &get_auth_type($udom, $uname); # Get old auth info.
  my $passfilename = &password_path($udom, $uname);   my $passfilename = &password_path($udom, $uname);
  if ($passfilename) { # Not allowed to create a new user!!   if ($passfilename) { # Not allowed to create a new user!!
     my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);      # If just changing the unix passwd. need to arrange to run
     &Reply($client, $result, $userinput);      # passwd since otherwise make_passwd_file will run
       # lcuseradd which fails if an account already exists
       # (to prevent an unscrupulous LONCAPA admin from stealing
       # an existing account by overwriting it as a LonCAPA account).
   
       if(($oldauth =~/^unix/) && ($umode eq "unix")) {
    my $result = &change_unix_password($uname, $npass);
    &logthis("Result of password change for $uname: ".$result);
    if ($result eq "ok") {
       &Reply($client, "$result\n")
    } 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);
       }
          
   
  } else {          } else {       
     &Failure($client, "non_authorized", $userinput); # Fail the user now.      &Failure($client, "non_authorized\n", $userinput); # Fail the user now.
  }   }
     }      }
     return 1;      return 1;
Line 1883  sub fetch_user_file_handler { Line 2013  sub fetch_user_file_handler {
  # Note that any regular files in the way of this path are   # Note that any regular files in the way of this path are
  # wiped out to deal with some earlier folly of mine.   # wiped out to deal with some earlier folly of mine.
   
  my $path = $udir;   if (!&mkpath($udir.'/'.$ufile)) {
  if ($ufile =~m|(.+)/([^/]+)$|) {      &Failure($client, "unable_to_create\n", $userinput);    
     my @parts=split('/',$1);  
     foreach my $part (@parts) {  
  $path .= '/'.$part;  
  if( -f $path) {  
     unlink($path);  
  }  
  if ((-e $path)!=1) {  
     mkdir($path,0770);  
  }  
     }  
  }   }
   
   
  my $destname=$udir.'/'.$ufile;   my $destname=$udir.'/'.$ufile;
  my $transname=$udir.'/'.$ufile.'.in.transit';   my $transname=$udir.'/'.$ufile.'.in.transit';
  my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;   my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
Line 1941  sub fetch_user_file_handler { Line 2060  sub fetch_user_file_handler {
 #  #
 # Returns:  # Returns:
 #    1    - Continue processing.  #    1    - Continue processing.
   
 sub remove_user_file_handler {  sub remove_user_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
Line 1957  sub remove_user_file_handler { Line 2075  sub remove_user_file_handler {
  if (-e $udir) {   if (-e $udir) {
     my $file=$udir.'/userfiles/'.$ufile;      my $file=$udir.'/userfiles/'.$ufile;
     if (-e $file) {      if (-e $file) {
    #
    #   If the file is a regular file unlink is fine...
    #   However it's possible the client wants a dir.
    #   removed, in which case rmdir is more approprate:
    #
         if (-f $file){          if (-f $file){
     unlink($file);      unlink($file);
  } elsif(-d $file) {   } elsif(-d $file) {
     rmdir($file);      rmdir($file);
  }   }
  if (-e $file) {   if (-e $file) {
       #  File is still there after we deleted it ?!?
   
     &Failure($client, "failed\n", "$cmd:$tail");      &Failure($client, "failed\n", "$cmd:$tail");
  } else {   } else {
     &Reply($client, "ok\n", "$cmd:$tail");      &Reply($client, "ok\n", "$cmd:$tail");
Line 1987  sub remove_user_file_handler { Line 2112  sub remove_user_file_handler {
 #  #
 # Returns:  # Returns:
 #    1    - Continue processing.  #    1    - Continue processing.
   
 sub mkdir_user_file_handler {  sub mkdir_user_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
Line 2001  sub mkdir_user_file_handler { Line 2125  sub mkdir_user_file_handler {
     } else {      } else {
  my $udir = &propath($udom,$uname);   my $udir = &propath($udom,$uname);
  if (-e $udir) {   if (-e $udir) {
     my $newdir=$udir.'/userfiles/'.$ufile;      my $newdir=$udir.'/userfiles/'.$ufile.'/';
     if (!-e $newdir) {      if (!&mkpath($newdir)) {
  mkdir($newdir);   &Failure($client, "failed\n", "$cmd:$tail");
  if (!-e $newdir) {  
     &Failure($client, "failed\n", "$cmd:$tail");  
  } else {  
     &Reply($client, "ok\n", "$cmd:$tail");  
  }  
     } else {  
  &Failure($client, "not_found\n", "$cmd:$tail");  
     }      }
       &Reply($client, "ok\n", "$cmd:$tail");
  } else {   } else {
     &Failure($client, "not_home\n", "$cmd:$tail");      &Failure($client, "not_home\n", "$cmd:$tail");
  }   }
Line 2029  sub mkdir_user_file_handler { Line 2147  sub mkdir_user_file_handler {
 #  #
 # Returns:  # Returns:
 #    1    - Continue processing.  #    1    - Continue processing.
   
 sub rename_user_file_handler {  sub rename_user_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
Line 2063  sub rename_user_file_handler { Line 2180  sub rename_user_file_handler {
 }  }
 &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);  &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);
   
   
 #  #
 #  Authenticate access to a user file by checking the user's   #  Authenticate access to a user file by checking that the token the user's 
 #  session token(?)  #  passed also exists in their session file
 #  #
 # Parameters:  # Parameters:
 #   cmd      - The request keyword that dispatched to tus.  #   cmd      - The request keyword that dispatched to tus.
Line 2074  sub rename_user_file_handler { Line 2190  sub rename_user_file_handler {
 #   client   - Filehandle open on the client.  #   client   - Filehandle open on the client.
 # Return:  # Return:
 #    1.  #    1.
   
 sub token_auth_user_file_handler {  sub token_auth_user_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
     my ($fname, $session) = split(/:/, $tail);      my ($fname, $session) = split(/:/, $tail);
           
     chomp($session);      chomp($session);
     my $reply='non_auth';      my $reply="non_auth\n";
     if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.      if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
      $session.'.id')) {       $session.'.id')) {
  while (my $line=<ENVIN>) {   while (my $line=<ENVIN>) {
     if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }      if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; }
  }   }
  close(ENVIN);   close(ENVIN);
  &Reply($client, $reply);   &Reply($client, $reply, "$cmd:$tail");
     } else {      } else {
  &Failure($client, "invalid_token\n", "$cmd:$tail");   &Failure($client, "invalid_token\n", "$cmd:$tail");
     }      }
     return 1;      return 1;
   
 }  }
   
 &register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);  &register_handler("tokenauthuserfile", \&token_auth_user_file_handler, 0,1,0);
   
   
 #  #
 #   Unsubscribe from a resource.  #   Unsubscribe from a resource.
 #  #
Line 2127  sub unsubscribe_handler { Line 2240  sub unsubscribe_handler {
     return 1;      return 1;
 }  }
 &register_handler("unsub", \&unsubscribe_handler, 0, 1, 0);  &register_handler("unsub", \&unsubscribe_handler, 0, 1, 0);
   
 #   Subscribe to a resource  #   Subscribe to a resource
 #  #
 # Parameters:  # Parameters:
Line 2205  sub activity_log_handler { Line 2319  sub activity_log_handler {
   
     return 1;      return 1;
 }  }
 register_handler("log", \&activity_log_handler, 0, 1, 0);  &register_handler("log", \&activity_log_handler, 0, 1, 0);
   
 #  #
 #   Put a namespace entry in a user profile hash.  #   Put a namespace entry in a user profile hash.
Line 2256  sub put_user_profile_entry { Line 2370  sub put_user_profile_entry {
 }  }
 &register_handler("put", \&put_user_profile_entry, 0, 1, 0);  &register_handler("put", \&put_user_profile_entry, 0, 1, 0);
   
   #   Put a piece of new data in hash, returns error if entry already 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.
   #
   sub newput_user_profile_entry {
       my ($cmd, $tail, $client)  = @_;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$what) =split(/:/,$tail,4);
       if ($namespace eq 'roles') {
           &Failure( $client, "refused\n", $userinput);
    return 1;
       }
   
       chomp($what);
   
       my $hashref = &tie_user_hash($udom, $uname, $namespace,
    &GDBM_WRCREAT(),"N",$what);
       if(!$hashref) {
    &Failure( $client, "error: ".($!)." tie(GDBM) Failed ".
     "while attempting put\n", $userinput);
    return 1;
       }
   
       my @pairs=split(/\&/,$what);
       foreach my $pair (@pairs) {
    my ($key,$value)=split(/=/,$pair);
    if (exists($hashref->{$key})) {
       &Failure($client, "key_exists: ".$key."\n",$userinput);
       return 1;
    }
       }
   
       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 put\n", 
    $userinput);
       }
       return 1;
   }
   &register_handler("newput", \&newput_user_profile_entry, 0, 1, 0);
   
 #   # 
 #   Increment a profile entry in the user history file.  #   Increment a profile entry in the user history file.
 #   The history contains keyword value pairs.  In this case,  #   The history contains keyword value pairs.  In this case,
Line 2286  sub increment_user_value_handler { Line 2455  sub increment_user_value_handler {
     my @pairs=split(/\&/,$what);      my @pairs=split(/\&/,$what);
     foreach my $pair (@pairs) {      foreach my $pair (@pairs) {
  my ($key,$value)=split(/=/,$pair);   my ($key,$value)=split(/=/,$pair);
                   $value = &unescape($value);
  # We could check that we have a number...   # We could check that we have a number...
  if (! defined($value) || $value eq '') {   if (! defined($value) || $value eq '') {
     $value = 1;      $value = 1;
  }   }
  $hashref->{$key}+=$value;   $hashref->{$key}+=$value;
                   if ($namespace eq 'nohist_resourcetracker') {
                       if ($hashref->{$key} < 0) {
                           $hashref->{$key} = 0;
                       }
                   }
     }      }
     if (untie(%$hashref)) {      if (untie(%$hashref)) {
  &Reply( $client, "ok\n", $userinput);   &Reply( $client, "ok\n", $userinput);
Line 2310  sub increment_user_value_handler { Line 2485  sub increment_user_value_handler {
 }  }
 &register_handler("inc", \&increment_user_value_handler, 0, 1, 0);  &register_handler("inc", \&increment_user_value_handler, 0, 1, 0);
   
   
 #  #
 #   Put a new role for a user.  Roles are LonCAPA's packaging of permissions.  #   Put a new role for a user.  Roles are LonCAPA's packaging of permissions.
 #   Each 'role' a user has implies a set of permissions.  Adding a new role  #   Each 'role' a user has implies a set of permissions.  Adding a new role
Line 2350  sub roles_put_handler { Line 2524  sub roles_put_handler {
     #  is done on close this improves the chances the log will be an un-      #  is done on close this improves the chances the log will be an un-
     #  corrupted ordered thing.      #  corrupted ordered thing.
     if ($hashref) {      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);   my @pairs=split(/\&/,$what);
  foreach my $pair (@pairs) {   foreach my $pair (@pairs) {
     my ($key,$value)=split(/=/,$pair);      my ($key,$value)=split(/=/,$pair);
     &manage_permissions($key, $udom, $uname,      &manage_permissions($key, $udom, $uname,
        &get_auth_type( $udom, $uname));         $auth_type);
     $hashref->{$key}=$value;      $hashref->{$key}=$value;
  }   }
  if (untie($hashref)) {   if (untie($hashref)) {
Line 2449  sub get_profile_entry { Line 2626  sub get_profile_entry {
         
     my ($udom,$uname,$namespace,$what) = split(/:/,$tail);      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
     chomp($what);      chomp($what);
     my $hashref = &tie_user_hash($udom, $uname, $namespace,  
  &GDBM_READER());      my $replystring = read_profile($udom, $uname, $namespace, $what);
     if ($hashref) {      my ($first) = split(/:/,$replystring);
         my @queries=split(/\&/,$what);      if($first ne "error") {
         my $qresult='';   &Reply($client, "$replystring\n", $userinput);
   
  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)) {  
     &Reply($client, "$qresult\n", $userinput);  
  } else {  
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".  
     "while attempting get\n", $userinput);  
  }  
     } else {      } else {
  if ($!+0 == 2) {               # +0 coerces errno -> number 2 is ENOENT   &Failure($client, $replystring." while attempting get\n", $userinput);
     &Failure($client, "error:No such file or ".  
     "GDBM reported bad block error\n", $userinput);  
  } else {                        # Some other undifferentiated err.  
     &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".  
     "while attempting get\n", $userinput);  
  }  
     }      }
     return 1;      return 1;
   
   
 }  }
 &register_handler("get", \&get_profile_entry, 0,1,0);  &register_handler("get", \&get_profile_entry, 0,1,0);
   
Line 2504  sub get_profile_entry_encrypted { Line 2666  sub get_profile_entry_encrypted {
         
     my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);      my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);
     chomp($what);      chomp($what);
     my $hashref = &tie_user_hash($udom, $uname, $namespace,      my $qresult = read_profile($udom, $uname, $namespace, $what);
  &GDBM_READER());      my ($first) = split(/:/, $qresult);
     if ($hashref) {      if($first ne "error") {
         my @queries=split(/\&/,$what);  
         my $qresult='';   if ($cipher) {
  for (my $i=0;$i<=$#queries;$i++) {      my $cmdlength=length($qresult);
     $qresult.="$hashref->{$queries[$i]}&";      $qresult.="         ";
  }      my $encqresult='';
  if (untie(%$hashref)) {      for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
     $qresult=~s/\&$//;   $encqresult.= unpack("H16", 
     if ($cipher) {       $cipher->encrypt(substr($qresult,
  my $cmdlength=length($qresult);       $encidx,
  $qresult.="         ";       8)));
  my $encqresult='';  
  for(my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {  
     $encqresult.= unpack("H16",   
  $cipher->encrypt(substr($qresult,  
  $encidx,  
  8)));  
  }  
  &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);  
     } else {  
  &Failure( $client, "error:no_key\n", $userinput);  
     }      }
       &Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".   &Failure( $client, "error:no_key\n", $userinput);
     "while attempting eget\n", $userinput);      }
  }  
     } else {      } else {
  &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".   &Failure($client, "$qresult while attempting eget\n", $userinput);
  "while attempting eget\n", $userinput);  
     }      }
           
     return 1;      return 1;
 }  }
 &register_handler("eget", \&GetProfileEntryEncrypted, 0, 1, 0);  &register_handler("eget", \&get_profile_entry_encrypted, 0, 1, 0);
   
 #  #
 #   Deletes a key in a user profile database.  #   Deletes a key in a user profile database.
 #     #   
Line 2558  sub get_profile_entry_encrypted { Line 2711  sub get_profile_entry_encrypted {
 #     0   - Exit server.  #     0   - Exit server.
 #  #
 #  #
   
 sub delete_profile_entry {  sub delete_profile_entry {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
Line 2587  sub delete_profile_entry { Line 2739  sub delete_profile_entry {
     return 1;      return 1;
 }  }
 &register_handler("del", \&delete_profile_entry, 0, 1, 0);  &register_handler("del", \&delete_profile_entry, 0, 1, 0);
   
 #  #
 #  List the set of keys that are defined in a profile database file.  #  List the set of keys that are defined in a profile database file.
 #  A successful reply from this will contain an & separated list of  #  A successful reply from this will contain an & separated list of
Line 2765  sub dump_with_regexp { Line 2918  sub dump_with_regexp {
   
     return 1;      return 1;
 }  }
   
 &register_handler("dump", \&dump_with_regexp, 0, 1, 0);  &register_handler("dump", \&dump_with_regexp, 0, 1, 0);
   
 #  Store a set of key=value pairs associated with a versioned name.  #  Store a set of key=value pairs associated with a versioned name.
Line 2797  sub store_handler { Line 2949  sub store_handler {
  chomp($what);   chomp($what);
  my @pairs=split(/\&/,$what);   my @pairs=split(/\&/,$what);
  my $hashref  = &tie_user_hash($udom, $uname, $namespace,   my $hashref  = &tie_user_hash($udom, $uname, $namespace,
        &GDBM_WRCREAT(), "P",         &GDBM_WRCREAT(), "S",
        "$rid:$what");         "$rid:$what");
  if ($hashref) {   if ($hashref) {
     my $now = time;      my $now = time;
Line 2831  sub store_handler { Line 2983  sub store_handler {
     return 1;      return 1;
 }  }
 &register_handler("store", \&store_handler, 0, 1, 0);  &register_handler("store", \&store_handler, 0, 1, 0);
   
 #  #
 #  Dump out all versions of a resource that has key=value pairs associated  #  Dump out all versions of a resource that has key=value pairs associated
 # with it for each version.  These resources are built up via the store  # with it for each version.  These resources are built up via the store
Line 2931  sub send_chat_handler { Line 3084  sub send_chat_handler {
     return 1;      return 1;
 }  }
 &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);  &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);
   
 #  #
 #   Retrieve the set of chat messagss from a discussion board.  #   Retrieve the set of chat messagss from a discussion board.
 #  #
Line 3066  sub reply_query_handler { Line 3220  sub reply_query_handler {
 #   $tail     - Tail of the command.  In this case consists of a colon  #   $tail     - Tail of the command.  In this case consists of a colon
 #               separated list contaning the domain to apply this to and  #               separated list contaning the domain to apply this to and
 #               an ampersand separated list of keyword=value pairs.  #               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.  #   $client   - Socket open on the client.
 # Returns:  # Returns:
 #   1    - indicating that processing should continue  #   1    - indicating that processing should continue
Line 3079  sub put_course_id_handler { Line 3241  sub put_course_id_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom, $what) = split(/:/, $tail);      my ($udom, $what) = split(/:/, $tail,2);
     chomp($what);      chomp($what);
     my $now=time;      my $now=time;
     my @pairs=split(/\&/,$what);      my @pairs=split(/\&/,$what);
Line 3087  sub put_course_id_handler { Line 3249  sub put_course_id_handler {
     my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
  foreach my $pair (@pairs) {   foreach my $pair (@pairs) {
     my ($key,$value)=split(/=/,$pair);              my ($key,$courseinfo) = split(/=/,$pair,2);
     $hashref->{$key}=$value.':'.$now;              $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;
  }   }
  if (untie(%$hashref)) {   if (untie(%$hashref)) {
     &Reply($client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
  } else {   } else {
     &Failure( $client, "error: ".($!+0)      &Failure($client, "error: ".($!+0)
      ." untie(GDBM) Failed ".       ." untie(GDBM) Failed ".
      "while attempting courseidput\n", $userinput);       "while attempting courseidput\n", $userinput);
  }   }
     } else {      } else {
  &Failure( $client, "error: ".($!+0)   &Failure($client, "error: ".($!+0)
  ." tie(GDBM) Failed ".   ." tie(GDBM) Failed ".
  "while attempting courseidput\n", $userinput);   "while attempting courseidput\n", $userinput);
     }      }
       
   
     return 1;      return 1;
 }  }
Line 3125  sub put_course_id_handler { Line 3304  sub put_course_id_handler {
 #                 description - regular expression that is used to filter  #                 description - regular expression that is used to filter
 #                            the dump.  Only keywords matching this regexp  #                            the dump.  Only keywords matching this regexp
 #                            will be used.  #                            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.  #     $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1     - Continue processing.  #    1     - Continue processing.
Line 3135  sub dump_course_id_handler { Line 3323  sub dump_course_id_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$since,$description) =split(/:/,$tail);      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter) =split(/:/,$tail);
     if (defined($description)) {      if (defined($description)) {
  $description=&unescape($description);   $description=&unescape($description);
     } else {      } else {
  $description='.';   $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; }      unless (defined($since)) { $since=0; }
     my $qresult='';      my $qresult='';
     my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
     my ($descr,$lasttime,$inst_code);      my ($descr,$lasttime,$inst_code,$owner);
     if ($value =~ m/^([^\:]*):([^\:]*):(\d+)$/) {              my @courseitems = split(/:/,$value);
  ($descr,$inst_code,$lasttime)=($1,$2,$3);              $lasttime = pop(@courseitems);
     } else {      ($descr,$inst_code,$owner)=@courseitems;
  ($descr,$lasttime) = split(/\:/,$value);  
     }  
     if ($lasttime<$since) { next; }      if ($lasttime<$since) { next; }
     if ($description eq '.') {              my $match = 1;
  $qresult.=$key.'='.$descr.':'.$inst_code.'&';      unless ($description eq '.') {
     } else {   my $unescapeDescr = &unescape($descr);
  my $unescapeVal = &unescape($descr);   unless (eval('$unescapeDescr=~/\Q$description\E/i')) {
  if (eval('$unescapeVal=~/\Q$description\E/i')) {                      $match = 0;
     $qresult.=$key.'='.$descr.':'.$inst_code.'&';  
  }   }
               }
               unless ($instcodefilter eq '.' || !defined($instcodefilter)) {
                   my $unescapeInstcode = &unescape($inst_code);
                   unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {
                       $match = 0;
                   }
     }      }
               unless ($ownerfilter eq '.' || !defined($ownerfilter)) {
                   my $unescapeOwner = &unescape($owner);
                   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.'&';
               }
  }   }
  if (untie(%$hashref)) {   if (untie(%$hashref)) {
     chop($qresult);      chop($qresult);
Line 3224  sub put_id_handler { Line 3446  sub put_id_handler {
   
     return 1;      return 1;
 }  }
   
 &register_handler("idput", \&put_id_handler, 0, 1, 0);  &register_handler("idput", \&put_id_handler, 0, 1, 0);
   
 #  #
 #  Retrieves a set of id values from the id database.  #  Retrieves a set of id values from the id database.
 #  Returns an & separated list of results, one for each requested id to the  #  Returns an & separated list of results, one for each requested id to the
Line 3274  sub get_id_handler { Line 3496  sub get_id_handler {
           
     return 1;      return 1;
 }  }
   &register_handler("idget", \&get_id_handler, 0, 1, 0);
 register_handler("idget", \&get_id_handler, 0, 1, 0);  
   
 #  #
 #  Process the tmpput command I'm not sure what this does.. Seems to  #  Process the tmpput command I'm not sure what this does.. Seems to
Line 3318  sub tmp_put_handler { Line 3539  sub tmp_put_handler {
       
 }  }
 &register_handler("tmpput", \&tmp_put_handler, 0, 1, 0);  &register_handler("tmpput", \&tmp_put_handler, 0, 1, 0);
   
 #   Processes the tmpget command.  This command returns the contents  #   Processes the tmpget command.  This command returns the contents
 #  of a temporary resource file(?) created via tmpput.  #  of a temporary resource file(?) created via tmpput.
 #  #
Line 3330  sub tmp_put_handler { Line 3552  sub tmp_put_handler {
 #    1         - Inidcating processing can continue.  #    1         - Inidcating processing can continue.
 # Side effects:  # Side effects:
 #   A reply is sent to the client.  #   A reply is sent to the client.
   
 #  #
 sub tmp_get_handler {  sub tmp_get_handler {
     my ($cmd, $id, $client) = @_;      my ($cmd, $id, $client) = @_;
Line 3353  sub tmp_get_handler { Line 3574  sub tmp_get_handler {
     return 1;      return 1;
 }  }
 &register_handler("tmpget", \&tmp_get_handler, 0, 1, 0);  &register_handler("tmpget", \&tmp_get_handler, 0, 1, 0);
   
 #  #
 #  Process the tmpdel command.  This command deletes a temp resource  #  Process the tmpdel command.  This command deletes a temp resource
 #  created by the tmpput command.  #  created by the tmpput command.
Line 3386  sub tmp_del_handler { Line 3608  sub tmp_del_handler {
   
 }  }
 &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);  &register_handler("tmpdel", \&tmp_del_handler, 0, 1, 0);
   
 #  #
 #   Processes the setannounce command.  This command  #   Processes the setannounce command.  This command
 #   creates a file named announce.txt in the top directory of  #   creates a file named announce.txt in the top directory of
Line 3424  sub set_announce_handler { Line 3647  sub set_announce_handler {
     return 1;      return 1;
 }  }
 &register_handler("setannounce", \&set_announce_handler, 0, 1, 0);  &register_handler("setannounce", \&set_announce_handler, 0, 1, 0);
   
 #  #
 #  Return the version of the daemon.  This can be used to determine  #  Return the version of the daemon.  This can be used to determine
 #  the compatibility of cross version installations or, alternatively to  #  the compatibility of cross version installations or, alternatively to
Line 3448  sub get_version_handler { Line 3672  sub get_version_handler {
     return 1;      return 1;
 }  }
 &register_handler("version", \&get_version_handler, 0, 1, 0);  &register_handler("version", \&get_version_handler, 0, 1, 0);
   
 #  Set the current host and domain.  This is used to support  #  Set the current host and domain.  This is used to support
 #  multihomed systems.  Each IP of the system, or even separate daemons  #  multihomed systems.  Each IP of the system, or even separate daemons
 #  on the same IP can be treated as handling a separate lonCAPA virtual  #  on the same IP can be treated as handling a separate lonCAPA virtual
Line 3584  sub validate_course_owner_handler { Line 3809  sub validate_course_owner_handler {
     return 1;      return 1;
 }  }
 &register_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0);  &register_handler("autonewcourse", \&validate_course_owner_handler, 0, 1, 0);
   
 #  #
 #   Validate a course section in the official schedule of classes  #   Validate a course section in the official schedule of classes
 #   from the institutions point of view (part of autoenrollment).  #   from the institutions point of view (part of autoenrollment).
Line 3664  sub create_auto_enroll_password_handler Line 3890  sub create_auto_enroll_password_handler
 #  #
 # Returns:  # Returns:
 #   1     - Continue processing.  #   1     - Continue processing.
   
 sub retrieve_auto_file_handler {  sub retrieve_auto_file_handler {
     my ($cmd, $tail, $client)    = @_;      my ($cmd, $tail, $client)    = @_;
     my $userinput                = "cmd:$tail";      my $userinput                = "cmd:$tail";
Line 3749  sub get_institutional_code_format_handle Line 3974  sub get_institutional_code_format_handle
           
     return 1;      return 1;
 }  }
   &register_handler("autoinstcodeformat",
 &register_handler("autoinstcodeformat", \&get_institutional_code_format_handler,    \&get_institutional_code_format_handler,0,1,0);
   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; }
    }
       }
       return 1;
   }
   
 #---------------------------------------------------------------  #---------------------------------------------------------------
 #  #
 #   Getting, decoding and dispatching requests:  #   Getting, decoding and dispatching requests:
 #  #
   
 #  #
 #   Get a Request:  #   Get a Request:
 #   Gets a Request message from the client.  The transaction  #   Gets a Request message from the client.  The transaction
Line 3799  sub process_request { Line 4071  sub process_request {
  $userinput = decipher($userinput);   $userinput = decipher($userinput);
  $wasenc=1;   $wasenc=1;
  if(!$userinput) { # Cipher not defined.   if(!$userinput) { # Cipher not defined.
     &Failure($client, "error: Encrypted data without negotated key");      &Failure($client, "error: Encrypted data without negotated key\n");
     return 0;      return 0;
  }   }
     }      }
Line 3869  sub process_request { Line 4141  sub process_request {
   
     }          }    
   
 #------------------- Commands not yet in spearate handlers. --------------      print $client "unknown_cmd\n";
   
 #------------------------------- is auto-enrollment enabled?  
     if ($userinput =~/^autorun/) {  
  if (isClient) {  
     my ($cmd,$cdom) = split(/:/,$userinput);  
     my $outcome = &localenroll::run($cdom);  
     print $client "$outcome\n";  
  } else {  
     print $client "0\n";  
  }  
 #------------------------------- get official sections (for auto-enrollment).  
     } elsif ($userinput =~/^autogetsections/) {  
  if (isClient) {  
     my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);  
     my @secs = &localenroll::get_sections($coursecode,$cdom);  
     my $seclist = &escape(join(':',@secs));  
     print $client "$seclist\n";  
  } else {  
     print $client "refused\n";  
  }  
 #----------------------- validate owner of new course section (for auto-enrollment).  
     } elsif ($userinput =~/^autonewcourse/) {  
  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 {  
     print $client "refused\n";  
  }  
 #-------------- validate course section in schedule of classes (for auto-enrollment).  
     } elsif ($userinput =~/^autovalidatecourse/) {  
  if (isClient) {  
     my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);  
     my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);  
     print $client "$outcome\n";  
  } else {  
     print $client "refused\n";  
  }  
 #--------------------------- create password for new user (for auto-enrollment).  
     } elsif ($userinput =~/^autocreatepassword/) {  
  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).  
     } elsif ($userinput =~/^autoretrieve/) {  
  if (isClient) {  
     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).  
     } elsif ($userinput =~/^autoinstcodeformat/) {  
  if (isClient) {  
     my $reply;  
     my($cmd,$cdom,$course) = split(/:/,$userinput);  
     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);  
  print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n";  
     }  
  } else {  
     print $client "refused\n";  
  }  
 # ------------------------------------------------------------- unknown command  
   
     } else {  
  # unknown command  
  print $client "unknown_cmd\n";  
     }  
 # -------------------------------------------------------------------- complete  # -------------------------------------------------------------------- complete
     Debug("process_request - returning 1");      Debug("process_request - returning 1");
     return 1;      return 1;
Line 4238  sub ReadHostTable { Line 4403  sub ReadHostTable {
     my $myloncapaname = $perlvar{'lonHostID'};      my $myloncapaname = $perlvar{'lonHostID'};
     Debug("My loncapa name is : $myloncapaname");      Debug("My loncapa name is : $myloncapaname");
     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 = gethostbyname($name);
       if (length($ip) ne 4) {
    &logthis("Skipping host $id name $name no IP $ip found\n");
    next;
       }
       $ip=inet_ntoa($ip);
     $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 4380  sub Reply { Line 4551  sub Reply {
     Debug("Request was $request  Reply was $reply");      Debug("Request was $request  Reply was $reply");
   
     $Transactions++;      $Transactions++;
   
   
 }  }
   
   
Line 4424  sub logstatus { Line 4593  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 4609  $SIG{USR2} = \&UpdateHosts; Line 4778  $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 4655  sub make_new_child { Line 4826  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 4686  sub make_new_child { Line 4855  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();   if ($dist ne 'fedora4') {
       &Authen::Krb5::init_ets();
    }
   
  &status('Accepted connection');   &status('Accepted connection');
 # =============================================================================  # =============================================================================
Line 4696  sub make_new_child { Line 4867  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 4851  sub make_new_child { Line 5027  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 4864  sub make_new_child { Line 5067  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 manage_permissions  sub manage_permissions {
 {  
   
     my ($request, $domain, $user, $authtype) = @_;      my ($request, $domain, $user, $authtype) = @_;
   
       &Debug("manage_permissions: $request $domain $user $authtype");
   
     # See if the request is of the form /$domain/_au      # See if the request is of the form /$domain/_au
     if($request =~ /^(\/$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 4889  sub manage_permissions Line 5093  sub manage_permissions
 #  #
 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 4969  sub get_auth_type Line 5168  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') {  
     $availinfo = $contentpwd;  
  }  
   
  return "$authtype:$availinfo";  
     } else {      } else {
  Debug("Returning nouser");   Debug("Returning nouser");
  return "nouser";   return "nouser";
Line 5072  sub validate_user { Line 5266  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);
Line 5316  sub subscribe { Line 5510  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 5323  sub make_passwd_file { Line 5546  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 5332  sub make_passwd_file { Line 5559  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 5363  sub make_passwd_file { Line 5598  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");
       $result = "lcuseradd_failed:$error_text\n";
    }  else {
       my $pf = IO::File->new(">$passfilename");
       if($pf) {
    print $pf "unix:\n";
       } else {
    $result = "pass_file_failed_error";
       }
    }
     }  else {      }  else {
  my $pf = IO::File->new(">$passfilename");   &Debug("Could not locate lcuseradd error: $lc_error_file");
  print $pf "unix:\n";   $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 5390  sub make_passwd_file { Line 5639  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);

Removed from v.1.250  
changed lines
  Added in v.1.289


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