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

Diff for /loncom/lond between versions 1.344 and 1.409

version 1.344, 2006/10/13 04:23:02 version 1.409, 2008/10/07 10:08:06
Line 40  use IO::File; Line 40  use IO::File;
 use POSIX;  use POSIX;
 use Crypt::IDEA;  use Crypt::IDEA;
 use LWP::UserAgent();  use LWP::UserAgent();
   use Digest::MD5 qw(md5_hex);
 use GDBM_File;  use GDBM_File;
 use Authen::Krb4;  use Authen::Krb4;
 use Authen::Krb5;  use Authen::Krb5;
 use lib '/home/httpd/lib/perl/';  
 use localauth;  use localauth;
 use localenroll;  use localenroll;
 use localstudentphoto;  use localstudentphoto;
 use File::Copy;  use File::Copy;
 use File::Find;  use File::Find;
 use LONCAPA::ConfigFileEdit;  
 use LONCAPA::lonlocal;  use LONCAPA::lonlocal;
 use LONCAPA::lonssl;  use LONCAPA::lonssl;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
   use Apache::lonnet;
   
 my $DEBUG = 0;       # Non zero to enable debug log entries.  my $DEBUG = 0;       # Non zero to enable debug log entries.
   
Line 69  my $clientip;   # IP address of client. Line 69  my $clientip;   # IP address of client.
 my $clientname; # LonCAPA name of client.  my $clientname; # LonCAPA name of client.
   
 my $server;  my $server;
 my $thisserver; # DNS of us.  
   
 my $keymode;  my $keymode;
   
Line 85  my $tmpsnum = 0;  # Id of tmpputs. Line 84  my $tmpsnum = 0;  # Id of tmpputs.
   
 my $ConnectionType;  my $ConnectionType;
   
 my %hostid; # ID's for hosts in cluster by ip.  
 my %hostdom; # LonCAPA domain for hosts in cluster.  
 my %hostname; # DNSname -> ID's mapping.  
 my %hostip; # IPs for hosts in cluster.  
 my %hostdns; # ID's of hosts looked up by DNS name.  
   
 my %managers; # Ip -> manager names  my %managers; # Ip -> manager names
   
 my %perlvar; # Will have the apache conf defined perl vars.  my %perlvar; # Will have the apache conf defined perl vars.
Line 142  my @adderrors    = ("ok", Line 135  my @adderrors    = ("ok",
     "lcuseradd Unable to make www member of users's group",      "lcuseradd Unable to make www member of users's group",
     "lcuseradd Unable to su to root",      "lcuseradd Unable to su to root",
     "lcuseradd Unable to set password",      "lcuseradd Unable to set password",
     "lcuseradd Usrname has invalid characters",      "lcuseradd Username has invalid characters",
     "lcuseradd Password has an invalid character",      "lcuseradd Password has an invalid character",
     "lcuseradd User already exists",      "lcuseradd User already exists",
     "lcuseradd Could not add user.",      "lcuseradd Could not add user.",
Line 178  sub ResetStatistics { Line 171  sub ResetStatistics {
 #   $Socket      - Socket open on client.  #   $Socket      - Socket open on client.
 #   $initcmd     - The full text of the init command.  #   $initcmd     - The full text of the init command.
 #  #
 # Implicit inputs:  
 #    $thisserver - Our DNS name.  
 #  
 # Returns:  # Returns:
 #     IDEA session key on success.  #     IDEA session key on success.
 #     undef on failure.  #     undef on failure.
 #  #
 sub LocalConnection {  sub LocalConnection {
     my ($Socket, $initcmd) = @_;      my ($Socket, $initcmd) = @_;
     Debug("Attempting local connection: $initcmd client: $clientip me: $thisserver");      Debug("Attempting local connection: $initcmd client: $clientip");
     if($clientip ne "127.0.0.1") {      if($clientip ne "127.0.0.1") {
  &logthis('<font color="red"> LocalConnection rejecting non local: '   &logthis('<font color="red"> LocalConnection rejecting non local: '
  ."$clientip ne $thisserver </font>");   ."$clientip ne 127.0.0.1 </font>");
  close $Socket;   close $Socket;
  return undef;   return undef;
     }  else {      }  else {
Line 424  sub ReadManagerTable { Line 414  sub ReadManagerTable {
       if ($host =~ "^#") {                  # Comment line.        if ($host =~ "^#") {                  # Comment line.
          next;           next;
       }        }
       if (!defined $hostip{$host}) { # This is a non cluster member        if (!defined &Apache::lonnet::get_host_ip($host)) { # This is a non cluster member
     #  The entry is of the form:      #  The entry is of the form:
     #    cluname:hostname      #    cluname:hostname
     #  cluname - A 'cluster hostname' is needed in order to negotiate      #  cluname - A 'cluster hostname' is needed in order to negotiate
Line 442  sub ReadManagerTable { Line 432  sub ReadManagerTable {
          }           }
       } else {        } else {
          logthis('<font color="green"> existing host'." $host</font>\n");           logthis('<font color="green"> existing host'." $host</font>\n");
          $managers{$hostip{$host}} = $host;  # Use info from cluster tab if clumemeber           $managers{&Apache::lonnet::get_host_ip($host)} = $host;  # Use info from cluster tab if clumemeber
       }        }
    }     }
 }  }
Line 503  sub AdjustHostContents { Line 493  sub AdjustHostContents {
     my $adjusted;      my $adjusted;
     my $me        = $perlvar{'lonHostID'};      my $me        = $perlvar{'lonHostID'};
   
  foreach my $line (split(/\n/,$contents)) {      foreach my $line (split(/\n/,$contents)) {
  if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {   if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
     chomp($line);      chomp($line);
     my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);      my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
     if ($id eq $me) {      if ($id eq $me) {
           my $ip = gethostbyname($name);   my $ip = gethostbyname($name);
           my $ipnew = inet_ntoa($ip);   my $ipnew = inet_ntoa($ip);
          $ip = $ipnew;   $ip = $ipnew;
  #  Reconstruct the host line and append to adjusted:   #  Reconstruct the host line and append to adjusted:
   
    my $newline = "$id:$domain:$role:$name:$ip";   my $newline = "$id:$domain:$role:$name:$ip";
    if($maxcon ne "") { # Not all hosts have loncnew tuning params   if($maxcon ne "") { # Not all hosts have loncnew tuning params
      $newline .= ":$maxcon:$idleto:$mincon";      $newline .= ":$maxcon:$idleto:$mincon";
    }   }
    $adjusted .= $newline."\n";   $adjusted .= $newline."\n";
   
       } else { # Not me, pass unmodified.      } else { # Not me, pass unmodified.
    $adjusted .= $line."\n";   $adjusted .= $line."\n";
       }      }
  } else {                  # Blank or comment never re-written.   } else {                  # Blank or comment never re-written.
     $adjusted .= $line."\n"; # Pass blanks and comments as is.      $adjusted .= $line."\n"; # Pass blanks and comments as is.
  }   }
  }      }
  return $adjusted;      return $adjusted;
 }  }
 #  #
 #   InstallFile: Called to install an administrative file:  #   InstallFile: Called to install an administrative file:
Line 1006  sub ping_handler { Line 996  sub ping_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     Debug("$cmd $tail $client .. $currenthostid:");      Debug("$cmd $tail $client .. $currenthostid:");
         
     Reply( $client,"$currenthostid\n","$cmd:$tail");      Reply( $client,\$currenthostid,"$cmd:$tail");
         
     return 1;      return 1;
 }  }
