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

Diff for /loncom/lond between versions 1.318.2.3 and 1.384

version 1.318.2.3, 2006/02/09 20:48:40 version 1.384, 2007/10/06 04:32:23
Line 31 Line 31
   
 use strict;  use strict;
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
   use LONCAPA;
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
   use Apache::lonnet;
   
 use IO::Socket;  use IO::Socket;
 use IO::File;  use IO::File;
 #use Apache::File;  #use Apache::File;
 use Symbol;  
 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 Symbol;  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 71  my $clientip;   # IP address of client. Line 70  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 87  my $tmpsnum = 0;  # Id of tmpputs. Line 85  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 144  my @adderrors    = ("ok", Line 136  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 180  sub ResetStatistics { Line 172  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 426  sub ReadManagerTable { Line 415  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 444  sub ReadManagerTable { Line 433  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 505  sub AdjustHostContents { Line 494  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 837  sub AdjustOurHost { Line 826  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 892  sub EditFile { Line 879  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 941  sub EditFile { Line 928  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);  
       
  if ($how eq &GDBM_READER()) {  
     $lock=LOCK_SH;  
     $how=$how|&GDBM_NOLOCK();  
     #if the db doesn't exist we can't read from it  
     if (! -e "$file_prefix.db") {  
  $! = 2;  
  return undef;  
     }  
  } elsif ($how eq &GDBM_WRCREAT()) {  
     $lock=LOCK_EX;  
     $how=$how|&GDBM_NOLOCK();  
     if (! -e "$file_prefix.db") {  
  # doesn't exist but we need it to in order to successfully  
                 # lock it so bring it into existance  
  open(TOUCH,">>$file_prefix.db");  
  close(TOUCH);  
     }  
  } else {  
     &logthis("Unknown method $how for $file_prefix");  
     die();  
  }  
       
  $sym=&Symbol::gensym();  
  open($sym,"$file_prefix.db");  
  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);  
     alarm(0);  
  };  
  if ($failed) {  
     $! = 100; # throwing error # 100  
     return undef;  
  }  
  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 1199  sub ping_handler { Line 1023  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 1309  sub load_handler { Line 1133  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\n", "$cmd:$tail");
           
     return 1;      return 1;
Line 1417  sub push_file_handler { Line 1241  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 1435  sub du_handler { Line 1259  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);
Line 1741  sub change_password_handler { Line 1566  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 1770  sub change_password_handler { Line 1602  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);
Line 2009  sub update_resource_handler { Line 1841  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 2059  sub devalidate_meta_cache { Line 1892  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 2273  sub rename_user_file_handler { Line 2096  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 2289  sub token_auth_user_file_handler { Line 2143  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 {
Line 2355  sub subscribe_handler { Line 2219  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 2756  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 2915  sub dump_profile_database { Line 2779  sub dump_profile_database {
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
     my ($v,$symb,$param) = split(/:/,$key);      my ($v,$symb,$param) = split(/:/,$key);
     next if ($v eq 'version' || $symb eq 'keys');      next if ($v eq 'version' || $symb eq 'keys');
     if (!defined($param)) {      next if (exists($data{$symb}) && 
  foreach my $pair (split(/\&/,$value)) {       exists($data{$symb}->{$param}) &&
     my ($param,$value)=split(/=/,$pair);       $data{$symb}->{'v.'.$param} > $v);
     next if (exists($data{$symb}) &&       $data{$symb}->{$param}=$value;
      exists($data{$symb}->{$param}) &&      $data{$symb}->{'v.'.$param}=$v;
      $data{$symb}->{'v.'.$param} > $v);  
     $data{$symb}->{$param}=$value;  
     $data{$symb}->{'v.'.$param}=$v;  
  }  
     } else {  
  next if (exists($data{$symb}) &&   
  exists($data{$symb}->{$param}) &&  
  $data{$symb}->{'v.'.$param} > $v);  
  $data{$symb}->{$param}=$value;  
  $data{$symb}->{'v.'.$param}=$v;  
     }  
  }   }
  if (&untie_user_hash($hashref)) {   if (&untie_user_hash($hashref)) {
     while (my ($symb,$param_hash) = each(%data)) {      while (my ($symb,$param_hash) = each(%data)) {
Line 3079  sub store_handler { Line 2932  sub store_handler {
     my $version=$hashref->{"version:$rid"};      my $version=$hashref->{"version:$rid"};
     my $allkeys='';       my $allkeys=''; 
     foreach my $pair (@pairs) {      foreach my $pair (@pairs) {
  my ($key)=split(/=/,$pair);   my ($key,$value)=split(/=/,$pair);
  $allkeys.=$key.':';   $allkeys.=$key.':';
    $hashref->{"$version:$rid:$key"}=$value;
     }      }
     $hashref->{"$version:$rid"}=$what."\&timestamp=$now";      $hashref->{"$version:$rid:timestamp"}=$now;
     $allkeys.='timestamp';      $allkeys.='timestamp';
     $hashref->{"$version:keys:$rid"}=$allkeys;      $hashref->{"$version:keys:$rid"}=$allkeys;
     if (&untie_user_hash($hashref)) {      if (&untie_user_hash($hashref)) {
Line 3103  sub store_handler { Line 2957  sub store_handler {
 }  }
 &register_handler("store", \&store_handler, 0, 1, 0);  &register_handler("store", \&store_handler, 0, 1, 0);
   
   #  Modify a set of key=value pairs associated with a versioned name.
   #
   #  Parameters:
   #    $cmd                - Request command keyword.
   #    $tail               - Tail of the request.  This is a colon
   #                          separated list containing:
   #                          domain/user - User and authentication domain.
   #                          namespace   - Name of the database being modified
   #                          rid         - Resource keyword to modify.
   #                          v           - Version item to modify
   #                          what        - new value associated with rid.
   #
   #    $client             - Socket open on the client.
   #
   #
   #  Returns:
   #      1 (keep on processing).
   #  Side-Effects:
   #    Writes to the client
   sub putstore_handler {
       my ($cmd, $tail, $client) = @_;
    
       my $userinput = "$cmd:$tail";
   
       my ($udom,$uname,$namespace,$rid,$v,$what) =split(/:/,$tail);
       if ($namespace ne 'roles') {
   
    chomp($what);
    my $hashref  = &tie_user_hash($udom, $uname, $namespace,
          &GDBM_WRCREAT(), "M",
          "$rid:$v:$what");
    if ($hashref) {
       my $now = time;
       my %data = &hash_extract($what);
       my @allkeys;
       while (my($key,$value) = each(%data)) {
    push(@allkeys,$key);
    $hashref->{"$v:$rid:$key"} = $value;
       }
       my $allkeys = join(':',@allkeys);
       $hashref->{"$v:keys:$rid"}=$allkeys;
   
       if (&untie_user_hash($hashref)) {
    &Reply($client, "ok\n", $userinput);
       } else {
    &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
    "while attempting store\n", $userinput);
       }
    } else {
       &Failure( $client, "error: ".($!+0)." tie(GDBM) Failed ".
        "while attempting store\n", $userinput);
    }
       } else {
    &Failure($client, "refused\n", $userinput);
       }
   
       return 1;
   }
   &register_handler("putstore", \&putstore_handler, 0, 1, 0);
   
   sub hash_extract {
       my ($str)=@_;
       my %hash;
       foreach my $pair (split(/\&/,$str)) {
    my ($key,$value)=split(/=/,$pair);
    $hash{$key}=$value;
       }
       return (%hash);
   }
   sub hash_to_str {
       my ($hash_ref)=@_;
       my $str;
       foreach my $key (keys(%$hash_ref)) {
    $str.=$key.'='.$hash_ref->{$key}.'&';
       }
       $str=~s/\&$//;
       return $str;
   }
   
 #  #
 #  Dump out all versions of a resource that has key=value pairs associated  #  Dump out all versions of a resource that has key=value pairs associated
 # with it for each version.  These resources are built up via the store  # with it for each version.  These resources are built up via the store
Line 3132  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 3148  sub restore_handler { Line 3081  sub restore_handler {
     my @keys=split(/:/,$vkeys);      my @keys=split(/:/,$vkeys);
     my $key;      my $key;
     $qresult.="$scope:keys=$vkeys&";      $qresult.="$scope:keys=$vkeys&";
     if (exists($hashref->{"$scope:$rid"})) {      foreach $key (@keys) {
  my $what=$hashref->{"$scope:$rid"};   $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";
  foreach my $pair (split(/\&/,$hashref->{"$scope:$rid"})) {      }                                  
     my ($key,$value)=split(/=/,$pair);  
     $qresult.="$scope:".$pair."&";  
  }  
     } else {  
  foreach $key (@keys) {  
     $qresult.="$scope:$key=".$hashref->{"$scope:$rid:$key"}."&";  
  }  
     }  
  }   }
  if (&untie_user_hash($hashref)) {   if (&untie_user_hash($hashref)) {
     $qresult=~s/\&$//;      $qresult=~s/\&$//;
Line 3179  sub restore_handler { Line 3104  sub restore_handler {
 &register_handler("restore", \&restore_handler, 0,1,0);  &register_handler("restore", \&restore_handler, 0,1,0);
   
 #  #
 #   Add a chat message to to a discussion board.  #   Add a chat message to a synchronous discussion board.
 #  #
 # Parameters:  # Parameters:
 #    $cmd                - Request keyword.  #    $cmd                - Request keyword.
 #    $tail               - Tail of the command. A colon separated list  #    $tail               - Tail of the command. A colon separated list
 #                          containing:  #                          containing:
 #                          cdom    - Domain on which the chat board lives  #                          cdom    - Domain on which the chat board lives
 #                          cnum    - Identifier of the discussion group.  #                          cnum    - Course containing the chat board.
 #                          post    - Body of the posting.  #                          newpost - Body of the posting.
   #                          group   - Optional group, if chat board is only 
   #                                    accessible in a group within the course 
 #   $client              - Socket open on the client.  #   $client              - Socket open on the client.
 # Returns:  # Returns:
 #   1    - Indicating caller should keep on processing.  #   1    - Indicating caller should keep on processing.
Line 3202  sub send_chat_handler { Line 3129  sub send_chat_handler {
           
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($cdom,$cnum,$newpost)=split(/\:/,$tail);      my ($cdom,$cnum,$newpost,$group)=split(/\:/,$tail);
     &chat_add($cdom,$cnum,$newpost);      &chat_add($cdom,$cnum,$newpost,$group);
     &Reply($client, "ok\n", $userinput);      &Reply($client, "ok\n", $userinput);
   
     return 1;      return 1;
Line 3211  sub send_chat_handler { Line 3138  sub send_chat_handler {
 &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);  &register_handler("chatsend", \&send_chat_handler, 0, 1, 0);
   
 #  #
 #   Retrieve the set of chat messagss from a discussion board.  #   Retrieve the set of chat messages from a discussion board.
 #  #
 #  Parameters:  #  Parameters:
 #    $cmd             - Command keyword that initiated the request.  #    $cmd             - Command keyword that initiated the request.
Line 3221  sub send_chat_handler { Line 3148  sub send_chat_handler {
 #                       chat id        - Discussion thread(?)  #                       chat id        - Discussion thread(?)
 #                       domain/user    - Authentication domain and username  #                       domain/user    - Authentication domain and username
 #                                        of the requesting person.  #                                        of the requesting person.
   #                       group          - Optional course group containing
   #                                        the board.      
 #   $client           - Socket open on the client program.  #   $client           - Socket open on the client program.
 # Returns:  # Returns:
 #    1     - continue processing  #    1     - continue processing
Line 3233  sub retrieve_chat_handler { Line 3162  sub retrieve_chat_handler {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($cdom,$cnum,$udom,$uname)=split(/\:/,$tail);      my ($cdom,$cnum,$udom,$uname,$group)=split(/\:/,$tail);
     my $reply='';      my $reply='';
     foreach (&get_chat($cdom,$cnum,$udom,$uname)) {      foreach (&get_chat($cdom,$cnum,$udom,$uname,$group)) {
  $reply.=&escape($_).':';   $reply.=&escape($_).':';
     }      }
     $reply=~s/\:$//;      $reply=~s/\:$//;
Line 3312  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 3376  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 3405  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 3432  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 3445  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 3459  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(/:/,&unescape($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' => &escape($val{'descr'}),
                                           'inst_code' => &escape($val{'inst_code'}),
                                           'owner'     => &escape($val{'owner'}),
                                           'type'      => &escape($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)) {
Line 3520  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\n", $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 3897  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\n", $userinput);
     } else {      } else {
Line 4122  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\n", $userinput);
   
Line 4178  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\n", $userinput);
   
Line 4218  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:
   #    $cmd     - The command request that got us dispatched.
   #    $tail    - The tail of the command.   In this case this is a colon separated
   #               set of words that will be split into:
   #               $inst_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\n", $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:  # 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??).  #               $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 4334  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 4354  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."\n",$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."\n",$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 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."\n",$userinput);
           } else {
               &Reply($client,"error\n", $userinput);
           }
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
   }
   &register_handler("instrulecheck",\&institutional_username_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 4366  sub photo_permission_handler { Line 4710  sub photo_permission_handler {
     my $userinput               = "$cmd:$tail";      my $userinput               = "$cmd:$tail";
     my $cdom = $tail;      my $cdom = $tail;
     my ($perm_reqd,$conditions);      my ($perm_reqd,$conditions);
     my $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,      my $outcome;
  \$conditions);      eval {
     &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",   local($SIG{__DIE__})='DEFAULT';
    $userinput);   $outcome = &localenroll::photo_permission($cdom,\$perm_reqd,
     \$conditions);
       };
       if (!$@) {
    &Reply($client, &escape($outcome.':'.$perm_reqd.':'. $conditions)."\n",
          $userinput);
       } else {
    &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
 }  }
 &register_handler("autophotopermission",\&photo_permission_handler,0,1,0);  &register_handler("autophotopermission",\&photo_permission_handler,0,1,0);
   
Line 4394  sub photo_check_handler { Line 4747  sub photo_check_handler {
     my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);      my $result = &localstudentphoto::fetch($udom,$uname,$pid,\$response);
     $result .= ':'.$response;      $result .= ':'.$response;
     &Reply($client, &escape($result)."\n",$userinput);      &Reply($client, &escape($result)."\n",$userinput);
       return 1;
 }  }
 &register_handler("autophotocheck",\&photo_check_handler,0,1,0);  &register_handler("autophotocheck",\&photo_check_handler,0,1,0);
   
Line 4407  sub photo_choice_handler { Line 4761  sub photo_choice_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
     my $userinput             = "$cmd:$tail";      my $userinput             = "$cmd:$tail";
     my $cdom                  = &unescape($tail);      my $cdom                  = &unescape($tail);
     my ($update,$comment) = &localenroll::manager_photo_update($cdom);      my ($update,$comment);
     &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);      eval {
    local($SIG{__DIE__})='DEFAULT';
    ($update,$comment)    = &localenroll::manager_photo_update($cdom);
       };
       if (!$@) {
    &Reply($client,&escape($update).':'.&escape($comment)."\n",$userinput);
       } else {
    &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
 }  }
 &register_handler("autophotochoice",\&photo_choice_handler,0,1,0);  &register_handler("autophotochoice",\&photo_choice_handler,0,1,0);
   
Line 4441  sub student_photo_handler { Line 4804  sub student_photo_handler {
     &mkpath($path);      &mkpath($path);
     my $file;      my $file;
     if ($type eq 'thumbnail') {      if ($type eq 'thumbnail') {
         $file=&localstudentphoto::fetch_thumbnail($domain,$uname);   eval {
       local($SIG{__DIE__})='DEFAULT';
       $file=&localstudentphoto::fetch_thumbnail($domain,$uname);
    };
     } else {      } else {
         $file=&localstudentphoto::fetch($domain,$uname);          $file=&localstudentphoto::fetch($domain,$uname);
     }      }
Line 4459  sub student_photo_handler { Line 4825  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\n", $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 4511  sub process_request { Line 4906  sub process_request {
                                 # fix all the userinput -> user_input.                                  # fix all the userinput -> user_input.
     my $wasenc    = 0; # True if request was encrypted.      my $wasenc    = 0; # True if request was encrypted.
 # ------------------------------------------------------------ See if encrypted  # ------------------------------------------------------------ See if encrypted
       # for command
       # sethost:<server>
       # <command>:<args>
       #   we just send it to the processor
       # for
       # sethost:<server>:<command>:<args>
       #  we do the implict set host and then do the command
       if ($userinput =~ /^sethost:/) {
    (my $cmd,my $newid,$userinput) = split(':',$userinput,3);
    if (defined($userinput)) {
       &sethost("$cmd:$newid");
    } else {
       $userinput = "$cmd:$newid";
    }
       }
   
     if ($userinput =~ /^enc/) {      if ($userinput =~ /^enc/) {
  $userinput = decipher($userinput);   $userinput = decipher($userinput);
  $wasenc=1;   $wasenc=1;
Line 4706  sub catchexception { Line 5117  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 4817  sub HUPSMAN {                      # sig Line 5228  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 4908  sub UpdateHosts { Line 5258  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 5074  sub status { Line 5423  sub status {
     $0='lond: '.$what.' '.$local;      $0='lond: '.$what.' '.$local;
 }  }
   
 # -------------------------------------------------------- Escape Special Chars  
   
 sub escape {  
     my $str=shift;  
     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;  
     return $str;  
 }  
   
 # ----------------------------------------------------- Un-Escape Special Chars  
   
 sub unescape {  
     my $str=shift;  
     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     return $str;  
 }  
   
 # ----------------------------------------------------------- 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 5164  sub sub_sql_reply { Line 5440  sub sub_sql_reply {
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";         or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "$cmd:$currentdomainid\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
     if (!$answer) { $answer="con_lost"; }      if (!$answer) { $answer="con_lost"; }
     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 5227  $SIG{USR1} = \&checkchildren; Line 5491  $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 5307  sub make_new_child { Line 5570  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 5317  sub make_new_child { Line 5581  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 5348  sub make_new_child { Line 5610  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 5436  sub make_new_child { Line 5698  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 5499  sub is_author { Line 5756  sub is_author {
   
     #  Author role should show up as a key /domain/_au      #  Author role should show up as a key /domain/_au
   
     my $key   = "/$domain/_au";      my $key    = "/$domain/_au";
     my $value = $hashref->{$key};      my $value;
       if (defined($hashref)) {
    $value = $hashref->{$key};
       }
   
     if(defined($value)) {      if(defined($value)) {
  &Debug("$user @ $domain is an author");   &Debug("$user @ $domain is an author");
Line 5717  sub validate_user { Line 5977  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 5730  sub validate_user { Line 5995  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 5756  sub addline { Line 6026  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 5773  sub addline { Line 6042  sub addline {
 }  }
   
 sub get_chat {  sub get_chat {
     my ($cdom,$cname,$udom,$uname)=@_;      my ($cdom,$cname,$udom,$uname,$group)=@_;
   
     my @entries=();      my @entries=();
     my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',      my $namespace = 'nohist_chatroom';
       my $namespace_inroom = 'nohist_inchatroom';
       if ($group ne '') {
           $namespace .= '_'.$group;
           $namespace_inroom .= '_'.$group;
       }
       my $hashref = &tie_user_hash($cdom, $cname, $namespace,
  &GDBM_READER());   &GDBM_READER());
     if ($hashref) {      if ($hashref) {
  @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));   @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
Line 5784  sub get_chat { Line 6059  sub get_chat {
     }      }
     my @participants=();      my @participants=();
     my $cutoff=time-60;      my $cutoff=time-60;
     $hashref = &tie_user_hash($cdom, $cname, 'nohist_inchatroom',      $hashref = &tie_user_hash($cdom, $cname, $namespace_inroom,
       &GDBM_WRCREAT());        &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
         $hashref->{$uname.':'.$udom}=time;          $hashref->{$uname.':'.$udom}=time;
Line 5799  sub get_chat { Line 6074  sub get_chat {
 }  }
   
 sub chat_add {  sub chat_add {
     my ($cdom,$cname,$newchat)=@_;      my ($cdom,$cname,$newchat,$group)=@_;
     my @entries=();      my @entries=();
     my $time=time;      my $time=time;
     my $hashref = &tie_user_hash($cdom, $cname, 'nohist_chatroom',      my $namespace = 'nohist_chatroom';
       my $logfile = 'chatroom.log';
       if ($group ne '') {
           $namespace .= '_'.$group;
           $logfile = 'chatroom_'.$group.'.log';
       }
       my $hashref = &tie_user_hash($cdom, $cname, $namespace,
  &GDBM_WRCREAT());   &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
  @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));   @entries=map { $_.':'.$hashref->{$_} } sort(keys(%$hashref));
Line 5825  sub chat_add { Line 6106  sub chat_add {
  }   }
  {   {
     my $proname=&propath($cdom,$cname);      my $proname=&propath($cdom,$cname);
     if (open(CHATLOG,">>$proname/chatroom.log")) {       if (open(CHATLOG,">>$proname/$logfile")) { 
  print CHATLOG ("$time:".&unescape($newchat)."\n");   print CHATLOG ("$time:".&unescape($newchat)."\n");
     }      }
     close(CHATLOG);      close(CHATLOG);
Line 5952  sub subscribe { Line 6233  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 6100  sub convert_photo { Line 6381  sub convert_photo {
 sub sethost {  sub sethost {
     my ($remotereq) = @_;      my ($remotereq) = @_;
     my (undef,$hostid)=split(/:/,$remotereq);      my (undef,$hostid)=split(/:/,$remotereq);
       # ignore sethost if we are already correct
       if ($hostid eq $currenthostid) {
    return 'ok';
       }
   
     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 6119  sub version { Line 6406  sub version {
     return "version:$VERSION";      return "version:$VERSION";
 }  }
   
 #There is a copy of this in lonnet.pm  
 sub userload {  
     my $numusers=0;  
     {  
  opendir(LONIDS,$perlvar{'lonIDsDir'});  
  my $filename;  
  my $curtime=time;  
  while ($filename=readdir(LONIDS)) {  
     if ($filename eq '.' || $filename eq '..') {next;}  
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];  
     if ($curtime-$mtime < 1800) { $numusers++; }  
  }  
  closedir(LONIDS);  
     }  
     my $userloadpercent=0;  
     my $maxuserload=$perlvar{'lonUserLoadLim'};  
     if ($maxuserload) {  
  $userloadpercent=100*$numusers/$maxuserload;  
     }  
     $userloadpercent=sprintf("%.2f",$userloadpercent);  
     return $userloadpercent;  
 }  
   
 # Routines for serializing arrays and hashes (copies from lonnet)  
   
 sub array2str {  
   my (@array) = @_;  
   my $result=&arrayref2str(\@array);  
   $result=~s/^__ARRAY_REF__//;  
   $result=~s/__END_ARRAY_REF__$//;  
   return $result;  
 }  
                                                                                    
 sub arrayref2str {  
   my ($arrayref) = @_;  
   my $result='__ARRAY_REF__';  
   foreach my $elem (@$arrayref) {  
     if(ref($elem) eq 'ARRAY') {  
       $result.=&arrayref2str($elem).'&';  
     } elsif(ref($elem) eq 'HASH') {  
       $result.=&hashref2str($elem).'&';  
     } elsif(ref($elem)) {  
       #print("Got a ref of ".(ref($elem))." skipping.");  
     } else {  
       $result.=&escape($elem).'&';  
     }  
   }  
   $result=~s/\&$//;  
   $result .= '__END_ARRAY_REF__';  
   return $result;  
 }  
                                                                                    
 sub hash2str {  
   my (%hash) = @_;  
   my $result=&hashref2str(\%hash);  
   $result=~s/^__HASH_REF__//;  
   $result=~s/__END_HASH_REF__$//;  
   return $result;  
 }  
                                                                                    
 sub hashref2str {  
   my ($hashref)=@_;  
   my $result='__HASH_REF__';  
   foreach (sort(keys(%$hashref))) {  
     if (ref($_) eq 'ARRAY') {  
       $result.=&arrayref2str($_).'=';  
     } elsif (ref($_) eq 'HASH') {  
       $result.=&hashref2str($_).'=';  
     } elsif (ref($_)) {  
       $result.='=';  
       #print("Got a ref of ".(ref($_))." skipping.");  
     } else {  
         if ($_) {$result.=&escape($_).'=';} else { last; }  
     }  
   
     if(ref($hashref->{$_}) eq 'ARRAY') {  
       $result.=&arrayref2str($hashref->{$_}).'&';  
     } elsif(ref($hashref->{$_}) eq 'HASH') {  
       $result.=&hashref2str($hashref->{$_}).'&';  
     } elsif(ref($hashref->{$_})) {  
        $result.='&';  
       #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");  
     } else {  
       $result.=&escape($hashref->{$_}).'&';  
     }  
   }  
   $result=~s/\&$//;  
   $result .= '__END_HASH_REF__';  
   return $result;  
 }  
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   
Line 6525  to the client, and the connection is clo Line 6722  to the client, and the connection is clo
 IO::Socket  IO::Socket
 IO::File  IO::File
 Apache::File  Apache::File
 Symbol  
 POSIX  POSIX
 Crypt::IDEA  Crypt::IDEA
 LWP::UserAgent()  LWP::UserAgent()
Removed from v.1.318.2.3  
changed lines
  Added in v.1.384

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