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

Diff for /loncom/lond between versions 1.327 and 1.390

version 1.327, 2006/05/18 02:17:27 version 1.390, 2007/11/12 22:54:42
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.
   
 my $status='';  my $status='';
 my $lastlog='';  my $lastlog='';
 my $lond_max_wait_time = 13;  
   
 my $VERSION='$Revision$'; #' stupid emacs  my $VERSION='$Revision$'; #' stupid emacs
 my $remoteVERSION;  my $remoteVERSION;
Line 70  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 86  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 143  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 179  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 425  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 443  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 504  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 836  sub AdjustOurHost { Line 825  sub AdjustOurHost {
     #   Use the config line to get my hostname.      #   Use the config line to get my hostname.
     #   Use gethostbyname to translate that into an IP address.      #   Use gethostbyname to translate that into an IP address.
     #      #
     my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);      my ($id,$domain,$role,$name,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
     my $BinaryIp = gethostbyname($name);  
     my $ip       = inet_ntoa($ip);  
     #      #
     #  Reassemble the config line from the elements in the list.      #  Reassemble the config line from the elements in the list.
     #  Note that if the loncnew items were not present before, they will      #  Note that if the loncnew items were not present before, they will
     #  be now even if they would be empty      #  be now even if they would be empty
     #      #
     my $newConfigLine = $id;      my $newConfigLine = $id;
     foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {      foreach my $item ($domain, $role, $name, $maxcon, $idleto, $mincon) {
  $newConfigLine .= ":".$item;   $newConfigLine .= ":".$item;
     }      }
     #  Replace the line:      #  Replace the line:
Line 891  sub EditFile { Line 878  sub EditFile {
   
     #  Split the command into it's pieces:  edit:filetype:script      #  Split the command into it's pieces:  edit:filetype:script
   
     my ($request, $filetype, $script) = split(/:/, $request,3); # : in script      my ($cmd, $filetype, $script) = split(/:/, $request,3); # : in script
   
     #  Check the pre-coditions for success:      #  Check the pre-coditions for success:
   
     if($request != "edit") { # Something is amiss afoot alack.      if($cmd != "edit") { # Something is amiss afoot alack.
  return "error:edit request detected, but request != 'edit'\n";   return "error:edit request detected, but request != 'edit'\n";
     }      }
     if( ($filetype ne "hosts")  &&      if( ($filetype ne "hosts")  &&
Line 940  sub EditFile { Line 927  sub EditFile {
     return "ok\n";      return "ok\n";
 }  }
   
 #---------------------------------------------------------------  
 #  
 # Manipulation of hash based databases (factoring out common code  
 # for later use as we refactor.  
 #  
 #  Ties a domain level resource file to a hash.  
 #  If requested a history entry is created in the associated hist file.  
 #  
 #  Parameters:  
 #     domain    - Name of the domain in which the resource file lives.  
 #     namespace - Name of the hash within that domain.  
 #     how       - How to tie the hash (e.g. GDBM_WRCREAT()).  
 #     loghead   - Optional parameter, if present a log entry is created  
 #                 in the associated history file and this is the first part  
 #                  of that entry.  
 #     logtail   - Goes along with loghead,  The actual logentry is of the  
 #                 form $loghead:<timestamp>:logtail.  
 # Returns:  
 #    Reference to a hash bound to the db file or alternatively undef  
 #    if the tie failed.  
 #  
 sub tie_domain_hash {  
     my ($domain,$namespace,$how,$loghead,$logtail) = @_;  
       
     # Filter out any whitespace in the domain name:  
       
     $domain =~ s/\W//g;  
       
     # We have enough to go on to tie the hash:  
       
     my $user_top_dir   = $perlvar{'lonUsersDir'};  
     my $domain_dir     = $user_top_dir."/$domain";  
     my $resource_file  = $domain_dir."/$namespace";  
     return &_locking_hash_tie($resource_file,$namespace,$how,$loghead,$logtail);  
 }  
   
 sub untie_domain_hash {  
     return &_locking_hash_untie(@_);  
 }  
 #  
 #   Ties a user's resource file to a hash.    
 #   If necessary, an appropriate history  
 #   log file entry is made as well.  
 #   This sub factors out common code from the subs that manipulate  
 #   the various gdbm files that keep keyword value pairs.  
 # Parameters:  
 #   domain       - Name of the domain the user is in.  
 #   user         - Name of the 'current user'.  
 #   namespace    - Namespace representing the file to tie.  
 #   how          - What the tie is done to (e.g. GDBM_WRCREAT().  
 #   loghead      - Optional first part of log entry if there may be a  
 #                  history file.  
 #   what         - Optional tail of log entry if there may be a history  
 #                  file.  
 # Returns:  
 #   hash to which the database is tied.  It's up to the caller to untie.  
 #   undef if the has could not be tied.  
 #  
 sub tie_user_hash {  
     my ($domain,$user,$namespace,$how,$loghead,$what) = @_;  
   
     $namespace=~s/\//\_/g; # / -> _  
     $namespace=~s/\W//g; # whitespace eliminated.  
     my $proname     = propath($domain, $user);  
   
     my $file_prefix="$proname/$namespace";  
     return &_locking_hash_tie($file_prefix,$namespace,$how,$loghead,$what);  
 }  
   
 sub untie_user_hash {  
     return &_locking_hash_untie(@_);  
 }  
   
 # internal routines that handle the actual tieing and untieing process  
   
 sub _do_hash_tie {  
     my ($file_prefix,$namespace,$how,$loghead,$what) = @_;  
     my %hash;  
     if(tie(%hash, 'GDBM_File', "$file_prefix.db", $how, 0640)) {  
  # If this is a namespace for which a history is kept,  
  # make the history log entry:      
  if (($namespace !~/^nohist\_/) && (defined($loghead))) {  
     my $args = scalar @_;  
     Debug(" Opening history: $file_prefix $args");  
     my $hfh = IO::File->new(">>$file_prefix.hist");   
     if($hfh) {  
  my $now = time;  
  print $hfh "$loghead:$now:$what\n";  
     }  
     $hfh->close;  
  }  
  return \%hash;  
     } else {  
  return undef;  
     }  
 }  
   
 sub _do_hash_untie {  
     my ($hashref) = @_;  
     my $result = untie(%$hashref);  
     return $result;  
 }  
   
 {  
     my $sym;  
   
     sub _locking_hash_tie {  
  my ($file_prefix,$namespace,$how,$loghead,$what) = @_;  
         my $lock_type=LOCK_SH;  
 # Are we reading or writing?  
         if ($how eq &GDBM_READER()) {  
 # We are reading  
            unless (open($sym,"$file_prefix.db.lock")) {  
 # We don't have a lock file. This could mean  
 # - that there is no such db-file  
 # - that it does not have a lock file yet  
                unless ((-e "$file_prefix.db") || (-e "$file_prefix.db.gz")) {  
 # No such file. Forget it.                  
                    $! = 2;  
                    return undef;  
                }  
 # Apparently just no lock file yet. Make one  
                open($sym,">>$file_prefix.db.lock");  
            }   
         } elsif ($how eq &GDBM_WRCREAT()) {  
 # We are writing  
            open($sym,">>$file_prefix.db.lock");  
 # Writing needs exclusive lock  
            $lock_type=LOCK_EX;  
         } else {  
            &logthis("Unknown method $how for $file_prefix");  
            die();  
         }  
 # If this is compressed, we will also need an exclusive lock  
        if (-e "$file_prefix.db.gz") { $lock_type=LOCK_EX; }  
 # Okay, try to obtain the lock we want  
        my $failed=0;  
        eval {  
            local $SIG{__DIE__}='DEFAULT';  
            local $SIG{ALRM}=sub {  
                $failed=1;  
                die("failed lock");  
            };  
            alarm($lond_max_wait_time);  
            flock($sym,$lock_type);  
            alarm(0);  
        };  
        if ($failed) {  
            $! = 100; # throwing error # 100  
            return undef;  
        }  
 # The file is ours!  
 # If it is archived, un-archive it now  
        if (-e "$file_prefix.db.gz") {  
            system("gunzip $file_prefix.db.gz");  
    if (-e "$file_prefix.hist.gz") {  
        system("gunzip $file_prefix.hist.gz");  
    }  
        }  
 # Change access mode to non-blocking  
        $how=$how|&GDBM_NOLOCK();  
 # Go ahead and tie the hash  
        return &_do_hash_tie($file_prefix,$namespace,$how,$loghead,$what);  
     }  
   
     sub _locking_hash_untie {  
  my ($hashref) = @_;  
  my $result = untie(%$hashref);  
  flock($sym,LOCK_UN);  
  close($sym);  
  undef($sym);  
  return $result;  
     }  
 }  
   
 #   read_profile  #   read_profile
 #  #
 #   Returns a set of specific entries from a user's profile file.  #   Returns a set of specific entries from a user's profile file.
Line 1184  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 1210  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 1254  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 1291  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 1320  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 1364  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 1400  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 1428  sub push_file_handler { Line 1240  sub push_file_handler {
 #  #
 sub du_handler {  sub du_handler {
     my ($cmd, $ududir, $client) = @_;      my ($cmd, $ududir, $client) = @_;
     my ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.      ($ududir) = split(/:/,$ududir); # Make 'telnet' testing easier.
     my $userinput = "$cmd:$ududir";      my $userinput = "$cmd:$ududir";
   
     if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {      if ($ududir=~/\.\./ || $ududir!~m|^/home/httpd/|) {
Line 1446  sub du_handler { Line 1258  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 1520  sub ls_handler { Line 1333  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;
   
Line 1589  sub ls2_handler { Line 1402  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);
Line 1617  sub reinit_process_handler { Line 1430  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 1752  sub change_password_handler { Line 1565  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 1781  sub change_password_handler { Line 1601  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 1846  sub add_user_handler { Line 1666  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 1915  sub change_authentication_handler { Line 1735  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 1936  sub change_authentication_handler { Line 1756  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 2020  sub update_resource_handler { Line 1840  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");
     } 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 2070  sub devalidate_meta_cache { Line 1891  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 2284  sub rename_user_file_handler { Line 2095  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 2300  sub token_auth_user_file_handler { Line 2142  sub token_auth_user_file_handler {
           
     chomp($session);      chomp($session);
     my $reply="non_auth\n";      my $reply="non_auth\n";
     if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.      my $file = $perlvar{'lonIDsDir'}.'/'.$session.'.id';
      $session.'.id')) {      if (open(ENVIN,"$file")) {
  while (my $line=<ENVIN>) {   flock(ENVIN,LOCK_SH);
     if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply="ok\n"; }   tie(my %disk_env,'GDBM_File',"$file",&GDBM_READER(),0640);
    if (exists($disk_env{"userfile.$fname"})) {
       $reply="ok\n";
    } else {
       foreach my $envname (keys(%disk_env)) {
    if ($envname=~ m|^userfile\.\Q$fname\E|) {
       $reply="ok\n";
       last;
    }
       }
  }   }
    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 2366  sub subscribe_handler { Line 2218  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 2730  sub get_profile_entry { Line 2582  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 2767  sub get_profile_entry_encrypted { Line 2620  sub get_profile_entry_encrypted {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
         
     my ($cmd,$udom,$uname,$namespace,$what) = split(/:/,$userinput);      my ($udom,$uname,$namespace,$what) = split(/:/,$tail);
     chomp($what);      chomp($what);
     my $qresult = read_profile($udom, $uname, $namespace, $what);      my $qresult = read_profile($udom, $uname, $namespace, $what);
     my ($first) = split(/:/, $qresult);      my ($first) = split(/:/, $qresult);
Line 2873  sub get_profile_keys { Line 2726  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 2943  sub dump_profile_database { Line 2796  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 3026  sub dump_with_regexp { Line 2879  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 3212  sub restore_handler { Line 3065  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 ($cmd,$udom,$uname,$namespace,$rid) = split(/:/,$userinput);  
     $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 3234  sub restore_handler { Line 3087  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 3315  sub retrieve_chat_handler { Line 3168  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 3388  sub reply_query_handler { Line 3241  sub reply_query_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($cmd,$id,$reply)=split(/:/,$userinput);       my ($id,$reply)=split(/:/,$tail); 
     my $store;      my $store;
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     if ($store=IO::File->new(">$execdir/tmp/$id")) {      if ($store=IO::File->new(">$execdir/tmp/$id")) {
Line 3452  sub put_course_id_handler { Line 3305  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]} = $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 == 1) { # flushcourselogs() from 1.1 or earlier                  if ($numnew <= $numcurrent) { # flushcourselogs() from pre 2.2 
                     $courseinfo .= ':'.join(':',@current_items);                      for (my $j=$numcurrent-$numnew; $j>=0; $j--) {
                 } elsif ($numnew == 2) { # flushcourselogs() from 1.2.X                          $courseinfo .= ':'.$current_items[$numcurrent-$j-1];
                     $courseinfo .= ':'.$current_items[$numcurrent-1];                      }
                 }                  }
             }              }
     $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 3481  sub put_course_id_handler { Line 3351  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 3508  sub put_course_id_handler { Line 3420  sub put_course_id_handler {
 #                 institutional code - optional supplied code to filter   #                 institutional code - optional supplied code to filter 
 #                            the dump. Only courses with an institutional code   #                            the dump. Only courses with an institutional code 
 #                            that match the supplied code will be returned.  #                            that match the supplied code will be returned.
 #                 owner    - optional supplied username of owner to filter  #                 owner    - optional supplied username and domain of owner to
 #                            the dump.  Only courses for which the course   #                            filter the dump.  Only courses for which the course
 #                            owner matches the supplied username will be  #                            owner matches the supplied username and/or domain
 #                            returned. Implicit assumption that owner  #                            will be returned. Pre-2.2.0 legacy entries from 
 #                            is a user in the domain in which the  #                            nohist_courseiddump will only contain usernames.
 #                            course database is defined.  #                 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.
   #    
 #     $client  - The socket open on the client.  #     $client  - The socket open on the client.
 # Returns:  # Returns:
 #    1     - Continue processing.  #    1     - Continue processing.
Line 3521  sub put_course_id_handler { Line 3441  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) =split(/:/,$tail);      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
           $typefilter,$regexp_ok,$rtn_as_hash) =split(/:/,$tail);
     if (defined($description)) {      if (defined($description)) {
  $description=&unescape($description);   $description=&unescape($description);
     } else {      } else {
Line 3535  sub dump_course_id_handler { Line 3455  sub dump_course_id_handler {
     } else {      } else {
         $instcodefilter='.';          $instcodefilter='.';
     }      }
       my ($ownerunamefilter,$ownerdomfilter);
     if (defined($ownerfilter)) {      if (defined($ownerfilter)) {
         $ownerfilter=&unescape($ownerfilter);          $ownerfilter=&unescape($ownerfilter);
           if ($ownerfilter ne '.' && defined($ownerfilter)) {
               if ($ownerfilter =~ /^([^:]*):([^:]*)$/) {
                    $ownerunamefilter = $1;
                    $ownerdomfilter = $2;
               } else {
                   $ownerunamefilter = $ownerfilter;
                   $ownerdomfilter = '';
               }
           }
     } else {      } else {
         $ownerfilter='.';          $ownerfilter='.';
     }      }
   
     if (defined($coursefilter)) {      if (defined($coursefilter)) {
         $coursefilter=&unescape($coursefilter);          $coursefilter=&unescape($coursefilter);
     } else {      } else {
         $coursefilter='.';          $coursefilter='.';
     }      }
       if (defined($typefilter)) {
     unless (defined($since)) { $since=0; }          $typefilter=&unescape($typefilter);
       } else {
           $typefilter='.';
       }
       if (defined($regexp_ok)) {
           $regexp_ok=&unescape($regexp_ok);
       }
       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);              my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,%unesc_val);
             my @courseitems = split(/:/,$value);              $unesc_key = &unescape($key);
             $lasttime = pop(@courseitems);              if ($unesc_key =~ /^lasttime:/) {
     ($descr,$inst_code,$owner)=@courseitems;                  next;
     if ($lasttime<$since) { 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'};
                   }
               } else {
                   $is_hash =  0;
                   my @courseitems = split(/:/,$value);
                   $lasttime = pop(@courseitems);
                   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) {
                 unless (eval('$unescapeInstcode=~/\Q$instcodefilter\E/i')) {                      $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
                     $match = 0;                  }
                   if ($regexp_ok) {
                       if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
                           $match = 0;
                       }
                   } else {
                       if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
                           $match = 0;
                       }
                 }                  }
     }      }
             unless ($ownerfilter eq '.' || !defined($ownerfilter)) {              if ($ownerfilter ne '.') {
                 my $unescapeOwner = &unescape($owner);                  if (!$is_hash) {
                 unless (eval('$unescapeOwner=~/\Q$ownerfilter\E/i')) {                      $unesc_val{'owner'} = &unescape($val{'owner'});
                     $match = 0;                  }
                   if (($ownerunamefilter ne '') && ($ownerdomfilter ne '')) {
                       if ($unesc_val{'owner'} =~ /:/) {
                           if (eval{$unesc_val{'owner'} !~ 
                                /\Q$ownerunamefilter\E:\Q$ownerdomfilter\E$/i}) {
                               $match = 0;
                           } 
                       } else {
                           if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                               $match = 0;
                           }
                       }
                   } elsif ($ownerunamefilter ne '') {
                       if ($unesc_val{'owner'} =~ /:/) {
                           if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E:[^:]+$/i}) {
                                $match = 0;
                           }
                       } else {
                           if (eval{$unesc_val{'owner'} !~ /\Q$ownerunamefilter\E/i}) {
                               $match = 0;
                           }
                       }
                   } elsif ($ownerdomfilter ne '') {
                       if ($unesc_val{'owner'} =~ /:/) {
                           if (eval{$unesc_val{'owner'} !~ /^[^:]+:\Q$ownerdomfilter\E/}) {
                                $match = 0;
                           }
                       } else {
                           if ($ownerdomfilter ne $udom) {
                               $match = 0;
                           }
                       }
                 }                  }
             }              }
             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;
                 }                  }
             }              }
               if ($typefilter ne '.') {
                   if (!$is_hash) {
                       $unesc_val{'type'} = &unescape($val{'type'});
                   }
                   if ($unesc_val{'type'} eq '') {
                       if ($typefilter ne 'Course') {
                           $match = 0;
                       }
                   } else {
                       if (eval{$unesc_val{'type'} !~ /^\Q$typefilter\E$/}) {
                           $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 3596  sub dump_course_id_handler { Line 3636  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 3685  sub get_id_handler { Line 3816  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 3809  sub dump_dcmail_handler { Line 3940  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 3927  sub dump_domainroles_handler { Line 4058  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 3937  sub dump_domainroles_handler { Line 4068  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 3973  sub tmp_put_handler { Line 4104  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 4017  sub tmp_get_handler { Line 4156  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 4198  sub enrollment_enabled_handler { Line 4337  sub enrollment_enabled_handler {
     my $userinput = $cmd.":".$tail; # For logging purposes.      my $userinput = $cmd.":".$tail; # For logging purposes.
   
           
     my $cdom = split(/:/, $tail);   # 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 4227  sub get_sections_handler { Line 4367  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 4254  sub validate_course_owner_handler { Line 4394  sub validate_course_owner_handler {
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
     my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);      my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);
   
       $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 4286  sub validate_course_section_handler { Line 4427  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 4294  sub validate_course_section_handler { Line 4435  sub validate_course_section_handler {
 &register_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);  &register_handler("autovalidatecourse", \&validate_course_section_handler, 0, 1, 0);
   
 #  #
 #   Create a password for a new auto-enrollment user.  #   Validate course owner's access to enrollment data for specific class section. 
 #   I think/guess, this password allows access to the institutions   #   
 #   AIS class list server/services.  Stuart can correct this comment  
 #   when he finds out how wrong I am.  
 #  #
 # Formal Parameters:  # Formal Parameters:
 #    $cmd     - The command request that got us dispatched.  #    $cmd     - The command request that got us dispatched.
 #    $tail    - The tail of the command.   In this case this is a colon separated  #    $tail    - The tail of the command.   In this case this is a colon separated
 #               set of words that will be split into:  #               set of words that will be split into:
 #               $authparam - An authentication parameter (username??).  #               $inst_class  - Institutional code for the specific class section   
   #               $courseowner - The escaped username:domain of the course owner 
   #               $cdom        - The domain of the course from the institution's
   #                              point of view.
   #    $client  - The socket open on the client.
   # Returns:
   #    1 - continue processing.
   #
   
   sub validate_class_access_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($inst_class,$ownerlist,$cdom) = split(/:/, $tail);
       my @owners = split(/,/,&unescape($ownerlist));
       my $outcome;
       eval {
    local($SIG{__DIE__})='DEFAULT';
    $outcome=&localenroll::check_section($inst_class,\@owners,$cdom);
       };
       &Reply($client,\$outcome, $userinput);
   
       return 1;
   }
   &register_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0);
   
   #
   #   Create a password for a new LON-CAPA user added by auto-enrollment.
   #   Only used for case where authentication method for new user is localauth
   #
   # Formal Parameters:
   #    $cmd     - The command request that got us dispatched.
   #    $tail    - The tail of the command.   In this case this is a colon separated
   #               set of words that will be split into:
   #               $authparam - An authentication parameter (localauth parameter).
 #               $cdom      - The domain of the course from the institution's  #               $cdom      - The domain of the course from the institution's
 #                            point of view.  #                            point of view.
 #    $client  - The socket open on the client.  #    $client  - The socket open on the client.
Line 4410  sub get_institutional_code_format_handle Line 4582  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 4430  sub get_institutional_code_format_handle Line 4602  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 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);
   
 # 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 4557  sub student_photo_handler { Line 4887  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 4820  sub catchexception { Line 5179  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 4931  sub HUPSMAN {                      # sig Line 5290  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 5022  sub UpdateHosts { Line 5320  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 5113  sub Debug { Line 5410  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 5188  sub status { Line 5490  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 5269  sub sub_sql_reply { Line 5514  sub sub_sql_reply {
     return $answer;      return $answer;
 }  }
   
 # -------------------------------------------- Return path to profile directory  
   
 sub propath {  
     my ($udom,$uname)=@_;  
     $udom=~s/\W//g;  
     $uname=~s/\W//g;  
     my $subdir=$uname.'__';  
     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;  
     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";  
     return $proname;  
 }   
   
 # --------------------------------------- Is this the home server of an author?  # --------------------------------------- Is this the home server of an author?
   
 sub ishome {  sub ishome {
Line 5325  $SIG{USR1} = \&checkchildren; Line 5558  $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 5405  sub make_new_child { Line 5637  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 5415  sub make_new_child { Line 5648  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 5446  sub make_new_child { Line 5677  sub make_new_child {
     my $remotereq=<$client>;      my $remotereq=<$client>;
     chomp($remotereq);      chomp($remotereq);
     Debug("Got init: $remotereq");      Debug("Got init: $remotereq");
     my $inikeyword = split(/:/, $remotereq);  
     if ($remotereq =~ /^init/) {      if ($remotereq =~ /^init/) {
  &sethost("sethost:$perlvar{'lonHostID'}");   &sethost("sethost:$perlvar{'lonHostID'}");
  #   #
Line 5534  sub make_new_child { Line 5765  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 5818  sub validate_user { Line 6044  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.'@'
                                                                    .$contentpwd));
  my $krbreturn  = &Authen::Krb5::get_in_tkt_with_password($krbclient,   my $krbreturn  = &Authen::Krb5::get_in_tkt_with_password($krbclient,
  $krbserver,   $krbserver,
  $password,   $password,
  $credentials);   $credentials);
  $validated = ($krbreturn == 1);   $validated = ($krbreturn == 1);
    if (!$validated) {
       &logthis('krb5: '.$user.', '.$contentpwd.', '.
        &Authen::Krb5::error());
    }
     } else {      } else {
  $validated = 0;   $validated = 0;
     }      }
Line 5831  sub validate_user { Line 6062  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 5857  sub addline { Line 6093  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 5879  sub get_chat { Line 6114  sub get_chat {
     my @entries=();      my @entries=();
     my $namespace = 'nohist_chatroom';      my $namespace = 'nohist_chatroom';
     my $namespace_inroom = 'nohist_inchatroom';      my $namespace_inroom = 'nohist_inchatroom';
     if (defined($group)) {      if ($group ne '') {
         $namespace .= '_'.$group;          $namespace .= '_'.$group;
         $namespace_inroom .= '_'.$group;          $namespace_inroom .= '_'.$group;
     }      }
Line 5911  sub chat_add { Line 6146  sub chat_add {
     my $time=time;      my $time=time;
     my $namespace = 'nohist_chatroom';      my $namespace = 'nohist_chatroom';
     my $logfile = 'chatroom.log';      my $logfile = 'chatroom.log';
     if (defined($group)) {      if ($group ne '') {
         $namespace .= '_'.$group;          $namespace .= '_'.$group;
         $logfile = 'chatroom_'.$group.'.log';          $logfile = 'chatroom_'.$group.'.log';
     }      }
Line 6065  sub subscribe { Line 6300  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 6108  sub change_unix_password { Line 6343  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 6176  sub make_passwd_file { Line 6411  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 6200  sub make_passwd_file { Line 6435  sub make_passwd_file {
     }      }
  }   }
     } else {      } else {
  $result="auth_mode_error\n";   $result="auth_mode_error";
     }      }
     return $result;      return $result;
 }  }
Line 6219  sub sethost { Line 6454  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 6237  sub version { Line 6473  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)
   
Removed from v.1.327  
changed lines
  Added in v.1.390

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