Line 1032  sub ping_handler { Line 1022  sub ping_handler {
 sub pong_handler {  sub pong_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
     my $reply=&reply("ping",$clientname);      my $reply=&Apache::lonnet::reply("ping",$clientname);
     &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail");       &Reply( $replyfd, "$currenthostid:$reply\n", "$cmd:$tail"); 
     return 1;      return 1;
 }  }
Line 1076  sub establish_key_handler { Line 1066  sub establish_key_handler {
     $key=substr($key,0,32);      $key=substr($key,0,32);
     my $cipherkey=pack("H32",$key);      my $cipherkey=pack("H32",$key);
     $cipher=new IDEA $cipherkey;      $cipher=new IDEA $cipherkey;
     &Reply($replyfd, "$buildkey\n", "$cmd:$tail");       &Reply($replyfd, \$buildkey, "$cmd:$tail"); 
         
     return 1;      return 1;
   
Line 1113  sub load_handler { Line 1103  sub load_handler {
         
     my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};      my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'};
   
     &Reply( $replyfd, "$loadpercent\n", "$cmd:$tail");      &Reply( $replyfd, \$loadpercent, "$cmd:$tail");
         
     return 1;      return 1;
 }  }
Line 1142  sub load_handler { Line 1132  sub load_handler {
 sub user_load_handler {  sub user_load_handler {
     my ($cmd, $tail, $replyfd) = @_;      my ($cmd, $tail, $replyfd) = @_;
   
     my $userloadpercent=&userload();      my $userloadpercent=&Apache::lonnet::userload();
     &Reply($replyfd, "$userloadpercent\n", "$cmd:$tail");      &Reply($replyfd, \$userloadpercent, "$cmd:$tail");
           
     return 1;      return 1;
 }  }
Line 1186  sub user_authorization_type { Line 1176  sub user_authorization_type {
  } else {   } else {
             $type .= ':';              $type .= ':';
         }          }
  &Reply( $replyfd, "$type\n", $userinput);   &Reply( $replyfd, \$type, $userinput);
     }      }
       
     return 1;      return 1;
Line 1222  sub push_file_handler { Line 1212  sub push_file_handler {
  # process making the request.   # process making the request.
               
  my $reply = &PushFile($userinput);   my $reply = &PushFile($userinput);
  &Reply($client, "$reply\n", $userinput);   &Reply($client, \$reply, $userinput);
   
     } else {      } else {
  &Failure( $client, "refused\n", $userinput);   &Failure( $client, "refused\n", $userinput);
Line 1231  sub push_file_handler { Line 1221  sub push_file_handler {
 }  }
 &register_handler("pushfile", \&push_file_handler, 1, 0, 1);  &register_handler("pushfile", \&push_file_handler, 1, 0, 1);
   
   # The du_handler routine should be considered obsolete and is retained
   # for communication with legacy servers.  Please see the du2_handler.
 #  #
 #   du  - list the disk usuage of a directory recursively.   #   du  - list the disk usage of a directory recursively. 
 #      #    
 #   note: stolen code from the ls file handler  #   note: stolen code from the ls file handler
 #   under construction by Rick Banghart   #   under construction by Rick Banghart 
Line 1268  sub du_handler { Line 1260  sub du_handler {
  my $code=sub {    my $code=sub { 
     if ($_=~/\.\d+\./) { return;}       if ($_=~/\.\d+\./) { return;} 
     if ($_=~/\.meta$/) { return;}      if ($_=~/\.meta$/) { return;}
       if (-d $_)         { return;}
     $total_size+=(stat($_))[7];      $total_size+=(stat($_))[7];
  };   };
  chdir($ududir);   chdir($ududir);
  find($code,$ududir);   find($code,$ududir);
  $total_size=int($total_size/1024);   $total_size=int($total_size/1024);
  &Reply($client,"$total_size\n","$cmd:$ududir");   &Reply($client,\$total_size,"$cmd:$ududir");
     } else {      } else {
  &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir");    &Failure($client, "bad_directory:$ududir\n","$cmd:$ududir"); 
     }      }
Line 1281  sub du_handler { Line 1274  sub du_handler {
 }  }
 &register_handler("du", \&du_handler, 0, 1, 0);  &register_handler("du", \&du_handler, 0, 1, 0);
   
   # Please also see the du_handler, which is obsoleted by du2. 
   # du2_handler differs from du_handler in that required path to directory
   # provided by &propath() is prepended in the handler instead of on the 
   # client side.
   #
   #   du2  - list the disk usage of a directory recursively.
   #
   # Parameters:
   #    $cmd        - The command that dispatched us (du).
   #    $tail       - The tail of the request that invoked us.
   #                  $tail is a : separated list of the following:
   #                   - $ududir - directory path to list (before prepending)
   #                   - $getpropath = 1 if &propath() should prepend
   #                   - $uname - username to use for &propath or user dir
   #                   - $udom - domain to use for &propath or user dir
   #                   All are escaped.
   #    $client     - Socket open on the client.
   # Returns:
   #     1 - indicating that the daemon should not disconnect.
   # Side Effects:
   #   The reply is written to $client.
   #
   
   sub du2_handler {
       my ($cmd, $tail, $client) = @_;
       my ($ududir,$getpropath,$uname,$udom) = map { &unescape($_) } (split(/:/, $tail));
       my $userinput = "$cmd:$tail";
       if (($ududir=~/\.\./) || (($ududir!~m|^/home/httpd/|) && (!$getpropath))) {
           &Failure($client,"refused\n","$cmd:$tail");
           return 1;
       }
       if ($getpropath) {
           if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
               $ududir = &propath($udom,$uname).'/'.$ududir;
           } else {
               &Failure($client,"refused\n","$cmd:$tail");
               return 1;
           }
       }
       #  Since $ududir could have some nasties in it,
       #  we will require that ududir is a valid
       #  directory.  Just in case someone tries to
       #  slip us a  line like .;(cd /home/httpd rm -rf*)
       #  etc.
       #
       if (-d $ududir) {
           my $total_size=0;
           my $code=sub {
               if ($_=~/\.\d+\./) { return;}
               if ($_=~/\.meta$/) { return;}
               if (-d $_)         { return;}
               $total_size+=(stat($_))[7];
           };
           chdir($ududir);
           find($code,$ududir);
           $total_size=int($total_size/1024);
           &Reply($client,\$total_size,"$cmd:$ududir");
       } else {
           &Failure($client, "bad_directory:$ududir\n","$cmd:$tail");
       }
       return 1;
   }
   &register_handler("du2", \&du2_handler, 0, 1, 0);
   
 #  #
 # The ls_handler routine should be considered obosolete and is retained  # The ls_handler routine should be considered obsolete and is retained
 # for communication with legacy servers.  Please see the ls2_handler.  # for communication with legacy servers.  Please see the ls3_handler.
 #  #
 #   ls  - list the contents of a directory.  For each file in the  #   ls  - list the contents of a directory.  For each file in the
 #    selected directory the filename followed by the full output of  #    selected directory the filename followed by the full output of
Line 1342  sub ls_handler { Line 1399  sub ls_handler {
  $ulsout='no_such_dir';   $ulsout='no_such_dir';
     }      }
     if ($ulsout eq '') { $ulsout='empty'; }      if ($ulsout eq '') { $ulsout='empty'; }
     &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.      &Reply($client, \$ulsout, $userinput); # This supports debug logging.
           
     return 1;      return 1;
   
 }  }
 &register_handler("ls", \&ls_handler, 0, 1, 0);  &register_handler("ls", \&ls_handler, 0, 1, 0);
   
 #  # The ls2_handler routine should be considered obsolete and is retained
 # Please also see the ls_handler, which this routine obosolets.  # for communication with legacy servers.  Please see the ls3_handler.
   # Please also see the ls_handler, which was itself obsoleted by ls2.
 # ls2_handler differs from ls_handler in that it escapes its return   # ls2_handler differs from ls_handler in that it escapes its return 
 # values before concatenating them together with ':'s.  # values before concatenating them together with ':'s.
 #  #
Line 1411  sub ls2_handler { Line 1469  sub ls2_handler {
         $ulsout='no_such_dir';          $ulsout='no_such_dir';
    }     }
    if ($ulsout eq '') { $ulsout='empty'; }     if ($ulsout eq '') { $ulsout='empty'; }
    &Reply($client, "$ulsout\n", $userinput); # This supports debug logging.     &Reply($client, \$ulsout, $userinput); # This supports debug logging.
    return 1;     return 1;
 }  }
 &register_handler("ls2", \&ls2_handler, 0, 1, 0);  &register_handler("ls2", \&ls2_handler, 0, 1, 0);
   #
   #   ls3  - list the contents of a directory.  For each file in the
   #    selected directory the filename followed by the full output of
   #    the stat function is returned.  The returned info for each
   #    file are separated by ':'.  The stat fields are separated by &'s.
   # Parameters:
   #    $cmd        - The command that dispatched us (ls).
   #    $tail       - The tail of the request that invoked us.
   #                  $tail is a : separated list of the following:
   #                   - $ulsdir - directory path to list (before prepending)
   #                   - $getpropath = 1 if &propath() should prepend
   #                   - $getuserdir = 1 if path to user dir in lonUsers should
   #                                     prepend
   #                   - $alternate_root - path to prepend
   #                   - $uname - username to use for &propath or user dir
   #                   - $udom - domain to use for &propath or user dir
   #            All of these except $getpropath and &getuserdir are escaped.    
   #                  no_such_dir.
   #    $client     - Socket open on the client.
   # Returns:
   #     1 - indicating that the daemon should not disconnect.
   # Side Effects:
   #   The reply is written to $client.
   #
   
   sub ls3_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($ulsdir,$getpropath,$getuserdir,$alternate_root,$uname,$udom) =
           split(/:/,$tail);
       if (defined($ulsdir)) {
           $ulsdir = &unescape($ulsdir);
       }
       if (defined($alternate_root)) {
           $alternate_root = &unescape($alternate_root);
       }
       if (defined($uname)) {
           $uname = &unescape($uname);
       }
       if (defined($udom)) {
           $udom = &unescape($udom);
       }
   
       my $dir_root = $perlvar{'lonDocRoot'};
       if ($getpropath) {
           if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
               $dir_root = &propath($udom,$uname);
               $dir_root =~ s/\/$//;
           } else {
               &Failure($client,"refused\n","$cmd:$tail");
               return 1;
           }
       } elsif ($getuserdir) {
           if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
               my $subdir=$uname.'__';
               $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
               $dir_root = $Apache::lonnet::perlvar{'lonUsersDir'}
                          ."/$udom/$subdir/$uname";
           } else {
               &Failure($client,"refused\n","$cmd:$tail");
               return 1;
           }
       } elsif ($alternate_root ne '') {
           $dir_root = $alternate_root;
       }
       if (($dir_root ne '') && ($dir_root ne '/')) {
           if ($ulsdir =~ /^\//) {
               $ulsdir = $dir_root.$ulsdir;
           } else {
               $ulsdir = $dir_root.'/'.$ulsdir;
           }
       }
       my $obs;
       my $rights;
       my $ulsout='';
       my $ulsfn;
       if (-e $ulsdir) {
           if(-d $ulsdir) {
               if (opendir(LSDIR,$ulsdir)) {
                   while ($ulsfn=readdir(LSDIR)) {
                       undef($obs);
                       undef($rights);
                       my @ulsstats=stat($ulsdir.'/'.$ulsfn);
                       #We do some obsolete checking here
                       if(-e $ulsdir.'/'.$ulsfn.".meta") {
                           open(FILE, $ulsdir.'/'.$ulsfn.".meta");
                           my @obsolete=<FILE>;
                           foreach my $obsolete (@obsolete) {
                               if($obsolete =~ m/(<obsolete>)(on|1)/) { $obs = 1; }
                               if($obsolete =~ m|(<copyright>)(default)|) {
                                   $rights = 1;
                               }
                           }
                       }
                       my $tmp = $ulsfn.'&'.join('&',@ulsstats);
                       if ($obs    eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
                       if ($rights eq '1') { $tmp.="&1"; } else { $tmp.="&0"; }
                       $ulsout.= &escape($tmp).':';
                   }
                   closedir(LSDIR);
               }
           } else {
               my @ulsstats=stat($ulsdir);
               $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
           }
       } else {
           $ulsout='no_such_dir';
       }
       if ($ulsout eq '') { $ulsout='empty'; }
       &Reply($client, \$ulsout, $userinput); # This supports debug logging.
       return 1;
   }
   &register_handler("ls3", \&ls3_handler, 0, 1, 0);
   
 #   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 1439  sub reinit_process_handler { Line 1610  sub reinit_process_handler {
     if(&ValidManager($cert)) {      if(&ValidManager($cert)) {
  chomp($userinput);   chomp($userinput);
  my $reply = &ReinitProcess($userinput);   my $reply = &ReinitProcess($userinput);
  &Reply( $client,  "$reply\n", $userinput);   &Reply( $client,  \$reply, $userinput);
     } else {      } else {
  &Failure( $client, "refused\n", $userinput);   &Failure( $client, "refused\n", $userinput);
     }      }
Line 1523  sub authenticate_handler { Line 1694  sub authenticate_handler {
     #  udom    - User's domain.      #  udom    - User's domain.
     #  uname   - Username.      #  uname   - Username.
     #  upass   - User's password.      #  upass   - User's password.
       #  checkdefauth - Pass to validate_user() to try authentication
       #                 with default auth type(s) if no user account.
           
     my ($udom,$uname,$upass)=split(/:/,$tail);      my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);
     &Debug(" Authenticate domain = $udom, user = $uname, password = $upass");      &Debug(" Authenticate domain = $udom, user = $uname, password = $upass,  checkdefauth = $checkdefauth");
     chomp($upass);      chomp($upass);
     $upass=&unescape($upass);      $upass=&unescape($upass);
   
     my $pwdcorrect = &validate_user($udom, $uname, $upass);      my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
     if($pwdcorrect) {      if($pwdcorrect) {
  &Reply( $client, "authorized\n", $userinput);   &Reply( $client, "authorized\n", $userinput);
  #   #
Line 1574  sub change_password_handler { Line 1747  sub change_password_handler {
     #  uname - Username.      #  uname - Username.
     #  upass - Current password.      #  upass - Current password.
     #  npass - New password.      #  npass - New password.
       #  context - Context in which this was called 
       #            (preferences or reset_by_email).
         
     my ($udom,$uname,$upass,$npass)=split(/:/,$tail);      my ($udom,$uname,$upass,$npass,$context)=split(/:/,$tail);
   
     $upass=&unescape($upass);      $upass=&unescape($upass);
     $npass=&unescape($npass);      $npass=&unescape($npass);
     &Debug("Trying to change password for $uname");      &Debug("Trying to change password for $uname");
   
     # First require that the user can be authenticated with their      # First require that the user can be authenticated with their
     # old password:      # old password unless context was 'reset_by_email':
       
     my $validated = &validate_user($udom, $uname, $upass);      my $validated;
       if ($context eq 'reset_by_email') {
           $validated = 1;
       } else {
           $validated = &validate_user($udom, $uname, $upass);
       }
     if($validated) {      if($validated) {
  my $realpasswd  = &get_auth_type($udom, $uname); # Defined since authd.   my $realpasswd  = &get_auth_type($udom, $uname); # Defined since authd.
   
Line 1603  sub change_password_handler { Line 1783  sub change_password_handler {
  ."to change password");   ."to change password");
  &Failure( $client, "non_authorized\n",$userinput);   &Failure( $client, "non_authorized\n",$userinput);
     }      }
  } elsif ($howpwd eq 'unix') {   } elsif ($howpwd eq 'unix' && $context ne 'reset_by_email') {
     my $result = &change_unix_password($uname, $npass);      my $result = &change_unix_password($uname, $npass);
     &logthis("Result of password change for $uname: ".      &logthis("Result of password change for $uname: ".
      $result);       $result);
     &Reply($client, "$result\n", $userinput);      &Reply($client, \$result, $userinput);
  } else {   } else {
     # this just means that the current password mode is not      # this just means that the current password mode is not
     # one we know how to change (e.g the kerberos auth modes or      # one we know how to change (e.g the kerberos auth modes or
Line 1668  sub add_user_handler { Line 1848  sub add_user_handler {
     }      }
     unless ($fperror) {      unless ($fperror) {
  my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);   my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
  &Reply($client, $result, $userinput);     #BUGBUG - could be fail   &Reply($client,\$result, $userinput);     #BUGBUG - could be fail
     } else {      } else {
  &Failure($client, "$fperror\n", $userinput);   &Failure($client, \$fperror, $userinput);
     }      }
  }   }
  umask($oldumask);   umask($oldumask);
Line 1737  sub change_authentication_handler { Line 1917  sub change_authentication_handler {
  my $result = &change_unix_password($uname, $npass);   my $result = &change_unix_password($uname, $npass);
  &logthis("Result of password change for $uname: ".$result);   &logthis("Result of password change for $uname: ".$result);
  if ($result eq "ok") {   if ($result eq "ok") {
     &Reply($client, "$result\n")      &Reply($client, \$result);
  } else {   } else {
     &Failure($client, "$result\n");      &Failure($client, \$result);
  }   }
     } else {      } else {
  my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);   my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
Line 1758  sub change_authentication_handler { Line 1938  sub change_authentication_handler {
  &manage_permissions("/$udom/_au", $udom, $uname, "$umode:");   &manage_permissions("/$udom/_au", $udom, $uname, "$umode:");
     }      }
  }   }
  &Reply($client, $result, $userinput);   &Reply($client, \$result, $userinput);
     }      }
                 
   
