Diff for /loncom/lond between versions 1.409 and 1.452

version 1.409, 2008/10/07 10:08:06 version 1.452, 2010/08/18 19:25:09
Line 42  use Crypt::IDEA; Line 42  use Crypt::IDEA;
 use LWP::UserAgent();  use LWP::UserAgent();
 use Digest::MD5 qw(md5_hex);  use Digest::MD5 qw(md5_hex);
 use GDBM_File;  use GDBM_File;
 use Authen::Krb4;  
 use Authen::Krb5;  use Authen::Krb5;
 use localauth;  use localauth;
 use localenroll;  use localenroll;
Line 67  my $currentdomainid; Line 66  my $currentdomainid;
 my $client;  my $client;
 my $clientip; # IP address of client.  my $clientip; # IP address of client.
 my $clientname; # LonCAPA name of client.  my $clientname; # LonCAPA name of client.
   my $clientversion;              # LonCAPA version running on client.
   my $clienthomedom;              # LonCAPA domain of homeID for client. 
                                   # primary library server. 
   
 my $server;  my $server;
   
Line 142  my @adderrors    = ("ok", Line 144  my @adderrors    = ("ok",
     "lcuseradd Password mismatch");      "lcuseradd Password mismatch");
   
   
   # This array are the errors from lcinstallfile:
   
   my @installerrors = ("ok",
        "Initial user id of client not that of www",
        "Usage error, not enough command line arguments",
        "Source file name does not exist",
        "Destination file name does not exist",
        "Some file operation failed",
        "Invalid table filename."
        );
   
 #  #
 #   Statistics that are maintained and dislayed in the status line.  #   Statistics that are maintained and dislayed in the status line.