Line 1842  sub update_resource_handler { Line 2022  sub update_resource_handler {
     my $now=time;      my $now=time;
     my $since=$now-$atime;      my $since=$now-$atime;
     if ($since>$perlvar{'lonExpire'}) {      if ($since>$perlvar{'lonExpire'}) {
  my $reply=&reply("unsub:$fname","$clientname");   my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
  &devalidate_meta_cache($fname);   &devalidate_meta_cache($fname);
  unlink("$fname");   unlink("$fname");
  unlink("$fname.meta");   unlink("$fname.meta");
     } else {      } else {
  my $transname="$fname.in.transfer";   my $transname="$fname.in.transfer";
  my $remoteurl=&reply("sub:$fname","$clientname");   my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
  my $response;   my $response;
  alarm(120);   alarm(120);
  {   {
Line 1893  sub devalidate_meta_cache { Line 2073  sub devalidate_meta_cache {
     my ($url) = @_;      my ($url) = @_;
     use Cache::Memcached;      use Cache::Memcached;
     my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});      my $memcache = new Cache::Memcached({'servers'=>['127.0.0.1:11211']});
     $url = &declutter($url);      $url = &Apache::lonnet::declutter($url);
     $url =~ s-\.meta$--;      $url =~ s-\.meta$--;
     my $id = &escape('meta:'.$url);      my $id = &escape('meta:'.$url);
     $memcache->delete($id);      $memcache->delete($id);
 }  }
   
 sub declutter {  
     my $thisfn=shift;  
     $thisfn=~s/^\Q$perlvar{'lonDocRoot'}\E//;  
     $thisfn=~s/^\///;  
     $thisfn=~s|^adm/wrapper/||;  
     $thisfn=~s|^adm/coursedocs/showdoc/||;  
     $thisfn=~s/^res\///;  
     $thisfn=~s/\?.+$//;  
     return $thisfn;  
 }  
 #  #
 #   Fetch a user file from a remote server to the user's home directory  #   Fetch a user file from a remote server to the user's home directory
 #   userfiles subdir.  #   userfiles subdir.
Line 2107  sub rename_user_file_handler { Line 2277  sub rename_user_file_handler {
 &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);  &register_handler("renameuserfile", \&rename_user_file_handler, 0,1,0);
   
 #  #
   #  Checks if the specified user has an active session on the server
   #  return ok if so, not_found if not
   #
   # Parameters:
   #   cmd      - The request keyword that dispatched to tus.
   #   tail     - The tail of the request (colon separated parameters).
   #   client   - Filehandle open on the client.
   # Return:
   #    1.
   sub user_has_session_handler {
       my ($cmd, $tail, $client) = @_;
   
       my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
       
       &logthis("Looking for $udom $uname");
       opendir(DIR,$perlvar{'lonIDsDir'});
       my $filename;
       while ($filename=readdir(DIR)) {
    last if ($filename=~/^\Q$uname\E_\d+_\Q$udom\E_/);
       }
       if ($filename) {
    &Reply($client, "ok\n", "$cmd:$tail");
       } else {
    &Failure($client, "not_found\n", "$cmd:$tail");
       }
       return 1;
   
   }
   &register_handler("userhassession", \&user_has_session_handler, 0,1,0);
   
   #
 #  Authenticate access to a user file by checking that the token the user's   #  Authenticate access to a user file by checking that the token the user's 
 #  passed also exists in their session file  #  passed also exists in their session file
 #  #
Line 2122  sub token_auth_user_file_handler { Line 2323  sub token_auth_user_file_handler {
     my ($fname, $session) = split(/:/, $tail);      my ($fname, $session) = split(/:/, $tail);
           
     chomp($session);      chomp($session);
     my $reply="non_auth\n";      my $reply="non_auth";
     my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';      my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';
     if (open(ENVIN,"$file")) {      if (open(ENVIN,"$file")) {
  flock(ENVIN,LOCK_SH);   flock(ENVIN,LOCK_SH);
  tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);   tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
  if (exists($disk_env{"userfile.$fname"})) {   if (exists($disk_env{"userfile.$fname"})) {
     $reply="ok\n";      $reply="ok";
  } else {   } else {
     foreach my $envname (keys(%disk_env)) {      foreach my $envname (keys(%disk_env)) {
  if ($envname=~ m|^userfile\.\Q$fname\E|) {   if ($envname=~ m|^userfile\.\Q$fname\E|) {
     $reply="ok\n";      $reply="ok";
     last;      last;
  }   }
     }      }
  }   }
  untie(%disk_env);   untie(%disk_env);
  close(ENVIN);   close(ENVIN);
  &Reply($client, $reply, "$cmd:$tail");   &Reply($client, \$reply, "$cmd:$tail");
     } else {      } else {
  &Failure($client, "invalid_token\n", "$cmd:$tail");   &Failure($client, "invalid_token\n", "$cmd:$tail");
     }      }
Line 2199  sub subscribe_handler { Line 2400  sub subscribe_handler {
 &register_handler("sub", \&subscribe_handler, 0, 1, 0);  &register_handler("sub", \&subscribe_handler, 0, 1, 0);
   
 #  #
 #   Determine the version of a resource (?) Or is it return  #   Determine the latest version of a resource (it looks for the highest
 #   the top version of the resource?  Not yet clear from the  #   past version and then returns that +1)
 #   code in currentversion.  
 #  #
 # Parameters:  # Parameters:
 #    $cmd      - The command that got us here.  #    $cmd      - The command that got us here.
 #    $tail     - Tail of the command (remaining parameters).  #    $tail     - Tail of the command (remaining parameters).
   #                 (Should consist of an absolute path to a file)
 #    $client   - File descriptor connected to client.  #    $client   - File descriptor connected to client.
 # Returns  # Returns
 #     0        - Requested to exit, caller should shut down.  #     0        - Requested to exit, caller should shut down.
Line 2563  sub get_profile_entry { Line 2764  sub get_profile_entry {
     my ($udom,$uname,$namespace,$what) = split(/:/,$tail);      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
     chomp($what);      chomp($what);
   
   
     my $replystring = read_profile($udom, $uname, $namespace, $what);      my $replystring = read_profile($udom, $uname, $namespace, $what);
     my ($first) = split(/:/,$replystring);      my ($first) = split(/:/,$replystring);
     if($first ne "error") {      if($first ne "error") {
  &Reply($client, "$replystring\n", $userinput);   &Reply($client, \$replystring, $userinput);
     } else {      } else {
  &Failure($client, $replystring." while attempting get\n", $userinput);   &Failure($client, $replystring." while attempting get\n", $userinput);
     }      }
Line 2706  sub get_profile_keys { Line 2908  sub get_profile_keys {
  }   }
  if (&untie_user_hash($hashref)) {   if (&untie_user_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, \$qresult, $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
     "while attempting keys\n", $userinput);      "while attempting keys\n", $userinput);
Line 2776  sub dump_profile_database { Line 2978  sub dump_profile_database {
  }   }
     }      }
     chop($qresult);      chop($qresult);
     &Reply($client , "$qresult\n", $userinput);      &Reply($client , \$qresult, $userinput);
  } else {   } else {
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
      "while attempting currentdump\n", $userinput);       "while attempting currentdump\n", $userinput);
Line 2859  sub dump_with_regexp { Line 3061  sub dump_with_regexp {
  }   }
  if (&untie_user_hash($hashref)) {   if (&untie_user_hash($hashref)) {
     chop($qresult);      chop($qresult);
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, \$qresult, $userinput);
  } else {   } else {
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
      "while attempting dump\n", $userinput);       "while attempting dump\n", $userinput);
Line 3045  sub restore_handler { Line 3247  sub restore_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
     my $userinput = "$cmd:$tail"; # Only used for logging purposes.      my $userinput = "$cmd:$tail"; # Only used for logging purposes.
   
     my ($udom,$uname,$namespace,$rid) = split(/:/,$tail);      my ($udom,$uname,$namespace,$rid) = split(/:/,$tail);
     $namespace=~s/\//\_/g;      $namespace=~s/\//\_/g;
     $namespace=~s/\W//g;      $namespace = &LONCAPA::clean_username($namespace);
   
     chomp($rid);      chomp($rid);
     my $qresult='';      my $qresult='';
     my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());      my $hashref = &tie_user_hash($udom, $uname, $namespace, &GDBM_READER());
Line 3067  sub restore_handler { Line 3269  sub restore_handler {
  }   }
  if (&untie_user_hash($hashref)) {   if (&untie_user_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply( $client, "$qresult\n", $userinput);      &Reply( $client, \$qresult, $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
     "while attempting restore\n", $userinput);      "while attempting restore\n", $userinput);
Line 3148  sub retrieve_chat_handler { Line 3350  sub retrieve_chat_handler {
  $reply.=&escape($_).':';   $reply.=&escape($_).':';
     }      }
     $reply=~s/\:$//;      $reply=~s/\:$//;
     &Reply($client, $reply."\n", $userinput);      &Reply($client, \$reply, $userinput);
   
   
     return 1;      return 1;
Line 3285  sub put_course_id_handler { Line 3487  sub put_course_id_handler {
  foreach my $pair (@pairs) {   foreach my $pair (@pairs) {
             my ($key,$courseinfo) = split(/=/,$pair,2);              my ($key,$courseinfo) = split(/=/,$pair,2);
             $courseinfo =~ s/=/:/g;              $courseinfo =~ s/=/:/g;
               if (defined($hashref->{$key})) {
             my @current_items = split(/:/,$hashref->{$key});                  my $value = &Apache::lonnet::thaw_unescape($hashref->{$key});
                   if (ref($value) eq 'HASH') {
                       my @items = ('description','inst_code','owner','type');
                       my @new_items = split(/:/,$courseinfo,-1);
                       my %storehash; 
                       for (my $i=0; $i<@new_items; $i++) {
                           $storehash{$items[$i]} = &unescape($new_items[$i]);
                       }
                       $hashref->{$key} = 
                           &Apache::lonnet::freeze_escape(\%storehash);
                       my $unesc_key = &unescape($key);
                       $hashref->{&escape('lasttime:'.$unesc_key)} = $now;
                       next;
                   }
               }
               my @current_items = split(/:/,$hashref->{$key},-1);
             shift(@current_items); # remove description              shift(@current_items); # remove description
             pop(@current_items);   # remove last access              pop(@current_items);   # remove last access
             my $numcurrent = scalar(@current_items);              my $numcurrent = scalar(@current_items);
               if ($numcurrent > 3) {
             my @new_items = split(/:/,$courseinfo);                  $numcurrent = 3;
               }
               my @new_items = split(/:/,$courseinfo,-1);
             my $numnew = scalar(@new_items);              my $numnew = scalar(@new_items);
             if ($numcurrent > 0) {              if ($numcurrent > 0) {
                 if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2                   if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 
Line 3300  sub put_course_id_handler { Line 3519  sub put_course_id_handler {
                     }                      }
                 }                  }
             }              }
     $hashref->{$key}=$courseinfo.':'.$now;              $hashref->{$key}=$courseinfo.':'.$now;
  }   }
  if (&untie_domain_hash($hashref)) {   if (&untie_domain_hash($hashref)) {
     &Reply( $client, "ok\n", $userinput);      &Reply( $client, "ok\n", $userinput);
Line 3314  sub put_course_id_handler { Line 3533  sub put_course_id_handler {
  ." tie(GDBM) Failed ".   ." tie(GDBM) Failed ".
  "while attempting courseidput\n", $userinput);   "while attempting courseidput\n", $userinput);
     }      }
       
   
     return 1;      return 1;
 }  }
 &register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);  &register_handler("courseidput", \&put_course_id_handler, 0, 1, 0);
   
   sub put_course_id_hash_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($udom,$mode,$what) = split(/:/, $tail,3);
       chomp($what);
       my $now=time;
       my @pairs=split(/\&/,$what);
       my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
           foreach my $pair (@pairs) {
               my ($key,$value)=split(/=/,$pair);
               my $unesc_key = &unescape($key);
               if ($mode ne 'timeonly') {
                   if (!defined($hashref->{&escape('lasttime:'.$unesc_key)})) {
                       my $curritems = &Apache::lonnet::thaw_unescape($key); 
                       if (ref($curritems) ne 'HASH') {
                           my @current_items = split(/:/,$hashref->{$key},-1);
                           my $lasttime = pop(@current_items);
                           $hashref->{&escape('lasttime:'.$unesc_key)} = $lasttime;
                       } else {
                           $hashref->{&escape('lasttime:'.$unesc_key)} = '';
                       }
                   } 
                   $hashref->{$key} = $value;
               }
               if ($mode ne 'notime') {
                   $hashref->{&escape('lasttime:'.$unesc_key)} = $now;
               }
           }
           if (&untie_domain_hash($hashref)) {
               &Reply($client, "ok\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                        "while attempting courseidputhash\n", $userinput);
           }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                     "while attempting courseidputhash\n", $userinput);
       }
       return 1;
   }
   &register_handler("courseidputhash", \&put_course_id_hash_handler, 0, 1, 0);
   
 #  Retrieves the value of a course id resource keyword pattern  #  Retrieves the value of a course id resource keyword pattern
 #  defined since a starting date.  Both the starting date and the  #  defined since a starting date.  Both the starting date and the
 #  keyword pattern are optional.  If the starting date is not supplied it  #  keyword pattern are optional.  If the starting date is not supplied it
Line 3346  sub put_course_id_handler { Line 3607  sub put_course_id_handler {
 #                            owner matches the supplied username and/or domain  #                            owner matches the supplied username and/or domain
 #                            will be returned. Pre-2.2.0 legacy entries from   #                            will be returned. Pre-2.2.0 legacy entries from 
 #                            nohist_courseiddump will only contain usernames.  #                            nohist_courseiddump will only contain usernames.
   #                 type     - optional parameter for selection 
   #                 regexp_ok - if true, allow the supplied institutional code
   #                            filter to behave as a regular expression.  
   #                 rtn_as_hash - whether to return the information available for
   #                            each matched item as a frozen hash of all 
   #                            key, value pairs in the item's hash, or as a 
   #                            colon-separated list of (in order) description,
   #                            institutional code, and course owner.
   #                 selfenrollonly - filter by courses allowing self-enrollment  
   #                                  now or in the future (selfenrollonly = 1).
   #                 catfilter - filter by course category, assigned to a course 
   #                             using manually defined categories (i.e., not
   #                             self-cataloging based on on institutional code).   
   #                 showhidden - include course in results even if course  
   #                              was set to be excluded from course catalog (DC only).
   #                 caller -  if set to 'coursecatalog', courses set to be hidden
   #                           from course catalog will be excluded from results (unless
   #                           overridden by "showhidden".
   #
 #     $client  - The socket open on the client.  #     $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1     - Continue processing.  #    1     - Continue processing.
Line 3353  sub put_course_id_handler { Line 3633  sub put_course_id_handler {
 #   a reply is written to $client.  #   a reply is written to $client.
 sub dump_course_id_handler {  sub dump_course_id_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
         $typefilter,$regexp_ok) =split(/:/,$tail);          $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
           $caller) =split(/:/,$tail);
       my $now = time;
     if (defined($description)) {      if (defined($description)) {
  $description=&unescape($description);   $description=&unescape($description);
     } else {      } else {
Line 3397  sub dump_course_id_handler { Line 3678  sub dump_course_id_handler {
     if (defined($regexp_ok)) {      if (defined($regexp_ok)) {
         $regexp_ok=&unescape($regexp_ok);          $regexp_ok=&unescape($regexp_ok);
     }      }
       if (defined($catfilter)) {
     unless (defined($since)) { $since=0; }          $catfilter=&unescape($catfilter);
       }
       my $unpack = 1;
       if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' && 
           $typefilter eq '.') {
           $unpack = 0;
       }
       if (!defined($since)) { $since=0; }
     my $qresult='';      my $qresult='';
     my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
     my ($descr,$lasttime,$inst_code,$owner,$type);              my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
             my @courseitems = split(/:/,$value);                  %unesc_val,$selfenroll_end,$selfenroll_types);
             $lasttime = pop(@courseitems);              $unesc_key = &unescape($key);
     ($descr,$inst_code,$owner,$type)=@courseitems;              if ($unesc_key =~ /^lasttime:/) {
     if ($lasttime<$since) { next; }                  next;
               } else {
                   $lasttime_key = &escape('lasttime:'.$unesc_key);
               }
               if ($hashref->{$lasttime_key} ne '') {
                   $lasttime = $hashref->{$lasttime_key};
                   next if ($lasttime<$since);
               }
               my $items = &Apache::lonnet::thaw_unescape($value);
               if (ref($items) eq 'HASH') {
                   $is_hash =  1;
                   if ($unpack || !$rtn_as_hash) {
                       $unesc_val{'descr'} = $items->{'description'};
                       $unesc_val{'inst_code'} = $items->{'inst_code'};
                       $unesc_val{'owner'} = $items->{'owner'};
                       $unesc_val{'type'} = $items->{'type'};
                   }
                   $selfenroll_types = $items->{'selfenroll_types'};
                   $selfenroll_end = $items->{'selfenroll_end_date'};
                   if ($selfenrollonly) {
                       next if (!$selfenroll_types);
                       if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
                           next;
                       }
                   }
                   if ($catfilter ne '') {
                       next if ($items->{'categories'} eq '');
                       my @categories = split('&',$items->{'categories'}); 
                       next if (@categories == 0);
                       my @subcats = split('&',$catfilter);
                       my $matchcat = 0;
                       foreach my $cat (@categories) {
                           if (grep(/^\Q$cat\E$/,@subcats)) {
                               $matchcat = 1;
                               last;
                           }
                       }
                       next if (!$matchcat);
                   }
                   if ($caller eq 'coursecatalog') {
                       if ($items->{'hidefromcat'} eq 'yes') {
                           next if !$showhidden;
                       }
                   }
               } else {
                   next if ($catfilter ne '');
                   next if ($selfenrollonly); 
                   $is_hash =  0;
                   my @courseitems = split(/:/,$value);
                   $lasttime = pop(@courseitems);
                   if ($hashref->{$lasttime_key} eq '') {
                       next if ($lasttime<$since);
                   }
           ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
               }
             my $match = 1;              my $match = 1;
     unless ($description eq '.') {      if ($description ne '.') {
  my $unescapeDescr = &unescape($descr);                  if (!$is_hash) {
  unless (eval('$unescapeDescr=~/\Q$description\E/i')) {                      $unesc_val{'descr'} = &unescape($val{'descr'});
                   }
                   if (eval{$unesc_val{'descr'} !~ /\Q$description\E/i}) {
                     $match = 0;                      $match = 0;
  }                  }
             }              }
             unless ($instcodefilter eq '.' || !defined($instcodefilter)) {              if ($instcodefilter ne '.') {
                 my $unescapeInstcode = &unescape($inst_code);                  if (!$is_hash) {
                       $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
                   }
                 if ($regexp_ok) {                  if ($regexp_ok) {
                     unless (eval('$unescapeInstcode=~/$instcodefilter/')) {                      if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
                         $match = 0;                          $match = 0;
                     }                      }
                 } else {                  } else {
                     unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {                      if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
                         $match = 0;                          $match = 0;
                     }                      }
                 }                  }
     }      }
             unless ($ownerfilter eq '.' || !defined($ownerfilter)) {              if ($ownerfilter ne '.') {
                 my $unescapeOwner = &unescape($owner);                  if (!$is_hash) {
                       $unesc_val{'owner'} = &unescape($val{'owner'});
                   }
                 if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {                  if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
                     if ($unescapeOwner =~ /:/) {                      if ($unesc_val{'owner'} =~ /:/) {
                         if (eval('$unescapeOwner !~                           if (eval{$unesc_val{'owner'} !~ 
                              /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i')) {                               /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
                             $match = 0;                              $match = 0;
                         }                           } 
                     } else {                      } else {
                         if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {                          if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                             $match = 0;                              $match = 0;
                         }                          }
                     }                      }
                 } elsif ($ownerunamefilter ne '') {                  } elsif ($ownerunamefilter ne '') {
                     if ($unescapeOwner =~ /:/) {                      if ($unesc_val{'owner'} =~ /:/) {
                         if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E:[^:]+$/i')) {                          if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
                              $match = 0;                               $match = 0;
                         }                          }
                     } else {                      } else {
                         if (eval('$unescapeOwner!~/\Q$ownerunamefilter\E/i')) {                          if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                             $match = 0;                              $match = 0;
                         }                          }
                     }                      }
                 } elsif ($ownerdomfilter ne '') {                  } elsif ($ownerdomfilter ne '') {
                     if ($unescapeOwner =~ /:/) {                      if ($unesc_val{'owner'} =~ /:/) {
                         if (eval('$unescapeOwner!~/^[^:]+:\Q$ownerdomfilter\E/')) {                          if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
                              $match = 0;                               $match = 0;
                         }                          }
                     } else {                      } else {
Line 3462  sub dump_course_id_handler { Line 3810  sub dump_course_id_handler {
                     }                      }
                 }                  }
             }              }
             unless ($coursefilter eq '.' || !defined($coursefilter)) {              if ($coursefilter ne '.') {
                 my $unescapeCourse = &unescape($key);                  if (eval{$unesc_key !~ /^$udom(_)\Q$coursefilter\E$/}) {
                 unless (eval('$unescapeCourse=~/^$udom(_)\Q$coursefilter\E$/')) {  
                     $match = 0;                      $match = 0;
                 }                  }
             }              }
             unless ($typefilter eq '.' || !defined($typefilter)) {              if ($typefilter ne '.') {
                 my $unescapeType = &unescape($type);                  if (!$is_hash) {
                 if ($type eq '') {                      $unesc_val{'type'} = &unescape($val{'type'});
                   }
                   if ($unesc_val{'type'} eq '') {
                     if ($typefilter ne 'Course') {                      if ($typefilter ne 'Course') {
                         $match = 0;                          $match = 0;
                     }                      }
                 } else {                   } else {
                     unless (eval('$unescapeType=~/^\Q$typefilter\E$/')) {                      if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
                         $match = 0;                          $match = 0;
                     }                      }
                 }                  }
             }              }
             if ($match == 1) {              if ($match == 1) {
                 $qresult.=$key.'='.$descr.':'.$inst_code.':'.$owner.'&';                  if ($rtn_as_hash) {
                       if ($is_hash) {
                           $qresult.=$key.'='.$value.'&';
                       } else {
                           my %rtnhash = ( 'description' => &unescape($val{'descr'}),
                                           'inst_code' => &unescape($val{'inst_code'}),
                                           'owner'     => &unescape($val{'owner'}),
                                           'type'      => &unescape($val{'type'}),
                                         );
                           my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
                           $qresult.=$key.'='.$items.'&';
                       }
                   } else {
                       if ($is_hash) {
                           $qresult .= $key.'='.&escape($unesc_val{'descr'}).':'.
                                       &escape($unesc_val{'inst_code'}).':'.
                                       &escape($unesc_val{'owner'}).'&';
                       } else {
                           $qresult .= $key.'='.$val{'descr'}.':'.$val{'inst_code'}.
                                       ':'.$val{'owner'}.'&';
                       }
                   }
             }              }
  }   }
  if (&untie_domain_hash($hashref)) {   if (&untie_domain_hash($hashref)) {
     chop($qresult);      chop($qresult);
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, \$qresult, $userinput);
  } else {   } else {
     &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
     "while attempting courseiddump\n", $userinput);      "while attempting courseiddump\n", $userinput);
Line 3495  sub dump_course_id_handler { Line 3865  sub dump_course_id_handler {
  &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".   &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
  "while attempting courseiddump\n", $userinput);   "while attempting courseiddump\n", $userinput);
     }      }
       return 1;
   }
   &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
   
   #
   # Puts an unencrypted entry in a namespace db file at the domain level 
   #
   # Parameters:
   #    $cmd      - The command that got us here.
   #    $tail     - Tail of the command (remaining parameters).
   #    $client   - File descriptor connected to client.
   # Returns
   #     0        - Requested to exit, caller should shut down.
   #     1        - Continue processing.
   #  Side effects:
   #     reply is written to $client.
   #
   sub put_domain_handler {
       my ($cmd,$tail,$client) = @_;
   
       my $userinput = "$cmd:$tail";
   
       my ($udom,$namespace,$what) =split(/:/,$tail,3);
       chomp($what);
       my @pairs=split(/\&/,$what);
       my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_WRCREAT(),
                                      "P", $what);
       if ($hashref) {
           foreach my $pair (@pairs) {
               my ($key,$value)=split(/=/,$pair);
               $hashref->{$key}=$value;
           }
           if (&untie_domain_hash($hashref)) {
               &Reply($client, "ok\n", $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                        "while attempting putdom\n", $userinput);
           }
       } else {
           &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
                     "while attempting putdom\n", $userinput);
       }
   
     return 1;      return 1;
 }  }
 &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);  &register_handler("putdom", \&put_domain_handler, 0, 1, 0);
   
   # Unencrypted get from the namespace database file at the domain level.
   # This function retrieves a keyed item from a specific named database in the
   # domain directory.
   #
   # Parameters:
   #   $cmd             - Command request keyword (get).
   #   $tail            - Tail of the command.  This is a colon separated list
   #                      consisting of the domain and the 'namespace' 
   #                      which selects the gdbm file to do the lookup in,
   #                      & separated list of keys to lookup.  Note that
   #                      the values are returned as an & separated list too.
   #   $client          - File descriptor open on the client.
   # Returns:
   #   1       - Continue processing.
   #   0       - Exit.
   #  Side effects:
   #     reply is written to $client.
   #
   
   sub get_domain_handler {
       my ($cmd, $tail, $client) = @_;
   
       my $userinput = "$client:$tail";
   
       my ($udom,$namespace,$what)=split(/:/,$tail,3);
       chomp($what);
       my @queries=split(/\&/,$what);
       my $qresult='';
       my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER());
       if ($hashref) {
           for (my $i=0;$i<=$#queries;$i++) {
               $qresult.="$hashref->{$queries[$i]}&";
           }
           if (&untie_domain_hash($hashref)) {
               $qresult=~s/\&$//;
               &Reply($client, \$qresult, $userinput);
           } else {
               &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
                         "while attempting getdom\n",$userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                    "while attempting getdom\n",$userinput);
       }
   
       return 1;
   }
   &register_handler("getdom", \&get_domain_handler, 0, 1, 0);
   
   
 #  #
 #  Puts an id to a domains id database.   #  Puts an id to a domains id database. 