Line 398  sub isClient { Line 410  sub isClient {
 #  #
 sub ReadManagerTable {  sub ReadManagerTable {
   
       &Debug("Reading manager table");
     #   Clean out the old table first..      #   Clean out the old table first..
   
    foreach my $key (keys %managers) {     foreach my $key (keys %managers) {
Line 520  sub AdjustHostContents { Line 533  sub AdjustHostContents {
 }  }
 #  #
 #   InstallFile: Called to install an administrative file:  #   InstallFile: Called to install an administrative file:
 #       - The file is created with <name>.tmp  #       - The file is created int a temp directory called <name>.tmp
 #       - The <name>.tmp file is then mv'd to <name>  #       - lcinstall file is called to install the file.
 #   This lugubrious procedure is done to ensure that we are never without  #         since the web app has no direct write access to the table directory
 #   a valid, even if dated, version of the file regardless of who crashes  
 #   and when the crash occurs.  
 #  #
 #  Parameters:  #  Parameters:
 #       Name of the file  #       Name of the file
Line 532  sub AdjustHostContents { Line 543  sub AdjustHostContents {
 #  Return:  #  Return:
 #      nonzero - success.  #      nonzero - success.
 #      0       - failure and $! has an errno.  #      0       - failure and $! has an errno.
   # Assumptions:
   #    File installtion is a relatively infrequent
 #  #
 sub InstallFile {  sub InstallFile {
   
     my ($Filename, $Contents) = @_;      my ($Filename, $Contents) = @_;
     my $TempFile = $Filename.".tmp";  #     my $TempFile = $Filename.".tmp";
       my $exedir = $perlvar{'lonDaemons'};
       my $tmpdir = $exedir.'/tmp/';
       my $TempFile = $tmpdir."TempTableFile.tmp";
   
     #  Open the file for write:      #  Open the file for write:
   
Line 550  sub InstallFile { Line 566  sub InstallFile {
     print $fh ($Contents);       print $fh ($Contents); 
     $fh->close; # In case we ever have a filesystem w. locking      $fh->close; # In case we ever have a filesystem w. locking
   
     chmod(0660, $TempFile);      chmod(0664, $TempFile); # Everyone can write it.
   
     # Now we can move install the file in position.      # Use lcinstall file to put the file in the table directory...
       
     move($TempFile, $Filename);      &Debug("Opening pipe to $exedir/lcinstallfile $TempFile $Filename");
       my $pf = IO::File->new("| $exedir/lcinstallfile   $TempFile $Filename > $exedir/logs/lcinstallfile.log");
       close $pf;
       my $err = $?;
       &Debug("Status is $err");
       if ($err != 0) {
    my $msg = $err;
    if ($err < @installerrors) {
       $msg = $installerrors[$err];
    }
    &logthis("Install failed for table file $Filename : $msg");
    return 0;
       }
   
       # Remove the temp file:
   
       unlink($TempFile);
   
     return 1;      return 1;
 }  }
Line 562  sub InstallFile { Line 594  sub InstallFile {
   
 #  #
 #   ConfigFileFromSelector: converts a configuration file selector  #   ConfigFileFromSelector: converts a configuration file selector
 #                 (one of host or domain at this point) into a   #                 into a configuration file pathname.
 #                 configuration file pathname.  #                 It's probably no longer necessary to preserve
   #                 special handling of hosts or domain as those
   #                 files have been superceded by dns_hosts, dns_domain.
   #                 The default action is just to prepend the directory
   #                 and append .tab
   #
 #  #
 #  Parameters:  #  Parameters:
 #      selector  - Configuration file selector.  #      selector  - Configuration file selector.
Line 580  sub ConfigFileFromSelector { Line 617  sub ConfigFileFromSelector {
     } elsif ($selector eq "domain") {      } elsif ($selector eq "domain") {
  $tablefile = $tabledir."domain.tab";   $tablefile = $tabledir."domain.tab";
     } else {      } else {
  return undef;   $tablefile =  $tabledir.$selector.'.tab';
     }      }
     return $tablefile;      return $tablefile;
   
Line 603  sub ConfigFileFromSelector { Line 640  sub ConfigFileFromSelector {
 sub PushFile {  sub PushFile {
     my $request = shift;          my $request = shift;    
     my ($command, $filename, $contents) = split(":", $request, 3);      my ($command, $filename, $contents) = split(":", $request, 3);
       &Debug("PushFile");
           
     #  At this point in time, pushes for only the following tables are      #  At this point in time, pushes for only the following tables are
     #  supported:      #  supported:
Line 619  sub PushFile { Line 657  sub PushFile {
     if(! (defined $tablefile)) {      if(! (defined $tablefile)) {
  return "refused";   return "refused";
     }      }
     #  
     # >copy< the old table to the backup table  
     #        don't rename in case system crashes/reboots etc. in the time  
     #        window between a rename and write.  
     #  
     my $backupfile = $tablefile;  
     $backupfile    =~ s/\.tab$/.old/;  
     if(!CopyFile($tablefile, $backupfile)) {  
  &logthis('<font color="green"> CopyFile from '.$tablefile." to ".$backupfile." failed </font>");  
  return "error:$!";  
     }  
     &logthis('<font color="green"> Pushfile: backed up '  
     .$tablefile." to $backupfile</font>");  
       
     #  If the file being pushed is the host file, we adjust the entry for ourself so that the      #  If the file being pushed is the host file, we adjust the entry for ourself so that the
     #  IP will be our current IP as looked up in dns.  Note this is only 99% good as it's possible      #  IP will be our current IP as looked up in dns.  Note this is only 99% good as it's possible
     #  to conceive of conditions where we don't have a DNS entry locally.  This is possible in a       #  to conceive of conditions where we don't have a DNS entry locally.  This is possible in a 
Line 645  sub PushFile { Line 670  sub PushFile {
   
     #  Install the new file:      #  Install the new file:
   
       &logthis("Installing new $tablefile contents:\n$contents");
     if(!InstallFile($tablefile, $contents)) {      if(!InstallFile($tablefile, $contents)) {
  &logthis('<font color="red"> Pushfile: unable to install '   &logthis('<font color="red"> Pushfile: unable to install '
  .$tablefile." $! </font>");   .$tablefile." $! </font>");
Line 951  sub read_profile { Line 977  sub read_profile {
  &GDBM_READER());   &GDBM_READER());
     if ($hashref) {      if ($hashref) {
         my @queries=split(/\&/,$what);          my @queries=split(/\&/,$what);
           if ($namespace eq 'roles') {
               @queries = map { &unescape($_); } @queries; 
           }
         my $qresult='';          my $qresult='';
   
  for (my $i=0;$i<=$#queries;$i++) {   for (my $i=0;$i<=$#queries;$i++) {
Line 1044  sub pong_handler { Line 1073  sub pong_handler {
 #  Implicit Inputs:  #  Implicit Inputs:
 #      $currenthostid - Global variable that carries the name of the host  #      $currenthostid - Global variable that carries the name of the host
 #                       known as.  #                       known as.
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  #      $clientname    - Global variable that carries the name of the host we're connected to.
 #  Returns:  #  Returns:
 #      1       - Ok to continue processing.  #      1       - Ok to continue processing.
 #      0       - Program should exit.  #      0       - Program should exit.
Line 1083  sub establish_key_handler { Line 1112  sub establish_key_handler {
 #  Implicit Inputs:  #  Implicit Inputs:
 #      $currenthostid - Global variable that carries the name of the host  #      $currenthostid - Global variable that carries the name of the host
 #                       known as.  #                       known as.
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  #      $clientname    - Global variable that carries the name of the host we're connected to.
 #  Returns:  #  Returns:
 #      1       - Ok to continue processing.  #      1       - Ok to continue processing.
 #      0       - Program should exit.  #      0       - Program should exit.
Line 1120  sub load_handler { Line 1149  sub load_handler {
 #  Implicit Inputs:  #  Implicit Inputs:
 #      $currenthostid - Global variable that carries the name of the host  #      $currenthostid - Global variable that carries the name of the host
 #                       known as.  #                       known as.
 #      $clientname    - Global variable that carries the name of the hsot we're connected to.  #      $clientname    - Global variable that carries the name of the host we're connected to.
 #  Returns:  #  Returns:
 #      1       - Ok to continue processing.  #      1       - Ok to continue processing.
 #      0       - Program should exit  #      0       - Program should exit
Line 1198  sub user_authorization_type { Line 1227  sub user_authorization_type {
 #    a reply is written to the client.  #    a reply is written to the client.
 sub push_file_handler {  sub push_file_handler {
     my ($cmd, $tail, $client) = @_;      my ($cmd, $tail, $client) = @_;
       &Debug("In push file handler");
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     # At this time we only know that the IP of our partner is a valid manager      # At this time we only know that the IP of our partner is a valid manager
Line 1206  sub push_file_handler { Line 1235  sub push_file_handler {
     # spoofing).      # spoofing).
   
     my $cert = &GetCertificate($userinput);      my $cert = &GetCertificate($userinput);
     if(&ValidManager($cert)) {       if(&ValidManager($cert)) {
    &Debug("Valid manager: $client");
   
  # Now presumably we have the bona fides of both the peer host and the   # Now presumably we have the bona fides of both the peer host and the
  # process making the request.   # process making the request.
Line 1215  sub push_file_handler { Line 1245  sub push_file_handler {
  &Reply($client, \$reply, $userinput);   &Reply($client, \$reply, $userinput);
   
     } else {      } else {
    &logthis("push_file_handler $client is not valid");
  &Failure( $client, "refused\n", $userinput);   &Failure( $client, "refused\n", $userinput);
     }       } 
     return 1;      return 1;
Line 1587  sub ls3_handler { Line 1618  sub ls3_handler {
 }  }
 &register_handler("ls3", \&ls3_handler, 0, 1, 0);  &register_handler("ls3", \&ls3_handler, 0, 1, 0);
   
   sub server_timezone_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       my $timezone;
       my $clockfile = '/etc/sysconfig/clock'; # Fedora/CentOS/SuSE
       my $tzfile = '/etc/timezone'; # Debian/Ubuntu
       if (-e $clockfile) {
           if (open(my $fh,"<$clockfile")) {
               while (<$fh>) {
                   next if (/^[\#\s]/);
                   if (/^(?:TIME)?ZONE\s*=\s*['"]?\s*([\w\/]+)/) {
                       $timezone = $1;
                       last;
                   }
               }
               close($fh);
           }
       } elsif (-e $tzfile) {
           if (open(my $fh,"<$tzfile")) {
               $timezone = <$fh>;
               close($fh);
               chomp($timezone);
               if ($timezone =~ m{^Etc/(\w+)$}) {
                   $timezone = $1;
               }
           }
       }
       &Reply($client,\$timezone,$userinput); # This supports debug logging.
       return 1;
   }
   &register_handler("servertimezone", \&server_timezone_handler, 0, 1, 0);
   
   sub server_loncaparev_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       &Reply($client,\$perlvar{'lonVersion'},$userinput);
       return 1;
   }
   &register_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);
   
   sub server_homeID_handler {
       my ($cmd,$tail,$client) = @_;
       my $userinput = "$cmd:$tail";
       &Reply($client,\$perlvar{'lonHostID'},$userinput);
       return 1;
   }
   &register_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0);
   
 #   Process a reinit request.  Reinit requests that either  #   Process a reinit request.  Reinit requests that either
 #   lonc or lond be reinitialized so that an updated   #   lonc or lond be reinitialized so that an updated 
 #   host.tab or domain.tab can be processed.  #   host.tab or domain.tab can be processed.
Line 1696  sub authenticate_handler { Line 1775  sub authenticate_handler {
     #  upass   - User's password.      #  upass   - User's password.
     #  checkdefauth - Pass to validate_user() to try authentication      #  checkdefauth - Pass to validate_user() to try authentication
     #                 with default auth type(s) if no user account.      #                 with default auth type(s) if no user account.
       #  clientcancheckhost - Passed by clients with functionality in lonauth.pm
       #                       to check if session can be hosted.
           
     my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);      my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail);
     &Debug(" Authenticate domain = $udom, user = $uname, password = $upass,  checkdefauth = $checkdefauth");      &Debug(" Authenticate domain = $udom, user = $uname, password = $upass,  checkdefauth = $checkdefauth");
     chomp($upass);      chomp($upass);
     $upass=&unescape($upass);      $upass=&unescape($upass);
   
     my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);      my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
     if($pwdcorrect) {      if($pwdcorrect) {
  &Reply( $client, "authorized\n", $userinput);          my $canhost = 1;
           unless ($clientcancheckhost) {
               my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
               my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
               my @intdoms;
               my $internet_names = &Apache::lonnet::get_internet_names($clientname);
               if (ref($internet_names) eq 'ARRAY') {
                   @intdoms = @{$internet_names};
               }
               unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
                   my ($remote,$hosted);
                   my $remotesession = &get_usersession_config($udom,'remotesession');
                   if (ref($remotesession) eq 'HASH') {
                       $remote = $remotesession->{'remote'}
                   }
                   my $hostedsession = &get_usersession_config($clienthomedom,'hostedsession');
                   if (ref($hostedsession) eq 'HASH') {
                       $hosted = $hostedsession->{'hosted'};
                   }
                   my $loncaparev = $clientversion;
                   if ($loncaparev eq '') {
                       $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
                   }
                   $canhost = &Apache::lonnet::can_host_session($udom,$clientname,
                                                                $loncaparev,
                                                                $remote,$hosted);
               }
           }
           if ($canhost) {               
               &Reply( $client, "authorized\n", $userinput);
           } else {
               &Reply( $client, "not_allowed_to_host\n", $userinput);
           }
  #   #
  #  Bad credentials: Failed to authorize   #  Bad credentials: Failed to authorize
  #   #
Line 1749  sub change_password_handler { Line 1862  sub change_password_handler {
     #  npass - New password.      #  npass - New password.
     #  context - Context in which this was called       #  context - Context in which this was called 
     #            (preferences or reset_by_email).      #            (preferences or reset_by_email).
       #  lonhost - HostID of server where request originated 
         
     my ($udom,$uname,$upass,$npass,$context)=split(/:/,$tail);      my ($udom,$uname,$upass,$npass,$context,$lonhost)=split(/:/,$tail);
   
     $upass=&unescape($upass);      $upass=&unescape($upass);
     $npass=&unescape($npass);      $npass=&unescape($npass);
Line 1759  sub change_password_handler { Line 1873  sub change_password_handler {
     # First require that the user can be authenticated with their      # First require that the user can be authenticated with their
     # old password unless context was 'reset_by_email':      # old password unless context was 'reset_by_email':
           
     my $validated;      my ($validated,$failure);
     if ($context eq 'reset_by_email') {      if ($context eq 'reset_by_email') {
         $validated = 1;          if ($lonhost eq '') {
               $failure = 'invalid_client';
           } else {
               $validated = 1;
           }
     } else {      } else {
         $validated = &validate_user($udom, $uname, $upass);          $validated = &validate_user($udom, $uname, $upass);
     }      }
Line 1775  sub change_password_handler { Line 1893  sub change_password_handler {
     $salt=substr($salt,6,2);      $salt=substr($salt,6,2);
     my $ncpass=crypt($npass,$salt);      my $ncpass=crypt($npass,$salt);
     if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {      if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {
  &logthis("Result of password change for "   my $msg="Result of password change for $uname: pwchange_success";
  ."$uname: pwchange_success");                  if ($lonhost) {
                       $msg .= " - request originated from: $lonhost";
                   }
                   &logthis($msg);
  &Reply($client, "ok\n", $userinput);   &Reply($client, "ok\n", $userinput);
     } else {      } else {
  &logthis("Unable to open $uname passwd "                  &logthis("Unable to open $uname passwd "               
Line 1797  sub change_password_handler { Line 1918  sub change_password_handler {
  }     }  
   
     } else {      } else {
  &Failure( $client, "non_authorized\n", $userinput);   if ($failure eq '') {
       $failure = 'non_authorized';
    }
    &Failure( $client, "$failure\n", $userinput);
     }      }
   
     return 1;      return 1;
Line 1984  sub is_home_handler { Line 2108  sub is_home_handler {
 &register_handler("home", \&is_home_handler, 0,1,0);  &register_handler("home", \&is_home_handler, 0,1,0);
   
 #  #
 #   Process an update request for a resource?? I think what's going on here is  #   Process an update request for a resource.
 #   that a resource has been modified that we hold a subscription to.  #   A resource has been modified that we hold a subscription to.
 #   If the resource is not local, then we must update, or at least invalidate our  #   If the resource is not local, then we must update, or at least invalidate our
 #   cached copy of the resource.   #   cached copy of the resource. 
 #   FUTURE WORK:  
 #      I need to look at this logic carefully.  My druthers would be to follow  
 #      typical caching logic, and simple invalidate the cache, drop any subscription  
 #      an let the next fetch start the ball rolling again... however that may  
 #      actually be more difficult than it looks given the complex web of  
 #      proxy servers.  
 # Parameters:  # 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).
Line 2017  sub update_resource_handler { Line 2135  sub update_resource_handler {
     my $ownership=ishome($fname);      my $ownership=ishome($fname);
     if ($ownership eq 'not_owner') {      if ($ownership eq 'not_owner') {
  if (-e $fname) {   if (-e $fname) {
               # Delete preview file, if exists
               unlink("$fname.tmp");
               # Get usage stats
     my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,      my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);   $atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
     my $now=time;      my $now=time;
     my $since=$now-$atime;      my $since=$now-$atime;
               # If the file has not been used within lonExpire seconds,
               # unsubscribe from it and delete local copy
     if ($since>$perlvar{'lonExpire'}) {      if ($since>$perlvar{'lonExpire'}) {
  my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");   my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
  &devalidate_meta_cache($fname);   &devalidate_meta_cache($fname);
  unlink("$fname");   unlink("$fname");
  unlink("$fname.meta");   unlink("$fname.meta");
     } else {      } else {
               # Yes, this is in active use. Get a fresh copy. Since it might be in
               # very active use and huge (like a movie), copy it to "in.transfer" filename first.
  my $transname="$fname.in.transfer";   my $transname="$fname.in.transfer";
  my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");   my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
  my $response;   my $response;
Line 2054  sub update_resource_handler { Line 2179  sub update_resource_handler {
  }   }
  alarm(0);   alarm(0);
     }      }
                       # we successfully transfered, copy file over to real name
     rename($transname,$fname);      rename($transname,$fname);
     &devalidate_meta_cache($fname);      &devalidate_meta_cache($fname);
  }   }
Line 3022  sub dump_with_regexp { Line 3148  sub dump_with_regexp {
   
     my $userinput = "$cmd:$tail";      my $userinput = "$cmd:$tail";
   
     my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);      my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);
     if (defined($regexp)) {      if (defined($regexp)) {
  $regexp=&unescape($regexp);   $regexp=&unescape($regexp);
     } else {      } else {
Line 3040  sub dump_with_regexp { Line 3166  sub dump_with_regexp {
     }      }
     my $hashref = &tie_user_hash($udom, $uname, $namespace,      my $hashref = &tie_user_hash($udom, $uname, $namespace,
  &GDBM_READER());   &GDBM_READER());
       my $clientcheckrole;
     if ($hashref) {      if ($hashref) {
         my $qresult='';          my $qresult='';
  my $count=0;   my $count=0;
           if ($extra ne '') {
               $extra = &Apache::lonnet::thaw_unescape($extra);
               $clientcheckrole = $extra->{'clientcheckrole'};
           }
           my @ids = &Apache::lonnet::current_machine_ids();
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
               if ($namespace eq 'roles') {
                   if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)_(cc|co|in|ta|ep|ad|st|cr)}) {
                       my $cdom = $1;
                       my $cnum = $2;
                       unless ($clientcheckrole) {
                           my $home = &Apache::lonnet::homeserver($cnum,$cdom);
                           my $loncaparev = $clientversion;
                           if ($loncaparev eq '') {
                               $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
                           }
                           my ($major,$minor);
                           if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
                               $major = $1;
                               $minor = $2;
                           }
                           if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_community)_(co|in|ta|ep|ad|st|cr)}) {
                               if ($major eq '' && $minor eq '') {
                                   next unless (($home ne 'no_host') && grep(/^\Q$home\E$/,@ids));
                               }
                           }
                           unless ($home eq 'no_host') {
                               my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
                               if (ref($courseinfo) eq 'HASH') {
                                   if (exists($courseinfo->{'releaserequired'})) {
                                       my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
                                       if ($reqdmajor ne '' && $reqdminor ne '') {
                                           next if (($major eq '' && $minor eq '') ||
                                                    ($major < $reqdmajor) || 
                                                    (($major == $reqdmajor) && ($minor < $reqdminor)));
                                       }
                                   }
                               }
                           }
                       }
                   }
               }
     if ($regexp eq '.') {      if ($regexp eq '.') {
  $count++;   $count++;
  if (defined($range) && $count >= $end)   { last; }   if (defined($range) && $count >= $end)   { last; }
Line 3608  sub put_course_id_hash_handler { Line 3776  sub put_course_id_hash_handler {
 #                            will be returned. Pre-2.2.0 legacy entries from   #                            will be returned. Pre-2.2.0 legacy entries from 
 #                            nohist_courseiddump will only contain usernames.  #                            nohist_courseiddump will only contain usernames.
 #                 type     - optional parameter for selection   #                 type     - optional parameter for selection 
 #                 regexp_ok - if true, allow the supplied institutional code  #                 regexp_ok - if 1 or -1 allow the supplied institutional code
 #                            filter to behave as a regular expression.    #                            filter to behave as a regular expression:
   #                      1 will not exclude the course if the instcode matches the RE 
   #                            -1 will exclude the course if the instcode matches the RE
 #                 rtn_as_hash - whether to return the information available for  #                 rtn_as_hash - whether to return the information available for
 #                            each matched item as a frozen hash of all   #                            each matched item as a frozen hash of all 
 #                            key, value pairs in the item's hash, or as a   #                            key, value pairs in the item's hash, or as a 
Line 3625  sub put_course_id_hash_handler { Line 3795  sub put_course_id_hash_handler {
 #                 caller -  if set to 'coursecatalog', courses set to be hidden  #                 caller -  if set to 'coursecatalog', courses set to be hidden
 #                           from course catalog will be excluded from results (unless  #                           from course catalog will be excluded from results (unless
 #                           overridden by "showhidden".  #                           overridden by "showhidden".
   #                 cloner - escaped username:domain of course cloner (if picking course to
   #                          clone).
   #                 cc_clone_list - escaped comma separated list of courses for which 
   #                                 course cloner has active CC role (and so can clone
   #                                 automatically).
   #                 cloneonly - filter by courses for which cloner has rights to clone.
   #                 createdbefore - include courses for which creation date preceeded this date.
   #                 createdafter - include courses for which creation date followed this date.
   #                 creationcontext - include courses created in specified context 
   #
   #                 domcloner - flag to indicate if user can create CCs in course's domain.
   #                             If so, ability to clone course is automatic. 
 #  #
 #     $client  - The socket open on the client.  #     $client  - The socket open on the client.
 # Returns:  # Returns:
Line 3637  sub dump_course_id_handler { Line 3819  sub dump_course_id_handler {
   
     my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
         $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,          $typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
         $caller) =split(/:/,$tail);          $caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
           $creationcontext,$domcloner) =split(/:/,$tail);
     my $now = time;      my $now = time;
       my ($cloneruname,$clonerudom,%cc_clone);
     if (defined($description)) {      if (defined($description)) {
  $description=&unescape($description);   $description=&unescape($description);
     } else {      } else {
Line 3681  sub dump_course_id_handler { Line 3865  sub dump_course_id_handler {
     if (defined($catfilter)) {      if (defined($catfilter)) {
         $catfilter=&unescape($catfilter);          $catfilter=&unescape($catfilter);
     }      }
       if (defined($cloner)) {
           $cloner = &unescape($cloner);
           ($cloneruname,$clonerudom) = ($cloner =~ /^($LONCAPA::match_username):($LONCAPA::match_domain)$/); 
       }
       if (defined($cc_clone_list)) {
           $cc_clone_list = &unescape($cc_clone_list);
           my @cc_cloners = split('&',$cc_clone_list);
           foreach my $cid (@cc_cloners) {
               my ($clonedom,$clonenum) = split(':',$cid);
               next if ($clonedom ne $udom); 
               $cc_clone{$clonedom.'_'.$clonenum} = 1;
           } 
       }
       if ($createdbefore ne '') {
           $createdbefore = &unescape($createdbefore);
       } else {
          $createdbefore = 0;
       }
       if ($createdafter ne '') {
           $createdafter = &unescape($createdafter);
       } else {
           $createdafter = 0;
       }
       if ($creationcontext ne '') {
           $creationcontext = &unescape($creationcontext);
       } else {
           $creationcontext = '.';
       }
     my $unpack = 1;      my $unpack = 1;
     if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&       if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' && 
         $typefilter eq '.') {          $typefilter eq '.') {
Line 3692  sub dump_course_id_handler { Line 3904  sub dump_course_id_handler {
     if ($hashref) {      if ($hashref) {
  while (my ($key,$value) = each(%$hashref)) {   while (my ($key,$value) = each(%$hashref)) {
             my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,              my ($unesc_key,$lasttime_key,$lasttime,$is_hash,%val,
                 %unesc_val,$selfenroll_end,$selfenroll_types);                  %unesc_val,$selfenroll_end,$selfenroll_types,$created,
                   $context);
             $unesc_key = &unescape($key);              $unesc_key = &unescape($key);
             if ($unesc_key =~ /^lasttime:/) {              if ($unesc_key =~ /^lasttime:/) {
                 next;                  next;
Line 3703  sub dump_course_id_handler { Line 3916  sub dump_course_id_handler {
                 $lasttime = $hashref->{$lasttime_key};                  $lasttime = $hashref->{$lasttime_key};
                 next if ($lasttime<$since);                  next if ($lasttime<$since);
             }              }
               my ($canclone,$valchange);
             my $items = &Apache::lonnet::thaw_unescape($value);              my $items = &Apache::lonnet::thaw_unescape($value);
             if (ref($items) eq 'HASH') {              if (ref($items) eq 'HASH') {
                   if ($hashref->{$lasttime_key} eq '') {
                       next if ($since > 1);
                   }
                 $is_hash =  1;                  $is_hash =  1;
                   if ($domcloner) {
                       $canclone = 1;
                   } elsif (defined($clonerudom)) {
                       if ($items->{'cloners'}) {
                           my @cloneable = split(',',$items->{'cloners'});
                           if (@cloneable) {
                               if (grep(/^\*$/,@cloneable))  {
                                   $canclone = 1;
                               } elsif (grep(/^\*:\Q$clonerudom\E$/,@cloneable)) {
                                   $canclone = 1;
                               } elsif (grep(/^\Q$cloneruname\E:\Q$clonerudom\E$/,@cloneable)) {
                                   $canclone = 1;
                               }
                           }
                           unless ($canclone) {
                               if ($cloneruname ne '' && $clonerudom ne '') {
                                   if ($cc_clone{$unesc_key}) {
                                       $canclone = 1;
                                       $items->{'cloners'} .= ','.$cloneruname.':'.
                                                              $clonerudom;
                                       $valchange = 1;
                                   }
                               }
                           }
                       } elsif (defined($cloneruname)) {
                           if ($cc_clone{$unesc_key}) {
                               $canclone = 1;
                               $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                               $valchange = 1;
                           }
                           unless ($canclone) {
                               if ($items->{'owner'} =~ /:/) {
                                   if ($items->{'owner'} eq $cloner) {
                                       $canclone = 1;
                                   }
                               } elsif ($cloner eq $items->{'owner'}.':'.$udom) {
                                   $canclone = 1;
                               }
                               if ($canclone) {
                                   $items->{'cloners'} = $cloneruname.':'.$clonerudom;
                                   $valchange = 1;
                               }
                           }
                       }
                   }
                 if ($unpack || !$rtn_as_hash) {                  if ($unpack || !$rtn_as_hash) {
                     $unesc_val{'descr'} = $items->{'description'};                      $unesc_val{'descr'} = $items->{'description'};
                     $unesc_val{'inst_code'} = $items->{'inst_code'};                      $unesc_val{'inst_code'} = $items->{'inst_code'};
                     $unesc_val{'owner'} = $items->{'owner'};                      $unesc_val{'owner'} = $items->{'owner'};
                     $unesc_val{'type'} = $items->{'type'};                      $unesc_val{'type'} = $items->{'type'};
                       $unesc_val{'cloners'} = $items->{'cloners'};
                       $unesc_val{'created'} = $items->{'created'};
                       $unesc_val{'context'} = $items->{'context'};
                 }                  }
                 $selfenroll_types = $items->{'selfenroll_types'};                  $selfenroll_types = $items->{'selfenroll_types'};
                 $selfenroll_end = $items->{'selfenroll_end_date'};                  $selfenroll_end = $items->{'selfenroll_end_date'};
                   $created = $items->{'created'};
                   $context = $items->{'context'};
                 if ($selfenrollonly) {                  if ($selfenrollonly) {
                     next if (!$selfenroll_types);                      next if (!$selfenroll_types);
                     if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {                      if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
                         next;                          next;
                     }                      }
                 }                  }
                   if ($creationcontext ne '.') {
                       next if (($context ne '') && ($context ne $creationcontext));  
                   }
                   if ($createdbefore > 0) {
                       next if (($created eq '') || ($created > $createdbefore));   
                   }
                   if ($createdafter > 0) {
                       next if (($created eq '') || ($created <= $createdafter)); 
                   }
                 if ($catfilter ne '') {                  if ($catfilter ne '') {
                     next if ($items->{'categories'} eq '');                      next if ($items->{'categories'} eq '');
                     my @categories = split('&',$items->{'categories'});                       my @categories = split('&',$items->{'categories'}); 
Line 3741  sub dump_course_id_handler { Line 4017  sub dump_course_id_handler {
                 }                  }
             } else {              } else {
                 next if ($catfilter ne '');                  next if ($catfilter ne '');
                 next if ($selfenrollonly);                   next if ($selfenrollonly);
                   next if ($createdbefore || $createdafter);
                   next if ($creationcontext ne '.');
                   if ((defined($clonerudom)) && (defined($cloneruname)))  {
                       if ($cc_clone{$unesc_key}) {
                           $canclone = 1;
                           $val{'cloners'} = &escape($cloneruname.':'.$clonerudom);
                       }
                   }
                 $is_hash =  0;                  $is_hash =  0;
                 my @courseitems = split(/:/,$value);                  my @courseitems = split(/:/,$value);
                 $lasttime = pop(@courseitems);                  $lasttime = pop(@courseitems);
Line 3750  sub dump_course_id_handler { Line 4034  sub dump_course_id_handler {
                 }                  }
         ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;          ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
             }              }
               if ($cloneonly) {
                  next unless ($canclone);
               }
             my $match = 1;              my $match = 1;
     if ($description ne '.') {      if ($description ne '.') {
                 if (!$is_hash) {                  if (!$is_hash) {
Line 3763  sub dump_course_id_handler { Line 4050  sub dump_course_id_handler {
                 if (!$is_hash) {                  if (!$is_hash) {
                     $unesc_val{'inst_code'} = &unescape($val{'inst_code'});                      $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
                 }                  }
                 if ($regexp_ok) {                  if ($regexp_ok == 1) {
                     if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {                      if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
                         $match = 0;                          $match = 0;
                     }                      }
                   } elsif ($regexp_ok == -1) {
                       if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) {
                           $match = 0;
                       }
                 } else {                  } else {
                     if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {                      if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
                         $match = 0;                          $match = 0;
Line 3832  sub dump_course_id_handler { Line 4123  sub dump_course_id_handler {
             if ($match == 1) {              if ($match == 1) {
                 if ($rtn_as_hash) {                  if ($rtn_as_hash) {
                     if ($is_hash) {                      if ($is_hash) {
                         $qresult.=$key.'='.$value.'&';                          if ($valchange) {
                               my $newvalue = &Apache::lonnet::freeze_escape($items);
                               $qresult.=$key.'='.$newvalue.'&';
                           } else {
                               $qresult.=$key.'='.$value.'&';
                           }
                     } else {                      } else {
                         my %rtnhash = ( 'description' => &unescape($val{'descr'}),                          my %rtnhash = ( 'description' => &unescape($val{'descr'}),
                                         'inst_code' => &unescape($val{'inst_code'}),                                          'inst_code' => &unescape($val{'inst_code'}),
                                         'owner'     => &unescape($val{'owner'}),                                          'owner'     => &unescape($val{'owner'}),
                                         'type'      => &unescape($val{'type'}),                                          'type'      => &unescape($val{'type'}),
                                           'cloners'   => &unescape($val{'cloners'}),
                                       );                                        );
                         my $items = &Apache::lonnet::freeze_escape(\%rtnhash);                          my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
                         $qresult.=$key.'='.$items.'&';                          $qresult.=$key.'='.$items.'&';
Line 3869  sub dump_course_id_handler { Line 4166  sub dump_course_id_handler {
 }  }
 &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);  &register_handler("courseiddump", \&dump_course_id_handler, 0, 1, 0);
   
   sub course_lastaccess_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($cdom,$cnum) = split(':',$tail); 
       my (%lastaccess,$qresult);
       my $hashref = &tie_domain_hash($cdom, "nohist_courseids", &GDBM_WRCREAT());
       if ($hashref) {
           while (my ($key,$value) = each(%$hashref)) {
               my ($unesc_key,$lasttime);
               $unesc_key = &unescape($key);
               if ($cnum) {
                   next unless ($unesc_key =~ /\Q$cdom\E_\Q$cnum\E$/);
               }
               if ($unesc_key =~ /^lasttime:($LONCAPA::match_domain\_$LONCAPA::match_courseid)/) {
                   $lastaccess{$1} = $value;
               } else {
                   my $items = &Apache::lonnet::thaw_unescape($value);
                   if (ref($items) eq 'HASH') {
                       unless ($lastaccess{$unesc_key}) {
                           $lastaccess{$unesc_key} = '';
                       }
                   } else {
                       my @courseitems = split(':',$value);
                       $lastaccess{$unesc_key} = pop(@courseitems);
                   }
               }
           }
           foreach my $cid (sort(keys(%lastaccess))) {
               $qresult.=&escape($cid).'='.$lastaccess{$cid}.'&'; 
           }
           if (&untie_domain_hash($hashref)) {
               if ($qresult) {
                   chop($qresult);
               }
               &Reply($client, \$qresult, $userinput);
           } else {
               &Failure($client, "error: ".($!+0)." untie(GDBM) Failed ".
                       "while attempting lastacourseaccess\n", $userinput);
           }
       } else {
           &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
                   "while attempting lastcourseaccess\n", $userinput);
       }
       return 1;
   }
   &register_handler("courselastaccess",\&course_lastaccess_handler, 0, 1, 0);
   
 #  #
 # Puts an unencrypted entry in a namespace db file at the domain level   # Puts an unencrypted entry in a namespace db file at the domain level 
 #  #
Line 3961  sub get_domain_handler { Line 4305  sub get_domain_handler {
 }  }
 &register_handler("getdom", \&get_domain_handler, 0, 1, 0);  &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 4268  sub dump_domainroles_handler { Line 4611  sub dump_domainroles_handler {
         $rolesfilter=&unescape($rolesfilter);          $rolesfilter=&unescape($rolesfilter);
  @roles = split(/\&/,$rolesfilter);   @roles = split(/\&/,$rolesfilter);
     }      }
                                                                                              
     my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());      my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
     if ($hashref) {      if ($hashref) {
         my $qresult = '';          my $qresult = '';
         while (my ($key,$value) = each(%$hashref)) {          while (my ($key,$value) = each(%$hashref)) {
             my $match = 1;              my $match = 1;
             my ($start,$end) = split(/:/,&unescape($value));              my ($end,$start) = split(/:/,&unescape($value));
             my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));              my ($trole,$uname,$udom,$runame,$rudom,$rsec) = split(/:/,&unescape($key));
             unless ($startfilter eq '.' || !defined($startfilter)) {              unless (@roles < 1) {
                 if ($start >= $startfilter) {                  unless (grep/^\Q$trole\E$/,@roles) {
                     $match = 0;                      $match = 0;
                       next;
                 }                  }
             }              }
             unless ($endfilter eq '.' || !defined($endfilter)) {              unless ($startfilter eq '.' || !defined($startfilter)) {
                 if ($end <= $endfilter) {                  if ((defined($start)) && ($start >= $startfilter)) {
                     $match = 0;                      $match = 0;
                       next;
                 }                  }
             }              }
             unless (@roles < 1) {              unless ($endfilter eq '.' || !defined($endfilter)) {
                 unless (grep/^\Q$trole\E$/,@roles) {                  if ((defined($end)) && (($end > 0) && ($end <= $endfilter))) {
                     $match = 0;                      $match = 0;
                       next;
                 }                  }
             }              }
             if ($match == 1) {              if ($match == 1) {
Line 4575  sub enrollment_enabled_handler { Line 4921  sub enrollment_enabled_handler {
 }  }
 &register_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);  &register_handler("autorun", \&enrollment_enabled_handler, 0, 1, 0);
   
   #
   #   Validate an institutional code used for a LON-CAPA course.          
   #
   # 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:
   #                        $dom      - The domain for which the check of 
   #                                    institutional course code will occur.
   #
   #                        $instcode - The institutional code for the course
   #                                    being requested, or validated for rights
   #                                    to request.
   #
   #                        $owner    - The course requestor (who will be the
   #                                    course owner, in the form username:domain
   #
   #   $client       - Socket open on the client.
   # Returns:
   #    1           - Indicating processing should continue.
   #
   sub validate_instcode_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($dom,$instcode,$owner) = split(/:/, $tail);
       $instcode = &unescape($instcode);
       $owner = &unescape($owner);
       my ($outcome,$description) = 
           &localenroll::validate_instcode($dom,$instcode,$owner);
       my $result = &escape($outcome).'&'.&escape($description);
       &Reply($client, \$result, $userinput);
   
       return 1;
   }
   &register_handler("autovalidateinstcode", \&validate_instcode_handler, 0, 1, 0);
   
 #   Get the official sections for which auto-enrollment is possible.  #   Get the official sections for which auto-enrollment is possible.
 #   Since the admin people won't know about 'unofficial sections'   #   Since the admin people won't know about 'unofficial sections' 
 #   we cannot auto-enroll on them.  #   we cannot auto-enroll on them.
Line 4778  sub retrieve_auto_file_handler { Line 5161  sub retrieve_auto_file_handler {
 }  }
 &register_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);  &register_handler("autoretrieve", \&retrieve_auto_file_handler, 0,1,0);
   
   sub crsreq_checks_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my $dom = $tail;
       my $result;
       my @reqtypes = ('official','unofficial','community');
       eval {
           local($SIG{__DIE__})='DEFAULT';
           my %validations;
           my $response = &localenroll::crsreq_checks($dom,\@reqtypes,
                                                      \%validations);
           if ($response eq 'ok') { 
               foreach my $key (keys(%validations)) {
                   $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&';
               }
               $result =~ s/\&$//;
           } else {
               $result = 'error';
           }
       };
       if (!$@) {
           &Reply($client, \$result, $userinput);
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autocrsreqchecks", \&crsreq_checks_handler, 0, 1, 0);
   
   sub validate_crsreq_handler {
       my ($cmd, $tail, $client) = @_;
       my $userinput = "$cmd:$tail";
       my ($dom,$owner,$crstype,$inststatuslist,$instcode,$instseclist) = split(/:/, $tail);
       $instcode = &unescape($instcode);
       $owner = &unescape($owner);
       $crstype = &unescape($crstype);
       $inststatuslist = &unescape($inststatuslist);
       $instcode = &unescape($instcode);
       $instseclist = &unescape($instseclist);
       my $outcome;
       eval {
           local($SIG{__DIE__})='DEFAULT';
           $outcome = &localenroll::validate_crsreq($dom,$owner,$crstype,
                                                    $inststatuslist,$instcode,
                                                    $instseclist);
       };
       if (!$@) {
           &Reply($client, \$outcome, $userinput);
       } else {
           &Failure($client,"unknown_cmd\n",$userinput);
       }
       return 1;
   }
   &register_handler("autocrsreqvalidation", \&validate_crsreq_handler, 0, 1, 0);
   
 #  #
 #   Read and retrieve institutional code format (for support form).  #   Read and retrieve institutional code format (for support form).
 # Formal Parameters:  # Formal Parameters:
Line 4862  sub get_institutional_defaults_handler { Line 5300  sub get_institutional_defaults_handler {
 &register_handler("autoinstcodedefaults",  &register_handler("autoinstcodedefaults",
                   \&get_institutional_defaults_handler,0,1,0);                    \&get_institutional_defaults_handler,0,1,0);
   
   sub get_possible_instcodes_handler {
       my ($cmd, $tail, $client)   = @_;
       my $userinput               = "$cmd:$tail";
   
       my $reply;
       my $cdom = $tail;
       my (@codetitles,%cat_titles,%cat_order,@code_order);
       my $formatreply = &localenroll::possible_instcodes($cdom,
                                                          \@codetitles,
                                                          \%cat_titles,
                                                          \%cat_order,
                                                          \@code_order);
       if ($formatreply eq 'ok') {
           my $result = join('&',map {&escape($_);} (@codetitles)).':';
           $result .= join('&',map {&escape($_);} (@code_order)).':';
           foreach my $key (keys(%cat_titles)) {
               $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_titles{$key}).'&';
           }
           $result =~ s/\&$//;
           $result .= ':';
           foreach my $key (keys(%cat_order)) {
               $result .= &escape($key).'='.&Apache::lonnet::freeze_escape($cat_order{$key}).'&';
           }
           $result =~ s/\&$//;
           &Reply($client,\$result,$userinput);
       } else {
           &Reply($client, "format_error\n", $userinput);
       }
       return 1;
   }
   &register_handler("autopossibleinstcodes",
                     \&get_possible_instcodes_handler,0,1,0);
   
 sub get_institutional_user_rules {  sub get_institutional_user_rules {
     my ($cmd, $tail, $client)   = @_;      my ($cmd, $tail, $client)   = @_;
     my $userinput               = "$cmd:$tail";      my $userinput               = "$cmd:$tail";
Line 5851  $SIG{USR2} = \&UpdateHosts; Line 6322  $SIG{USR2} = \&UpdateHosts;
   
 #  Read the host hashes:  #  Read the host hashes:
 &Apache::lonnet::load_hosts_tab();  &Apache::lonnet::load_hosts_tab();
   my %iphost = &Apache::lonnet::get_iphost(1);
   
 my $dist=`$perlvar{'lonDaemons'}/distprobe`;  my $dist=`$perlvar{'lonDaemons'}/distprobe`;
   
Line 5944  sub make_new_child { Line 6416  sub make_new_child {
  if ($clientip eq '127.0.0.1') {   if ($clientip eq '127.0.0.1') {
     $outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'});      $outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'});
  }   }
    &ReadManagerTable();
  my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));   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  = "[unknown]";
  if($clientrec) { # Establish client type.   if($clientrec) { # Establish client type.
     $ConnectionType = "client";      $ConnectionType = "client";
     $clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];      $clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
Line 5975  sub make_new_child { Line 6447  sub make_new_child {
  #   #
  #  If the remote is attempting a local init... give that a try:   #  If the remote is attempting a local init... give that a try:
  #   #
  my ($i, $inittype) = split(/:/, $remotereq);   (my $i, my $inittype, $clientversion) = split(/:/, $remotereq);
   
  # If the connection type is ssl, but I didn't get my   # If the connection type is ssl, but I didn't get my
  # certificate files yet, then I'll drop  back to    # certificate files yet, then I'll drop  back to 
Line 5995  sub make_new_child { Line 6467  sub make_new_child {
  }   }
   
  if($inittype eq "local") {   if($inittype eq "local") {
                       $clientversion = $perlvar{'lonVersion'};
     my $key = LocalConnection($client, $remotereq);      my $key = LocalConnection($client, $remotereq);
     if($key) {      if($key) {
  Debug("Got local key $key");   Debug("Got local key $key");
Line 6002  sub make_new_child { Line 6475  sub make_new_child {
  my $cipherkey = pack("H32", $key);   my $cipherkey = pack("H32", $key);
  $cipher       = new IDEA($cipherkey);   $cipher       = new IDEA($cipherkey);
  print $client "ok:local\n";   print $client "ok:local\n";
  &logthis('<font color="green"'   &logthis('<font color="green">'
  . "Successful local authentication </font>");   . "Successful local authentication </font>");
  $keymode = "local"   $keymode = "local"
     } else {      } else {
Line 6066  sub make_new_child { Line 6539  sub make_new_child {
 # ------------------------------------------------------------ Process requests  # ------------------------------------------------------------ Process requests
     my $keep_going = 1;      my $keep_going = 1;
     my $user_input;      my $user_input;
               my $clienthost = &Apache::lonnet::hostname($clientname);
               my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);
               $clienthomedom = &Apache::lonnet::host_domain($clientserverhomeID);
     while(($user_input = get_request) && $keep_going) {      while(($user_input = get_request) && $keep_going) {
  alarm(120);   alarm(120);
  Debug("Main: Got $user_input\n");   Debug("Main: Got $user_input\n");
Line 6224  sub rewrite_password_file { Line 6700  sub rewrite_password_file {
   
 #     Returns the authorization type or nouser if there is no such user.  #     Returns the authorization type or nouser if there is no such user.
 #  #
 sub get_auth_type   sub get_auth_type {
 {  
   
     my ($domain, $user)  = @_;      my ($domain, $user)  = @_;
   
     Debug("get_auth_type( $domain, $user ) \n");      Debug("get_auth_type( $domain, $user ) \n");
Line 6321  sub validate_user { Line 6795  sub validate_user {
     } else {      } else {
  $validated = 0;   $validated = 0;
     }      }
  }   } elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
  elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.              my $checkwithkrb5 = 0;
     if(! ($password =~ /$null/) ) {              if ($dist =~/^fedora(\d+)$/) {
  my $k4error = &Authen::Krb4::get_pw_in_tkt($user,                  if ($1 > 11) {
    "",                      $checkwithkrb5 = 1;
    $contentpwd,,                  }
    'krbtgt',              } elsif ($dist =~ /^suse([\d.]+)$/) {
    $contentpwd,                  if ($1 > 11.1) {
    1,                      $checkwithkrb5 = 1; 
    $password);                  }
  if(!$k4error) {              }
     $validated = 1;              if ($checkwithkrb5) {
  } else {                  $validated = &krb5_authen($password,$null,$user,$contentpwd);
     $validated = 0;              } else {
     &logthis('krb4: '.$user.', '.$contentpwd.', '.                  $validated = &krb4_authen($password,$null,$user,$contentpwd);
      &Authen::Krb4::get_err_txt($Authen::Krb4::error));              }
  }  
     } else {  
  $validated = 0; # Password has a match with null.  
     }  
  } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.   } elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
     if(!($password =~ /$null/)) { # Null password not allowed.              $validated = &krb5_authen($password,$null,$user,$contentpwd);
  my $krbclient = &Authen::Krb5::parse_name($user.'@'  
   .$contentpwd);  
  my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;  
  my $krbserver  = &Authen::Krb5::parse_name($krbservice);  
  my $credentials= &Authen::Krb5::cc_default();  
  $credentials->initialize(&Authen::Krb5::parse_name($user.'@'  
                                                                  .$contentpwd));  
                 my $krbreturn;  
                 if (exists(&Authen::Krb5::get_init_creds_password)) {  
                     $krbreturn =   
                         &Authen::Krb5::get_init_creds_password($krbclient,$password,  
                                                                $krbservice);  
                     $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');  
                 } else {  
     $krbreturn  =   
                         &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,  
  $password,$credentials);  
     $validated = ($krbreturn == 1);  
                 }  
  if (!$validated) {  
     &logthis('krb5: '.$user.', '.$contentpwd.', '.  
      &Authen::Krb5::error());  
  }  
     } else {  
  $validated = 0;  
     }  
  } elsif ($howpwd eq "localauth") {    } elsif ($howpwd eq "localauth") { 
     #  Authenticate via installation specific authentcation method:      #  Authenticate via installation specific authentcation method:
     $validated = &localauth::localauth($user,       $validated = &localauth::localauth($user, 
Line 6399  sub validate_user { Line 6843  sub validate_user {
     return $validated;      return $validated;
 }  }
   
   sub krb4_authen {
       my ($password,$null,$user,$contentpwd) = @_;
       my $validated = 0;
       if (!($password =~ /$null/) ) {  # Null password not allowed.
           eval {
               require Authen::Krb4;
           };
           if (!$@) {
               my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
                                                          "",
                                                          $contentpwd,,
                                                          'krbtgt',
                                                          $contentpwd,
                                                          1,
                                                          $password);
               if(!$k4error) {
                   $validated = 1;
               } else {
                   $validated = 0;
                   &logthis('krb4: '.$user.', '.$contentpwd.', '.
                             &Authen::Krb4::get_err_txt($Authen::Krb4::error));
               }
           } else {
               $validated = krb5_authen($password,$null,$user,$contentpwd);
           }
       }
       return $validated;
   }
   
   sub krb5_authen {
       my ($password,$null,$user,$contentpwd) = @_;
       my $validated = 0;
       if(!($password =~ /$null/)) { # Null password not allowed.
           my $krbclient = &Authen::Krb5::parse_name($user.'@'
                                                     .$contentpwd);
           my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
           my $krbserver  = &Authen::Krb5::parse_name($krbservice);
           my $credentials= &Authen::Krb5::cc_default();
           $credentials->initialize(&Authen::Krb5::parse_name($user.'@'
                                                               .$contentpwd));
           my $krbreturn;
           if (exists(&Authen::Krb5::get_init_creds_password)) {
               $krbreturn =
                   &Authen::Krb5::get_init_creds_password($krbclient,$password,
                                                             $krbservice);
               $validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
           } else {
               $krbreturn  =
                   &Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
                                                            $password,$credentials);
               $validated = ($krbreturn == 1);
           }
           if (!$validated) {
               &logthis('krb5: '.$user.', '.$contentpwd.', '.
                        &Authen::Krb5::error());
           }
       }
       return $validated;
   }
   
 sub addline {  sub addline {
     my ($fname,$hostid,$ip,$newline)=@_;      my ($fname,$hostid,$ip,$newline)=@_;
Line 6769  sub sethost { Line 7272  sub sethost {
  eq &Apache::lonnet::get_host_ip($hostid)) {   eq &Apache::lonnet::get_host_ip($hostid)) {
  $currenthostid  =$hostid;   $currenthostid  =$hostid;
  $currentdomainid=&Apache::lonnet::host_domain($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 ".
  $perlvar{'lonHostID'}." refusing connection");   $perlvar{'lonHostID'}." refusing connection");
Line 6784  sub version { Line 7287  sub version {
     return "version:$VERSION";      return "version:$VERSION";
 }  }
   
   sub get_usersession_config {
       my ($dom,$name) = @_;
       my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
       if (defined($cached)) {
           return $usersessionconf;
       } else {
           my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom);
           if (ref($domconfig{'usersessions'}) eq 'HASH') {
               &Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600);
               return $domconfig{'usersessions'};
           }
       }
       return;
   }
   
   sub get_courseinfo_hash {
       my ($cnum,$cdom,$home) = @_;
       my $hashid = $cdom.':'.$cnum;
       my ($courseinfo,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
       if (defined($cached)) {
           return $courseinfo;
       } else {
           my %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
           if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
               return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
           }
       }
       return;
   }
   
 # ----------------------------------- POD (plain old documentation, CPAN style)  # ----------------------------------- POD (plain old documentation, CPAN style)
   
Line 7519  string. Line 8051  string.
   
 =back  =back
   
   =back
   
   
 =cut  =cut

Removed from v.1.409  
changed lines
  Added in v.1.452


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