Line 3584  sub get_id_handler { Line 4045  sub get_id_handler {
  }   }
  if (&untie_domain_hash($hashref)) {   if (&untie_domain_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
     &Reply($client, "$qresult\n", $userinput);      &Reply($client, \$qresult, $userinput);
  } else {   } else {
     &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".      &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
       "while attempting idget\n",$userinput);        "while attempting idget\n",$userinput);
Line 3708  sub dump_dcmail_handler { Line 4169  sub dump_dcmail_handler {
         }          }
         if (&untie_domain_hash($hashref)) {          if (&untie_domain_hash($hashref)) {
             chop($qresult);              chop($qresult);
             &Reply($client, "$qresult\n", $userinput);              &Reply($client, \$qresult, $userinput);
         } else {          } else {
             &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".              &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                     "while attempting dcmaildump\n", $userinput);                      "while attempting dcmaildump\n", $userinput);
Line 3826  sub dump_domainroles_handler { Line 4287  sub dump_domainroles_handler {
                 }                  }
             }              }
             unless (@roles < 1) {              unless (@roles < 1) {
                 unless (grep/^$trole$/,@roles) {                  unless (grep/^\Q$trole\E$/,@roles) {
                     $match = 0;                      $match = 0;
                 }                  }
             }              }
Line 3836  sub dump_domainroles_handler { Line 4297  sub dump_domainroles_handler {
         }          }
         if (&untie_domain_hash($hashref)) {          if (&untie_domain_hash($hashref)) {
             chop($qresult);              chop($qresult);
             &Reply($client, "$qresult\n", $userinput);              &Reply($client, \$qresult, $userinput);
         } else {          } else {
             &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".              &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                     "while attempting domrolesdump\n", $userinput);                      "while attempting domrolesdump\n", $userinput);
Line 3872  sub tmp_put_handler { Line 4333  sub tmp_put_handler {
   
     my $userinput = "$cmd:$what"; # Reconstruct for logging.      my $userinput = "$cmd:$what"; # Reconstruct for logging.
   
       my ($record,$context) = split(/:/,$what);
     my $store;      if ($context ne '') {
           chomp($context);
           $context = &unescape($context);
       }
       my ($id,$store);
     $tmpsnum++;      $tmpsnum++;
     my $id=$$.'_'.$clientip.'_'.$tmpsnum;      if ($context eq 'resetpw') {
           $id = &md5_hex(&md5_hex(time.{}.rand().$$));
       } else {
           $id = $$.'_'.$clientip.'_'.$tmpsnum;
       }
     $id=~s/\W/\_/g;      $id=~s/\W/\_/g;
     $what=~s/\n//g;      $record=~s/\n//g;
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {      if ($store=IO::File->new(">$execdir/tmp/$id.tmp")) {
  print $store $what;   print $store $record;
  close $store;   close $store;
  &Reply($client, "$id\n", $userinput);   &Reply($client, \$id, $userinput);
     } else {      } else {
  &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".   &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
   "while attempting tmpput\n", $userinput);    "while attempting tmpput\n", $userinput);
Line 3916  sub tmp_get_handler { Line 4385  sub tmp_get_handler {
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {      if ($store=IO::File->new("$execdir/tmp/$id.tmp")) {
  my $reply=<$store>;   my $reply=<$store>;
  &Reply( $client, "$reply\n", $userinput);   &Reply( $client, \$reply, $userinput);
  close $store;   close $store;
     } else {      } else {
  &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".   &Failure( $client, "error: ".($!+0)."IO::File->new Failed ".
Line 4100  sub enrollment_enabled_handler { Line 4569  sub enrollment_enabled_handler {
     my ($cdom) = split(/:/, $tail, 2);   # Domain we're asking about.      my ($cdom) = split(/:/, $tail, 2);   # Domain we're asking about.
   
     my $outcome  = &localenroll::run($cdom);      my $outcome  = &localenroll::run($cdom);
     &Reply($client, "$outcome\n", $userinput);      &Reply($client, \$outcome, $userinput);
   
     return 1;      return 1;
 }  }
Line 4127  sub get_sections_handler { Line 4596  sub get_sections_handler {
     my @secs = &localenroll::get_sections($coursecode,$cdom);      my @secs = &localenroll::get_sections($coursecode,$cdom);
     my $seclist = &escape(join(':',@secs));      my $seclist = &escape(join(':',@secs));
   
     &Reply($client, "$seclist\n", $userinput);      &Reply($client, \$seclist, $userinput);
           
   
     return 1;      return 1;
Line 4156  sub validate_course_owner_handler { Line 4625  sub validate_course_owner_handler {
   
     $owner = &unescape($owner);      $owner = &unescape($owner);
     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);      my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
     &Reply($client, "$outcome\n", $userinput);      &Reply($client, \$outcome, $userinput);
   
   
   
Line 4187  sub validate_course_section_handler { Line 4656  sub validate_course_section_handler {
     my ($inst_course_id, $cdom) = split(/:/, $tail);      my ($inst_course_id, $cdom) = split(/:/, $tail);
   
     my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);      my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
     &Reply($client, "$outcome\n", $userinput);      &Reply($client, \$outcome, $userinput);
   
   
     return 1;      return 1;
Line 4214  sub validate_course_section_handler { Line 4683  sub validate_course_section_handler {
 sub validate_class_access_handler {  sub validate_class_access_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
     my ($inst_class,$courseowner,$cdom) = split(/:/, $tail);      my ($inst_class,$ownerlist,$cdom) = split(/:/, $tail);
     $courseowner = &unescape($courseowner);      my $owners = &unescape($ownerlist);
     my $outcome;      my $outcome;
     eval {      eval {
  local($SIG{__DIE__})='DEFAULT';   local($SIG{__DIE__})='DEFAULT';
  $outcome=&localenroll::check_section($inst_class,$courseowner,$cdom);   $outcome=&localenroll::check_section($inst_class,$owners,$cdom);
     };      };
     &Reply($client,"$outcome\n", $userinput);      &Reply($client,\$outcome, $userinput);
   
     return 1;      return 1;
 }  }
Line 4342  sub get_institutional_code_format_handle Line 4811  sub get_institutional_code_format_handle
     \%cat_titles,      \%cat_titles,
     \%cat_order);      \%cat_order);
     if ($formatreply eq 'ok') {      if ($formatreply eq 'ok') {
  my $codes_str = &hash2str(%codes);   my $codes_str = &Apache::lonnet::hash2str(%codes);
  my $codetitles_str = &array2str(@codetitles);   my $codetitles_str = &Apache::lonnet::array2str(@codetitles);
  my $cat_titles_str = &hash2str(%cat_titles);   my $cat_titles_str = &Apache::lonnet::hash2str(%cat_titles);
  my $cat_order_str = &hash2str(%cat_order);   my $cat_order_str = &Apache::lonnet::hash2str(%cat_order);
  &Reply($client,   &Reply($client,
        $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'         $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'
        .$cat_order_str."\n",         .$cat_order_str."\n",
Line 4362  sub get_institutional_code_format_handle Line 4831  sub get_institutional_code_format_handle
 &register_handler("autoinstcodeformat",  &register_handler("autoinstcodeformat",
   \&get_institutional_code_format_handler,0,1,0);    \&get_institutional_code_format_handler,0,1,0);
   
   sub get_institutional_defaults_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
   
       my $dom = $tail;
       my %defaults_hash;
       my @code_order;
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::instcode_defaults($dom,\%defaults_hash,
                                                      \@code_order);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result='';
               while (my ($key,$value) = each(%defaults_hash)) {
                   $result.=&escape($key).'='.&escape($value).'&';
               }
               $result .= 'code_order='.&escape(join('&',@code_order));
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("autoinstcodedefaults",
                     \&get_institutional_defaults_handler,0,1,0);
   
   sub get_institutional_user_rules {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my $dom = &unescape($tail);
       my (%rules_hash,@rules_order);
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::username_rules($dom,\%rules_hash,\@rules_order);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result;
               foreach my $key (keys(%rules_hash)) {
                   $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
               }
               $result =~ s/\&$//;
               $result .= ':';
               if (@rules_order > 0) {
                   foreach my $item (@rules_order) {
                       $result .= &escape($item).'&';
                   }
               }
               $result =~ s/\&$//;
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instuserrules",\&get_institutional_user_rules,0,1,0);
   
   sub get_institutional_id_rules {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my $dom = &unescape($tail);
       my (%rules_hash,@rules_order);
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::id_rules($dom,\%rules_hash,\@rules_order);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result;
               foreach my $key (keys(%rules_hash)) {
                   $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
               }
               $result =~ s/\&$//;
               $result .= ':';
               if (@rules_order > 0) {
                   foreach my $item (@rules_order) {
                       $result .= &escape($item).'&';
                   }
               }
               $result =~ s/\&$//;
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instidrules",\&get_institutional_id_rules,0,1,0);
   
   sub get_institutional_selfcreate_rules {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my $dom = &unescape($tail);
       my (%rules_hash,@rules_order);
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::selfcreate_rules($dom,\%rules_hash,\@rules_order);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result;
               foreach my $key (keys(%rules_hash)) {
                   $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($rules_hash{$key}).'&';
               }
               $result =~ s/\&$//;
               $result .= ':';
               if (@rules_order > 0) {
                   foreach my $item (@rules_order) {
                       $result .= &escape($item).'&';
                   }
               }
               $result =~ s/\&$//;
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instemailrules",\&get_institutional_selfcreate_rules,0,1,0);
   
   
   sub institutional_username_check {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my %rulecheck;
       my $outcome;
       my ($udom,$uname,@rules) = split(/:/,$tail);
       $udom = &unescape($udom);
       $uname = &unescape($uname);
       @rules = map {&unescape($_);} (@rules);
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::username_check($udom,$uname,\@rules,\%rulecheck);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result='';
               foreach my $key (keys(%rulecheck)) {
                   $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
               }
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instrulecheck",\&institutional_username_check,0,1,0);
   
   sub institutional_id_check {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my %rulecheck;
       my $outcome;
       my ($udom,$id,@rules) = split(/:/,$tail);
       $udom = &unescape($udom);
       $id = &unescape($id);
       @rules = map {&unescape($_);} (@rules);
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::id_check($udom,$id,\@rules,\%rulecheck);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result='';
               foreach my $key (keys(%rulecheck)) {
                   $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
               }
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instidrulecheck",\&institutional_id_check,0,1,0);
   
   sub institutional_selfcreate_check {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
       my %rulecheck;
       my $outcome;
       my ($udom,$email,@rules) = split(/:/,$tail);
       $udom = &unescape($udom);
       $email = &unescape($email);
       @rules = map {&unescape($_);} (@rules);
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::selfcreate_check($udom,$email,\@rules,\%rulecheck);
       };
       if (!$@) {
           if ($outcome eq 'ok') {
               my $result='';
               foreach my $key (keys(%rulecheck)) {
                   $result.=&escape($key).'='.&Apache::lonnet::freeze_escape($rulecheck{$key}).'&';
               }
               &Reply($client,\$result,$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instselfcreatecheck",\&institutional_selfcreate_check,0,1,0);
   
 # Get domain specific conditions for import of student photographs to a course  # Get domain specific conditions for import of student photographs to a course
 #  #
 # Retrieves information from photo_permission subroutine in localenroll.  # Retrieves information from photo_permission subroutine in localenroll.
Line 4489  sub student_photo_handler { Line 5179  sub student_photo_handler {
 }  }
 &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);  &register_handler("studentphoto", \&student_photo_handler, 0, 1, 0);
   
   sub inst_usertypes_handler {
       my ($cmd, $domain, $client) = @_;
       my $res;
       my $userinput = $cmd.":".$domain; # For logging purposes.
       my (%typeshash,@order,$result);
       eval {
    local($SIG{__DIE__})='DEFAULT';
    $result=&localenroll::inst_usertypes($domain,\%typeshash,\@order);
       };
       if ($result eq 'ok') {
           if (keys(%typeshash) > 0) {
               foreach my $key (keys(%typeshash)) {
                   $res.=&escape($key).'='.&escape($typeshash{$key}).'&';
               }
           }
           $res=~s/\&$//;
           $res .= ':';
           if (@order > 0) {
               foreach my $item (@order) {
                   $res .= &escape($item).'&';
               }
           }
           $res=~s/\&$//;
       }
       &Reply($client, \$res, $userinput);
       return 1;
   }
   &register_handler("inst_usertypes", \&inst_usertypes_handler, 0, 1, 0);
   
 # mkpath makes all directories for a file, expects an absolute path with a  # mkpath makes all directories for a file, expects an absolute path with a
 # file or a trailing / if just a dir is passed  # file or a trailing / if just a dir is passed
 # returns 1 on success 0 on failure  # returns 1 on success 0 on failure
Line 4752  sub catchexception { Line 5471  sub catchexception {
     $SIG{__DIE__}='DEFAULT';      $SIG{__DIE__}='DEFAULT';
     &status("Catching exception");      &status("Catching exception");
     &logthis("<font color='red'>CRITICAL: "      &logthis("<font color='red'>CRITICAL: "
      ."ABNORMAL EXIT. Child $$ for server $thisserver died through "       ."ABNORMAL EXIT. Child $$ for server ".$perlvar{'lonHostID'}." died through "
      ."a crash with this error msg->[$error]</font>");       ."a crash with this error msg->[$error]</font>");
     &logthis('Famous last words: '.$status.' - '.$lastlog);      &logthis('Famous last words: '.$status.' - '.$lastlog);
     if ($client) { print $client "error: $error\n"; }      if ($client) { print $client "error: $error\n"; }
Line 4863  sub HUPSMAN {                      # sig Line 5582  sub HUPSMAN {                      # sig
 }  }
   
 #  #
 #    Kill off hashes that describe the host table prior to re-reading it.  
 #    Hashes affected are:  
 #       %hostid, %hostdom %hostip %hostdns.  
 #  
 sub KillHostHashes {  
     foreach my $key (keys %hostid) {  
  delete $hostid{$key};  
     }  
     foreach my $key (keys %hostdom) {  
  delete $hostdom{$key};  
     }  
     foreach my $key (keys %hostip) {  
  delete $hostip{$key};  
     }  
     foreach my $key (keys %hostdns) {  
  delete $hostdns{$key};  
     }  
 }  
 #  
 #   Read in the host table from file and distribute it into the various hashes:  
 #  
 #    - %hostid  -  Indexed by IP, the loncapa hostname.  
 #    - %hostdom -  Indexed by  loncapa hostname, the domain.  
 #    - %hostip  -  Indexed by hostid, the Ip address of the host.  
 sub ReadHostTable {  
   
     open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";  
     my $myloncapaname = $perlvar{'lonHostID'};  
     Debug("My loncapa name is : $myloncapaname");  
     my %name_to_ip;  
     while (my $configline=<CONFIG>) {  
  if ($configline !~ /^\s*\#/ && $configline !~ /^\s*$/ ) {  
     my ($id,$domain,$role,$name)=split(/:/,$configline);  
     $name=~s/\s//g;  
     my $ip;  
     if (!exists($name_to_ip{$name})) {  
  $ip = gethostbyname($name);  
  if (!$ip || length($ip) ne 4) {  
     &logthis("Skipping host $id name $name no IP found\n");  
     next;  
  }  
  $ip=inet_ntoa($ip);  
  $name_to_ip{$name} = $ip;  
     } else {  
  $ip = $name_to_ip{$name};  
     }  
     $hostid{$ip}=$id;         # LonCAPA name of host by IP.  
     $hostdom{$id}=$domain;    # LonCAPA domain name of host.   
     $hostname{$id}=$name;     # LonCAPA name -> DNS name  
     $hostip{$id}=$ip;         # IP address of host.  
     $hostdns{$name} = $id;    # LonCAPA name of host by DNS.  
   
     if ($id eq $perlvar{'lonHostID'}) {   
  Debug("Found me in the host table: $name");  
  $thisserver=$name;   
     }  
  }  
     }  
     close(CONFIG);  
 }  
 #  
 #  Reload the Apache daemon's state.  #  Reload the Apache daemon's state.
 #  This is done by invoking /home/httpd/perl/apachereload  #  This is done by invoking /home/httpd/perl/apachereload
 #  a setuid perl script that can be root for us to do this job.  #  a setuid perl script that can be root for us to do this job.
Line 4954  sub UpdateHosts { Line 5612  sub UpdateHosts {
     #  either dropped or changed hosts.  Note that the re-read of the table      #  either dropped or changed hosts.  Note that the re-read of the table
     #  will take care of new and changed hosts as connections come into being.      #  will take care of new and changed hosts as connections come into being.
   
       &Apache::lonnet::reset_hosts_info();
   
     KillHostHashes;      foreach my $child (keys(%children)) {
     ReadHostTable;  
   
     foreach my $child (keys %children) {  
  my $childip = $children{$child};   my $childip = $children{$child};
  if(!$hostid{$childip}) {   if ($childip ne '127.0.0.1'
       && !defined(&Apache::lonnet::get_hosts_from_ip($childip))) {
     logthis('<font color="blue"> UpdateHosts killing child '      logthis('<font color="blue"> UpdateHosts killing child '
     ." $child for ip $childip </font>");      ." $child for ip $childip </font>");
     kill('INT', $child);      kill('INT', $child);
Line 5045  sub Debug { Line 5702  sub Debug {
 #  #
 sub Reply {  sub Reply {
     my ($fd, $reply, $request) = @_;      my ($fd, $reply, $request) = @_;
     print $fd $reply;      if (ref($reply)) {
     Debug("Request was $request  Reply was $reply");   print $fd $$reply;
    print $fd "\n";
    if ($DEBUG) { Debug("Request was $request  Reply was $$reply"); }
       } else {
    print $fd $reply;
    if ($DEBUG) { Debug("Request was $request  Reply was $reply"); }
       }
     $Transactions++;      $Transactions++;
 }  }
   
Line 5120  sub status { Line 5782  sub status {
     $0='lond: '.$what.' '.$local;      $0='lond: '.$what.' '.$local;
 }  }
   
 # ----------------------------------------------------------- Send USR1 to lonc  
   
 sub reconlonc {  
     my $peerfile=shift;  
     &logthis("Trying to reconnect for $peerfile");  
     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";  
     if (my $fh=IO::File->new("$loncfile")) {  
  my $loncpid=<$fh>;  
         chomp($loncpid);  
         if (kill 0 => $loncpid) {  
     &logthis("lonc at pid $loncpid responding, sending USR1");  
             kill USR1 => $loncpid;  
         } else {  
     &logthis(  
               "<font color='red'>CRITICAL: "  
              ."lonc at pid $loncpid not responding, giving up</font>");  
         }  
     } else {  
       &logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');  
     }  
 }  
   
 # -------------------------------------------------- Non-critical communication  
   
 sub subreply {  
     my ($cmd,$server)=@_;  
     my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};  
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",  
                                       Type    => SOCK_STREAM,  
                                       Timeout => 10)  
        or return "con_lost";  
     print $sclient "sethost:$server:$cmd\n";  
     my $answer=<$sclient>;  
     chomp($answer);  
     if (!$answer) { $answer="con_lost"; }  
     return $answer;  
 }  
   
 sub reply {  
   my ($cmd,$server)=@_;  
   my $answer;  
   if ($server ne $currenthostid) {   
     $answer=subreply($cmd,$server);  
     if ($answer eq 'con_lost') {  
  $answer=subreply("ping",$server);  
         if ($answer ne $server) {  
     &logthis("sub reply: answer != server answer is $answer, server is $server");  
            &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$server});  
         }  
         $answer=subreply($cmd,$server);  
     }  
   } else {  
     $answer='self_reply';  
   }   
   return $answer;  
 }  
   
 # -------------------------------------------------------------- Talk to lonsql  # -------------------------------------------------------------- Talk to lonsql
   
 sub sql_reply {  sub sql_reply {
Line 5245  $SIG{USR1} = \&checkchildren; Line 5850  $SIG{USR1} = \&checkchildren;
 $SIG{USR2} = \&UpdateHosts;  $SIG{USR2} = \&UpdateHosts;
   
 #  Read the host hashes:  #  Read the host hashes:
   &Apache::lonnet::load_hosts_tab();
 ReadHostTable;  
   
 my $dist=`$perlvar{'lonDaemons'}/distprobe`;  my $dist=`$perlvar{'lonDaemons'}/distprobe`;
   
Line 5325  sub make_new_child { Line 5929  sub make_new_child {
 #        my $tmpsnum=0;            # Now global  #        my $tmpsnum=0;            # Now global
 #---------------------------------------------------- kerberos 5 initialization  #---------------------------------------------------- kerberos 5 initialization
         &Authen::Krb5::init_context();          &Authen::Krb5::init_context();
  unless (($dist eq 'fedora4') || ($dist eq 'suse9.3')) {   unless (($dist eq 'fedora5') || ($dist eq 'fedora4') ||  
    ($dist eq 'fedora6') || ($dist eq 'suse9.3')) {
     &Authen::Krb5::init_ets();      &Authen::Krb5::init_ets();
  }   }
   
Line 5335  sub make_new_child { Line 5940  sub make_new_child {
 # -----------------------------------------------------------------------------  # -----------------------------------------------------------------------------
  # see if we know client and 'check' for spoof IP by ineffective challenge   # see if we know client and 'check' for spoof IP by ineffective challenge
   
  ReadManagerTable; # May also be a manager!!  
   
  my $outsideip=$clientip;   my $outsideip=$clientip;
  if ($clientip eq '127.0.0.1') {   if ($clientip eq '127.0.0.1') {
     $outsideip=$hostip{$perlvar{'lonHostID'}};      $outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'});
  }   }
   
  my $clientrec=($hostid{$outsideip}     ne undef);   my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));
  my $ismanager=($managers{$outsideip}    ne undef);   my $ismanager=($managers{$outsideip}    ne undef);
  $clientname  = "[unknonwn]";   $clientname  = "[unknonwn]";
  if($clientrec) { # Establish client type.   if($clientrec) { # Establish client type.
     $ConnectionType = "client";      $ConnectionType = "client";
     $clientname = $hostid{$outsideip};      $clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
     if($ismanager) {      if($ismanager) {
  $ConnectionType = "both";   $ConnectionType = "both";
     }      }
Line 5454  sub make_new_child { Line 6057  sub make_new_child {
     
  if ($clientok) {   if ($clientok) {
 # ---------------- New known client connecting, could mean machine online again  # ---------------- New known client connecting, could mean machine online again
           if (&Apache::lonnet::get_host_ip($currenthostid) ne $clientip 
     foreach my $id (keys(%hostip)) {   && $clientip ne '127.0.0.1') {
  if ($hostip{$id} ne $clientip ||   &Apache::lonnet::reconlonc($clientname);
     $hostip{$currenthostid} eq $clientip) {  
     # no need to try to do recon's to myself  
     next;  
  }  
  &reconlonc("$perlvar{'lonSockDir'}/".$hostname{$id});  
     }      }
     &logthis("<font color='green'>Established connection: $clientname</font>");      &logthis("<font color='green'>Established connection: $clientname</font>");
     &status('Will listen to '.$clientname);      &status('Will listen to '.$clientname);
Line 5664  sub get_auth_type Line 6262  sub get_auth_type
 #     0        - The domain,user,password triplet is not a valid user.  #     0        - The domain,user,password triplet is not a valid user.
 #  #
 sub validate_user {  sub validate_user {
     my ($domain, $user, $password) = @_;      my ($domain, $user, $password, $checkdefauth) = @_;
   
   
     # Why negative ~pi you may well ask?  Well this function is about      # Why negative ~pi you may well ask?  Well this function is about
     # authentication, and therefore very important to get right.      # authentication, and therefore very important to get right.
Line 5688  sub validate_user { Line 6285  sub validate_user {
   
     my $null = pack("C",0); # Used by kerberos auth types.      my $null = pack("C",0); # Used by kerberos auth types.
   
       if ($howpwd eq 'nouser') {
           if ($checkdefauth) {
               my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
               if ($domdefaults{'auth_def'} eq 'localauth') {
                   $howpwd = $domdefaults{'auth_def'};
                   $contentpwd = $domdefaults{'auth_arg_def'};
               } elsif ((($domdefaults{'auth_def'} eq 'krb4') || 
                         ($domdefaults{'auth_def'} eq 'krb5')) &&
                        ($domdefaults{'auth_arg_def'} ne '')) {
                   $howpwd = $domdefaults{'auth_def'};
                   $contentpwd = $domdefaults{'auth_arg_def'}; 
               }
           }
       } 
     if ($howpwd ne 'nouser') {      if ($howpwd ne 'nouser') {
   
  if($howpwd eq "internal") { # Encrypted is in local password file.   if($howpwd eq "internal") { # Encrypted is in local password file.
     $validated = (crypt($password, $contentpwd) eq $contentpwd);      $validated = (crypt($password, $contentpwd) eq $contentpwd);
  }   }
Line 5738  sub validate_user { Line 6348  sub validate_user {
  my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;   my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
  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(&Authen::Krb5::parse_name($user.'@'
  my $krbreturn  = &Authen::Krb5::get_in_tkt_with_password($krbclient,                                                                   .$contentpwd));
  $krbserver,                  my $krbreturn;
  $password,                  if (exists(&Authen::Krb5::get_init_creds_password)) {
  $credentials);                      $krbreturn = 
  $validated = ($krbreturn == 1);                          &Authen::Krb5::get_init_creds_password($krbclient,$password,
                                                                  $krbservice);
                       $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
                   } else {
       $krbreturn  = 
                           &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
    $password,$credentials);
       $validated = ($krbreturn == 1);
                   }
    if (!$validated) {
       &logthis('krb5: '.$user.', '.$contentpwd.', '.
        &Authen::Krb5::error());
    }
     } else {      } else {
  $validated = 0;   $validated = 0;
     }      }
Line 5751  sub validate_user { Line 6373  sub validate_user {
     #  Authenticate via installation specific authentcation method:      #  Authenticate via installation specific authentcation method:
     $validated = &localauth::localauth($user,       $validated = &localauth::localauth($user, 
        $password,          $password, 
        $contentpwd);         $contentpwd,
          $domain);
       if ($validated < 0) {
    &logthis("localauth for $contentpwd $user:$domain returned a $validated");
    $validated = 0;
       }
  } else { # Unrecognized auth is also bad.   } else { # Unrecognized auth is also bad.
     $validated = 0;      $validated = 0;
  }   }
Line 5777  sub addline { Line 6404  sub addline {
     my ($fname,$hostid,$ip,$newline)=@_;      my ($fname,$hostid,$ip,$newline)=@_;
     my $contents;      my $contents;
     my $found=0;      my $found=0;
     my $expr='^'.$hostid.':'.$ip.':';      my $expr='^'.quotemeta($hostid).':'.quotemeta($ip).':';
     $expr =~ s/\./\\\./g;  
     my $sh;      my $sh;
     if ($sh=IO::File->new("$fname.subscription")) {      if ($sh=IO::File->new("$fname.subscription")) {
  while (my $subline=<$sh>) {   while (my $subline=<$sh>) {
Line 5985  sub subscribe { Line 6611  sub subscribe {
                 # the metadata                  # the metadata
  unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }   unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
  $fname=~s/\/home\/httpd\/html\/res/raw/;   $fname=~s/\/home\/httpd\/html\/res/raw/;
  $fname="http://$thisserver/".$fname;   $fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
  $result="$fname\n";   $result="$fname\n";
     }      }
  } else {   } else {
Line 6028  sub change_unix_password { Line 6654  sub change_unix_password {
   
 sub make_passwd_file {  sub make_passwd_file {
     my ($uname, $umode,$npass,$passfilename)=@_;      my ($uname, $umode,$npass,$passfilename)=@_;
     my $result="ok\n";      my $result="ok";
     if ($umode eq 'krb4' or $umode eq 'krb5') {      if ($umode eq 'krb4' or $umode eq 'krb5') {
  {   {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
Line 6096  sub make_passwd_file { Line 6722  sub make_passwd_file {
  if($useraddok > 0) {   if($useraddok > 0) {
     my $error_text = &lcuseraddstrerror($useraddok);      my $error_text = &lcuseraddstrerror($useraddok);
     &logthis("Failed lcuseradd: $error_text");      &logthis("Failed lcuseradd: $error_text");
     $result = "lcuseradd_failed:$error_text\n";      $result = "lcuseradd_failed:$error_text";
  }  else {   }  else {
     my $pf = IO::File->new(">$passfilename");      my $pf = IO::File->new(">$passfilename");
     if($pf) {      if($pf) {
Line 6120  sub make_passwd_file { Line 6746  sub make_passwd_file {
     }      }
  }   }
     } else {      } else {
  $result="auth_mode_error\n";   $result="auth_mode_error";
     }      }
     return $result;      return $result;
 }  }
Line 6139  sub sethost { Line 6765  sub sethost {
     }      }
   
     if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }      if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
     if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {      if (&Apache::lonnet::get_host_ip($perlvar{'lonHostID'}) 
    eq &Apache::lonnet::get_host_ip($hostid)) {
  $currenthostid  =$hostid;   $currenthostid  =$hostid;
  $currentdomainid=$hostdom{$hostid};   $currentdomainid=&Apache::lonnet::host_domain($hostid);
  &logthis("Setting hostid to $hostid, and domain to $currentdomainid");   &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
     } else {      } else {
  &logthis("Requested host id $hostid not an alias of ".   &logthis("Requested host id $hostid not an alias of ".
Line 6157  sub version { Line 6784  sub version {
     return "version:$VERSION";      return "version:$VERSION";
 }  }
   
 #There is a copy of this in lonnet.pm  
 sub userload {  
     my $numusers=0;  
     {  
  opendir(LONIDS,$perlvar{'lonIDsDir'});  
  my $filename;  
  my $curtime=time;  
  while ($filename=readdir(LONIDS)) {  
     if ($filename eq '.' || $filename eq '..') {next;}  
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];  
     if ($curtime-$mtime < 1800) { $numusers++; }  
  }  
  closedir(LONIDS);  
     }  
     my $userloadpercent=0;  
     my $maxuserload=$perlvar{'lonUserLoadLim'};  
     if ($maxuserload) {  
  $userloadpercent=100*$numusers/$maxuserload;  
     }  
     $userloadpercent=sprintf("%.2f",$userloadpercent);  
     return $userloadpercent;  
 }  
   
 # Routines for serializing arrays and hashes (copies from lonnet)  
   
 sub array2str {  
   my (@array) = @_;  
   my $result=&arrayref2str(\@array);  
   $result=~s/^__ARRAY_REF__//;  
   $result=~s/__END_ARRAY_REF__$//;  
   return $result;  
 }  
                                                                                    
 sub arrayref2str {  
   my ($arrayref) = @_;  
   my $result='__ARRAY_REF__';  
   foreach my $elem (@$arrayref) {  
     if(ref($elem) eq 'ARRAY') {  
       $result.=&arrayref2str($elem).'&';  
     } elsif(ref($elem) eq 'HASH') {  
       $result.=&hashref2str($elem).'&';  
     } elsif(ref($elem)) {  
       #print("Got a ref of ".(ref($elem))." skipping.");  
     } else {  
       $result.=&escape($elem).'&';  
     }  
   }  
   $result=~s/\&$//;  
   $result .= '__END_ARRAY_REF__';  
   return $result;  
 }  
                                                                                    
 sub hash2str {  
   my (%hash) = @_;  
   my $result=&hashref2str(\%hash);  
   $result=~s/^__HASH_REF__//;  
   $result=~s/__END_HASH_REF__$//;  
   return $result;  
 }  
                                                                                    
 sub hashref2str {  
   my ($hashref)=@_;  
   my $result='__HASH_REF__';  
   foreach (sort(keys(%$hashref))) {  
     if (ref($_) eq 'ARRAY') {  
       $result.=&arrayref2str($_).'=';  
     } elsif (ref($_) eq 'HASH') {  
       $result.=&hashref2str($_).'=';  
     } elsif (ref($_)) {  
       $result.='=';  
       #print("Got a ref of ".(ref($_))." skipping.");  
     } else {  
         if ($_) {$result.=&escape($_).'=';} else { last; }  
     }  
   
     if(ref($hashref->{$_}) eq 'ARRAY') {  
       $result.=&arrayref2str($hashref->{$_}).'&';  
     } elsif(ref($hashref->{$_}) eq 'HASH') {  
       $result.=&hashref2str($hashref->{$_}).'&';  
     } elsif(ref($hashref->{$_})) {  
        $result.='&';  
       #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");  
     } else {  
       $result.=&escape($hashref->{$_}).'&';  
     }  
   }  
   $result=~s/\&$//;  
   $result .= '__END_HASH_REF__';  
   return $result;  
 }  
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   
Line 6581  linux Line 7118  linux
 Server/Process  Server/Process
   
 =cut  =cut
   
   
   =pod
   
   =head1 LOG MESSAGES
   
   The messages below can be emitted in the lond log.  This log is located
   in ~httpd/perl/logs/lond.log  Many log messages have HTML encapsulation
   to provide coloring if examined from inside a web page. Some do not.
   Where color is used, the colors are; Red for sometihhng to get excited
   about and to follow up on. Yellow for something to keep an eye on to
   be sure it does not get worse, Green,and Blue for informational items.
   
   In the discussions below, sometimes reference is made to ~httpd
   when describing file locations.  There isn't really an httpd 
   user, however there is an httpd directory that gets installed in the
   place that user home directories go.  On linux, this is usually
   (always?) /home/httpd.
   
   
   Some messages are colorless.  These are usually (not always)
   Green/Blue color level messages.
   
   =over 2
   
   =item (Red)  LocalConnection rejecting non local: <ip> ne 127.0.0.1
   
   A local connection negotiation was attempted by
   a host whose IP address was not 127.0.0.1.
   The socket is closed and the child will exit.
   lond has three ways to establish an encyrption
   key with a client:
   
   =over 2
   
   =item local 
   
   The key is written and read from a file.
   This is only valid for connections from localhost.
   
   =item insecure 
   
   The key is generated by the server and
   transmitted to the client.
   
   =item  ssl (secure)
   
   An ssl connection is negotiated with the client,
   the key is generated by the server and sent to the 
   client across this ssl connection before the
   ssl connectionis terminated and clear text
   transmission resumes.
   
   =back
   
   =item (Red) LocalConnection: caller is insane! init = <init> and type = <type>
   
   The client is local but has not sent an initialization
   string that is the literal "init:local"  The connection
   is closed and the child exits.
   
   =item Red CRITICAL Can't get key file <error>        
   
   SSL key negotiation is being attempted but the call to
   lonssl::KeyFile  failed.  This usually means that the
   configuration file is not correctly defining or protecting
   the directories/files lonCertificateDirectory or
   lonnetPrivateKey
   <error> is a string that describes the reason that
   the key file could not be located.
   
   =item (Red) CRITICAL  Can't get certificates <error>  
   
   SSL key negotiation failed because we were not able to retrives our certificate
   or the CA's certificate in the call to lonssl::CertificateFile
   <error> is the textual reason this failed.  Usual reasons:
   
   =over 2
          
   =item Apache config file for loncapa  incorrect:
    
   one of the variables 
   lonCertificateDirectory, lonnetCertificateAuthority, or lonnetCertificate
   undefined or incorrect
   
   =item Permission error:
   
   The directory pointed to by lonCertificateDirectory is not readable by lond
   
   =item Permission error:
   
   Files in the directory pointed to by lonCertificateDirectory are not readable by lond.
   
   =item Installation error:                         
   
   Either the certificate authority file or the certificate have not
   been installed in lonCertificateDirectory.
   
   =item (Red) CRITICAL SSL Socket promotion failed:  <err> 
   
   The promotion of the connection from plaintext to SSL failed
   <err> is the reason for the failure.  There are two
   system calls involved in the promotion (one of which failed), 
   a dup to produce
   a second fd on the raw socket over which the encrypted data
   will flow and IO::SOcket::SSL->new_from_fd which creates
   the SSL connection on the duped fd.
   
   =item (Blue)   WARNING client did not respond to challenge 
   
   This occurs on an insecure (non SSL) connection negotiation request.
   lond generates some number from the time, the PID and sends it to
   the client.  The client must respond by echoing this information back.
   If the client does not do so, that's a violation of the challenge
   protocols and the connection will be failed.
   
   =item (Red) No manager table. Nobody can manage!!    
   
   lond has the concept of privileged hosts that
   can perform remote management function such
   as update the hosts.tab.   The manager hosts
   are described in the 
   ~httpd/lonTabs/managers.tab file.
   this message is logged if this file is missing.
   
   
   =item (Green) Registering manager <dnsname> as <cluster_name> with <ipaddress>
   
   Reports the successful parse and registration
   of a specific manager. 
   
   =item Green existing host <clustername:dnsname>  
   
   The manager host is already defined in the hosts.tab
   the information in that table, rather than the info in the
   manager table will be used to determine the manager's ip.
   
   =item (Red) Unable to craete <filename>                 
   
   lond has been asked to create new versions of an administrative
   file (by a manager).  When this is done, the new file is created
   in a temp file and then renamed into place so that there are always
   usable administrative files, even if the update fails.  This failure
   message means that the temp file could not be created.
   The update is abandoned, and the old file is available for use.
   
   =item (Green) CopyFile from <oldname> to <newname> failed
   
   In an update of administrative files, the copy of the existing file to a
   backup file failed.  The installation of the new file may still succeed,
   but there will not be a back up file to rever to (this should probably
   be yellow).
   
   =item (Green) Pushfile: backed up <oldname> to <newname>
   
   See above, the backup of the old administrative file succeeded.
   
   =item (Red)  Pushfile: Unable to install <filename> <reason>
   
   The new administrative file could not be installed.  In this case,
   the old administrative file is still in use.
   
   =item (Green) Installed new < filename>.                      
   
   The new administrative file was successfullly installed.                                               
   
   =item (Red) Reinitializing lond pid=<pid>                    
   
   The lonc child process <pid> will be sent a USR2 
   signal.
   
   =item (Red) Reinitializing self                                    
   
   We've been asked to re-read our administrative files,and
   are doing so.
   
   =item (Yellow) error:Invalid process identifier <ident>  
   
   A reinit command was received, but the target part of the 
   command was not valid.  It must be either
   'lond' or 'lonc' but was <ident>
   
   =item (Green) isValideditCommand checking: Command = <command> Key = <key> newline = <newline>
   
   Checking to see if lond has been handed a valid edit
   command.  It is possible the edit command is not valid
   in that case there are no log messages to indicate that.
   
   =item Result of password change for  <username> pwchange_success
   
   The password for <username> was
   successfully changed.
   
   =item Unable to open <user> passwd to change password
   
   Could not rewrite the 
   internal password file for a user
   
   =item Result of password change for <user> : <result>
                                                                        
   A unix password change for <user> was attempted 
   and the pipe returned <result>  
   
   =item LWP GET: <message> for <fname> (<remoteurl>)
   
   The lightweight process fetch for a resource failed
   with <message> the local filename that should
   have existed/been created was  <fname> the
   corresponding URI: <remoteurl>  This is emitted in several
   places.
   
   =item Unable to move <transname> to <destname>     
   
   From fetch_user_file_handler - the user file was replicated but could not
   be mv'd to its final location.
   
   =item Looking for <domain> <username>              
   
   From user_has_session_handler - This should be a Debug call instead
   it indicates lond is about to check whether the specified user has a 
   session active on the specified domain on the local host.
   
   =item Client <ip> (<name>) hanging up: <input>     
   
   lond has been asked to exit by its client.  The <ip> and <name> identify the
   client systemand <input> is the full exit command sent to the server.
   
   =item Red CRITICAL: ABNORMAL EXIT. child <pid> for server <hostname> died through a crass with this error->[<message>].
                                                    
   A lond child terminated.  NOte that this termination can also occur when the
   child receives the QUIT or DIE signals.  <pid> is the process id of the child,
   <hostname> the host lond is working for, and <message> the reason the child died
   to the best of our ability to get it (I would guess that any numeric value
   represents and errno value).  This is immediately followed by
   
   =item  Famous last words: Catching exception - <log> 
   
   Where log is some recent information about the state of the child.
   
   =item Red CRITICAL: TIME OUT <pid>                     
   
   Some timeout occured for server <pid>.  THis is normally a timeout on an LWP
   doing an HTTP::GET.
   
   =item child <pid> died                              
   
   The reaper caught a SIGCHILD for the lond child process <pid>
   This should be modified to also display the IP of the dying child
   $children{$pid}
   
   =item Unknown child 0 died                           
   A child died but the wait for it returned a pid of zero which really should not
   ever happen. 
   
   =item Child <which> - <pid> looks like we missed it's death 
   
   When a sigchild is received, the reaper process checks all children to see if they are
   alive.  If children are dying quite quickly, the lack of signal queuing can mean
   that a signal hearalds the death of more than one child.  If so this message indicates
   which other one died. <which> is the ip of a dead child
   
   =item Free socket: <shutdownretval>                
   
   The HUNTSMAN sub was called due to a SIGINT in a child process.  The socket is being shutdown.
   for whatever reason, <shutdownretval> is printed but in fact shutdown() is not documented
   to return anything. This is followed by: 
   
   =item Red CRITICAL: Shutting down                       
   
   Just prior to exit.
   
   =item Free socket: <shutdownretval>                 
   
   The HUPSMAN sub was called due to a SIGHUP.  all children get killsed, and lond execs itself.
   This is followed by:
   
   =item (Red) CRITICAL: Restarting                         
   
   lond is about to exec itself to restart.
   
   =item (Blue) Updating connections                        
   
   (In response to a USR2).  All the children (except the one for localhost)
   are about to be killed, the hosts tab reread, and Apache reloaded via apachereload.
   
   =item (Blue) UpdateHosts killing child <pid> for ip <ip>   
   
   Due to USR2 as above.
   
   =item (Green) keeping child for ip <ip> (pid = <pid>)    
   
   In response to USR2 as above, the child indicated is not being restarted because
   it's assumed that we'll always need a child for the localhost.
   
   
   =item Going to check on the children                
   
   Parent is about to check on the health of the child processes.
   Note that this is in response to a USR1 sent to the parent lond.
   there may be one or more of the next two messages:
   
   =item <pid> is dead                                 
   
   A child that we have in our child hash as alive has evidently died.
   
   =item  Child <pid> did not respond                   
   
   In the health check the child <pid> did not update/produce a pid_.txt
   file when sent it's USR1 signal.  That process is killed with a 9 signal, as it's
   assumed to be hung in some un-fixable way.
   
   =item Finished checking children                   
    
   Master processs's USR1 processing is cojmplete.
   
   =item (Red) CRITICAL: ------- Starting ------            
   
   (There are more '-'s on either side).  Lond has forked itself off to 
   form a new session and is about to start actual initialization.
   
   =item (Green) Attempting to start child (<client>)       
   
   Started a new child process for <client>.  Client is IO::Socket object
   connected to the child.  This was as a result of a TCP/IP connection from a client.
   
   =item Unable to determine who caller was, getpeername returned nothing
                                                     
   In child process initialization.  either getpeername returned undef or
   a zero sized object was returned.  Processing continues, but in my opinion,
   this should be cause for the child to exit.
   
   =item Unable to determine clientip                  
   
   In child process initialization.  The peer address from getpeername was not defined.
   The client address is stored as "Unavailable" and processing continues.
   
   =item (Yellow) INFO: Connection <ip> <name> connection type = <type>
                                                     
   In child initialization.  A good connectionw as received from <ip>.
   
   =over 2
   
   =item <name> 
   
   is the name of the client from hosts.tab.
   
   =item <type> 
   
   Is the connection type which is either 
   
   =over 2
   
   =item manager 
   
   The connection is from a manager node, not in hosts.tab
   
   =item client  
   
   the connection is from a non-manager in the hosts.tab
   
   =item both
   
   The connection is from a manager in the hosts.tab.
   
   =back
   
   =back
   
   =item (Blue) Certificates not installed -- trying insecure auth
   
   One of the certificate file, key file or
   certificate authority file could not be found for a client attempting
   SSL connection intiation.  COnnection will be attemptied in in-secure mode.
   (this would be a system with an up to date lond that has not gotten a 
   certificate from us).
   
   =item (Green)  Successful local authentication            
   
   A local connection successfully negotiated the encryption key. 
   In this case the IDEA key is in a file (that is hopefully well protected).
   
   =item (Green) Successful ssl authentication with <client>  
   
   The client (<client> is the peer's name in hosts.tab), has successfully
   negotiated an SSL connection with this child process.
   
   =item (Green) Successful insecure authentication with <client>
                                                      
   
   The client has successfully negotiated an  insecure connection withthe child process.
   
   =item (Yellow) Attempted insecure connection disallowed    
   
   The client attempted and failed to successfully negotiate a successful insecure
   connection.  This can happen either because the variable londAllowInsecure is false
   or undefined, or becuse the child did not successfully echo back the challenge
   string.
   
   
   =back
   
   
   =cut
Removed from v.1.344  
changed lines
  Added in v.1.409

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