loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.410.2.2 and 1.489.2.2

-version 1.410.2.2, 2009/10/09 12:36:10
+version 1.489.2.2, 2012/10/06 14:44:50
  Line 15
  #
  # LON-CAPA is distributed in the hope that it will be useful,
  # but WITHOUT ANY WARRANTY; without even the implied warranty of
  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  # GNU General Public License for more details.
  #
- Line 42  use Crypt::IDEA;
+ Line 43  use Crypt::IDEA;
  use LWP::UserAgent();
  use Digest::MD5 qw(md5_hex);
  use GDBM_File;
- use Authen::Krb4;
  use Authen::Krb5;
  use localauth;
  use localenroll;
  Line 53  use LONCAPA::lonlocal;
  use LONCAPA::lonssl;
  use Fcntl qw(:flock);
  use Apache::lonnet;
+ use Mail::Send;
  my $DEBUG = 0;		       # Non zero to enable debug log entries.
- Line 67  my $currentdomainid;
+ Line 68  my $currentdomainid;
  my $client;
  my $clientip;			# IP address 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;
- Line 88  my %managers;   # Ip -> manager names
+ Line 92  my %managers;   # Ip -> manager names
  my %perlvar;			# Will have the apache conf defined perl vars.
+ my $dist;
  #
  #   The hash below is used for command dispatching, and is therefore keyed on the request keyword.
  #    Each element of the hash contains a reference to an array that contains:
- Line 142  my @adderrors    = ("ok",
+ Line 148  my @adderrors    = ("ok",
  		    "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.
- Line 398  sub isClient {
+ Line 414  sub isClient {
  #
  sub ReadManagerTable {
+     &Debug("Reading manager table");
      #   Clean out the old table first..
     foreach my $key (keys %managers) {
- Line 406  sub ReadManagerTable {
+ Line 423  sub ReadManagerTable {
     my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
     if (!open (MANAGERS, $tablename)) {
-       logthis('<font color="red">No manager table.  Nobody can manage!!</font>');
+        my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
-       return;
+        if (&Apache::lonnet::is_LC_dns($hostname)) {
+            &logthis('<font color="red">No manager table.  Nobody can manage!!</font>');
+        }
+        return;
     }
     while(my $host = <MANAGERS>) {
        chomp($host);
- Line 432  sub ReadManagerTable {
+ Line 452  sub ReadManagerTable {
           }
        } else {
           logthis('<font color="green"> existing host'." $host</font>\n");
-          $managers{&Apache::lonnet::get_host_ip($host)} = $host;  # Use info from cluster tab if clumemeber
+          $managers{&Apache::lonnet::get_host_ip($host)} = $host;  # Use info from cluster tab if cluster memeber
        }
     }
  }
- Line 494  sub AdjustHostContents {
+ Line 514  sub AdjustHostContents {
      my $me        = $perlvar{'lonHostID'};
      foreach my $line (split(/\n/,$contents)) {
- 	if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
+ 	if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/) ||
+              ($line =~ /^\s*\^/))) {
  	    chomp($line);
  	    my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
  	    if ($id eq $me) {
- Line 520  sub AdjustHostContents {
+ Line 541  sub AdjustHostContents {
  }
  #
  #   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:
  #       Name of the file
- Line 532  sub AdjustHostContents {
+ Line 551  sub AdjustHostContents {
  #  Return:
  #      nonzero - success.
  #      0       - failure and $! has an errno.
+ # Assumptions:
+ #    File installtion is a relatively infrequent
  #
  sub InstallFile {
      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:
- Line 550  sub InstallFile {
+ Line 574  sub InstallFile {
      print $fh ($Contents);
      $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;
  }
- Line 562  sub InstallFile {
+ Line 602  sub InstallFile {
  #
  #   ConfigFileFromSelector: converts a configuration file selector
- #                 (one of host or domain at this point) into a
+ #                 into a configuration file pathname.
- #                 configuration file pathname.
+ #                 Supports the following file selectors:
+ #                 hosts, domain, dns_hosts, dns_domain
+ #
  #
  #  Parameters:
  #      selector  - Configuration file selector.
- Line 575  sub ConfigFileFromSelector {
+ Line 617  sub ConfigFileFromSelector {
      my $tablefile;
      my $tabledir = $perlvar{'lonTabDir'}.'/';
-     if ($selector eq "hosts") {
+     if (($selector eq "hosts") || ($selector eq "domain") ||
- 	$tablefile = $tabledir."hosts.tab";
+         ($selector eq "dns_hosts") || ($selector eq "dns_domain")) {
-     } elsif ($selector eq "domain") {
+ 	$tablefile =  $tabledir.$selector.'.tab';
- 	$tablefile = $tabledir."domain.tab";
-     } else {
- 	return undef;
      }
      return $tablefile;
  }
  #
  #   PushFile:  Called to do an administrative push of a file.
- Line 603  sub ConfigFileFromSelector {
+ Line 641  sub ConfigFileFromSelector {
  sub PushFile {
      my $request = shift;
      my ($command, $filename, $contents) = split(":", $request, 3);
+     &Debug("PushFile");
      #  At this point in time, pushes for only the following tables are
      #  supported:
      #   hosts.tab  ($filename eq host).
      #   domain.tab ($filename eq domain).
+     #   dns_hosts.tab ($filename eq dns_host).
+     #   dns_domain.tab ($filename eq dns_domain).
      # Construct the destination filename or reject the request.
      #
      # lonManage is supposed to ensure this, however this session could be
- Line 619  sub PushFile {
+ Line 660  sub PushFile {
      if(! (defined $tablefile)) {
  	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
      #  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
- Line 645  sub PushFile {
+ Line 673  sub PushFile {
      #  Install the new file:
+     &logthis("Installing new $tablefile contents:\n$contents");
      if(!InstallFile($tablefile, $contents)) {
  	&logthis('<font color="red"> Pushfile: unable to install '
  	 .$tablefile." $! </font>");
  	return "error:$!";
      } else {
  	&logthis('<font color="green"> Installed new '.$tablefile
- 		 ."</font>");
+ 		 ." - transaction by: $clientname ($clientip)</font>");
+         my $adminmail = $perlvar{'lonAdmEMail'};
+         my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
+         if ($admindom ne '') {
+             my %domconfig =
+                 &Apache::lonnet::get_dom('configuration',['contacts'],$admindom);
+             if (ref($domconfig{'contacts'}) eq 'HASH') {
+                 if ($domconfig{'contacts'}{'adminemail'} ne '') {
+                     $adminmail = $domconfig{'contacts'}{'adminemail'};
+                 }
+             }
+         }
+         if ($adminmail =~ /^[^\@]+\@[^\@]+$/) {
+             my $msg = new Mail::Send;
+             $msg->to($adminmail);
+             $msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'});
+             $msg->add('Content-type','text/plain; charset=UTF-8');
+             if (my $fh = $msg->open()) {
+                 print $fh 'Update to '.$tablefile.' from Cluster Manager '.
+                           "$clientname ($clientip)\n";
+                 $fh->close;
+             }
+         }
      }
      #  Indicate success:
      return "ok";
- Line 951  sub read_profile {
+ Line 1000  sub read_profile {
  				 &GDBM_READER());
      if ($hashref) {
          my @queries=split(/\&/,$what);
+         if ($namespace eq 'roles') {
+             @queries = map { &unescape($_); } @queries;
+         }
          my $qresult='';
  	for (my $i=0;$i<=$#queries;$i++) {
- Line 1044  sub pong_handler {
+ Line 1096  sub pong_handler {
  #  Implicit Inputs:
  #      $currenthostid - Global variable that carries the name of the host
  #                       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:
  #      1       - Ok to continue processing.
  #      0       - Program should exit.
- Line 1083  sub establish_key_handler {
+ Line 1135  sub establish_key_handler {
  #  Implicit Inputs:
  #      $currenthostid - Global variable that carries the name of the host
  #                       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:
  #      1       - Ok to continue processing.
  #      0       - Program should exit.
- Line 1092  sub establish_key_handler {
+ Line 1144  sub establish_key_handler {
  sub load_handler {
      my ($cmd, $tail, $replyfd) = @_;
     # Get the load average from /proc/loadavg and calculate it as a percentage of
     # the allowed load limit as set by the perl global variable lonLoadLim
- Line 1120  sub load_handler {
+ Line 1174  sub load_handler {
  #  Implicit Inputs:
  #      $currenthostid - Global variable that carries the name of the host
  #                       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:
  #      1       - Ok to continue processing.
  #      0       - Program should exit
- Line 1198  sub user_authorization_type {
+ Line 1252  sub user_authorization_type {
  #    a reply is written to the client.
  sub push_file_handler {
      my ($cmd, $tail, $client) = @_;
+     &Debug("In push file handler");
      my $userinput = "$cmd:$tail";
      # At this time we only know that the IP of our partner is a valid manager
- Line 1206  sub push_file_handler {
+ Line 1260  sub push_file_handler {
      # spoofing).
      my $cert = &GetCertificate($userinput);
      if(&ValidManager($cert)) {
+ 	&Debug("Valid manager: $client");
  	# Now presumably we have the bona fides of both the peer host and the
  	# process making the request.
- Line 1215  sub push_file_handler {
+ Line 1270  sub push_file_handler {
  	&Reply($client, \$reply, $userinput);
      } else {
+ 	&logthis("push_file_handler $client is not valid");
  	&Failure( $client, "refused\n", $userinput);
      }
      return 1;
- Line 1587  sub ls3_handler {
+ Line 1643  sub ls3_handler {
  }
  &register_handler("ls3", \&ls3_handler, 0, 1, 0);
+ sub read_lonnet_global {
+     my ($cmd,$tail,$client) = @_;
+     my $userinput = "$cmd:$tail";
+     my $requested = &Apache::lonnet::thaw_unescape($tail);
+     my $result;
+     my %packagevars = (
+                         spareid => \%Apache::lonnet::spareid,
+                         perlvar => \%Apache::lonnet::perlvar,
+                       );
+     my %limit_to = (
+                     perlvar => {
+                                  lonOtherAuthen => 1,
+                                  lonBalancer    => 1,
+                                  lonVersion     => 1,
+                                  lonSysEMail    => 1,
+                                  lonHostID      => 1,
+                                  lonRole        => 1,
+                                  lonDefDomain   => 1,
+                                  lonLoadLim     => 1,
+                                  lonUserLoadLim => 1,
+                                }
+                   );
+     if (ref($requested) eq 'HASH') {
+         foreach my $what (keys(%{$requested})) {
+             my $response;
+             my $items = {};
+             if (exists($packagevars{$what})) {
+                 if (ref($limit_to{$what}) eq 'HASH') {
+                     foreach my $varname (keys(%{$packagevars{$what}})) {
+                         if ($limit_to{$what}{$varname}) {
+                             $items->{$varname} = $packagevars{$what}{$varname};
+                         }
+                     }
+                 } else {
+                     $items = $packagevars{$what};
+                 }
+                 if ($what eq 'perlvar') {
+                     if (!exists($packagevars{$what}{'lonBalancer'})) {
+                         if ($dist =~ /^(centos|rhes|fedora|scientific)/) {
+                             my $othervarref=LONCAPA::Configuration::read_conf('httpd.conf');
+                             if (ref($othervarref) eq 'HASH') {
+                                 $items->{'lonBalancer'} = $othervarref->{'lonBalancer'};
+                             }
+                         }
+                     }
+                 }
+                 $response = &Apache::lonnet::freeze_escape($items);
+             }
+             $result .= &escape($what).'='.$response.'&';
+         }
+     }
+     $result =~ s/\&$//;
+     &Reply($client,\$result,$userinput);
+     return 1;
+ }
+ &register_handler("readlonnetglobal", \&read_lonnet_global, 0, 1, 0);
+ sub server_devalidatecache_handler {
+     my ($cmd,$tail,$client) = @_;
+     my $userinput = "$cmd:$tail";
+     my ($name,$id) = map { &unescape($_); } split(/:/,$tail);
+     &Apache::lonnet::devalidate_cache_new($name,$id);
+     my $result = 'ok';
+     &Reply($client,\$result,$userinput);
+     return 1;
+ }
+ &register_handler("devalidatecache", \&server_devalidatecache_handler, 0, 1, 0);
  sub server_timezone_handler {
      my ($cmd,$tail,$client) = @_;
      my $userinput = "$cmd:$tail";
- Line 1619  sub server_timezone_handler {
+ Line 1743  sub server_timezone_handler {
  }
  &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);
+ sub server_distarch_handler {
+     my ($cmd,$tail,$client) = @_;
+     my $userinput = "$cmd:$tail";
+     my $reply = &distro_and_arch();
+     &Reply($client,\$reply,$userinput);
+     return 1;
+ }
+ &register_handler("serverdistarch", \&server_distarch_handler, 0, 1, 0);
  #   Process a reinit request.  Reinit requests that either
  #   lonc or lond be reinitialized so that an updated
  #   host.tab or domain.tab can be processed.
- Line 1728  sub authenticate_handler {
+ Line 1877  sub authenticate_handler {
      #  upass   - User's password.
      #  checkdefauth - Pass to validate_user() to try authentication
      #                 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");
      chomp($upass);
      $upass=&unescape($upass);
      my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
      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
  	#
- Line 1781  sub change_password_handler {
+ Line 1964  sub change_password_handler {
      #  npass - New password.
      #  context - Context in which this was called
      #            (preferences or reset_by_email).
      #  lonhost - HostID of server where request originated
      my ($udom,$uname,$upass,$npass,$context,$lonhost)=split(/:/,$tail);
- Line 1813  sub change_password_handler {
+ Line 1996  sub change_password_handler {
  	    my $ncpass=crypt($npass,$salt);
  	    if(&rewrite_password_file($udom, $uname, "internal:$ncpass")) {
  		my $msg="Result of password change for $uname: pwchange_success";
- 		if ($lonhost) {
+                 if ($lonhost) {
- 		    $msg .= " - request originated from: $lonhost";
+                     $msg .= " - request originated from: $lonhost";
- 		}
+                 }
- 		&logthis($msg);
+                 &logthis($msg);
  		&Reply($client, "ok\n", $userinput);
  	    } else {
  		&logthis("Unable to open $uname passwd "
- Line 1890  sub add_user_handler {
+ Line 2073  sub add_user_handler {
  		    ."makeuser";
  	    }
  	    unless ($fperror) {
- 		my $result=&make_passwd_file($uname, $umode,$npass, $passfilename);
+ 		my $result=&make_passwd_file($uname,$udom,$umode,$npass, $passfilename);
  		&Reply($client,\$result, $userinput);     #BUGBUG - could be fail
  	    } else {
  		&Failure($client, \$fperror, $userinput);
- Line 1965  sub change_authentication_handler {
+ Line 2148  sub change_authentication_handler {
  		    &Failure($client, \$result);
  		}
  	    } else {
- 		my $result=&make_passwd_file($uname, $umode,$npass,$passfilename);
+ 		my $result=&make_passwd_file($uname,$udom,$umode,$npass,$passfilename);
  		#
  		#  If the current auth mode is internal, and the old auth mode was
  		#  unix, or krb*,  and the user is an author for this domain,
- Line 2027  sub is_home_handler {
+ Line 2210  sub is_home_handler {
  &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
  #   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:
  #    $cmd      - The command that got us here.
  #    $tail     - Tail of the command (remaining parameters).
- Line 2060  sub update_resource_handler {
+ Line 2237  sub update_resource_handler {
      my $ownership=ishome($fname);
      if ($ownership eq 'not_owner') {
  	if (-e $fname) {
+             # Delete preview file, if exists
+             unlink("$fname.tmp");
+             # Get usage stats
  	    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  		$atime,$mtime,$ctime,$blksize,$blocks)=stat($fname);
  	    my $now=time;
  	    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'}) {
  		my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
  		&devalidate_meta_cache($fname);
  		unlink("$fname");
  		unlink("$fname.meta");
  	    } 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 $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
  		my $response;
- 		alarm(120);
+ # FIXME: cannot replicate files that take more than two minutes to transfer?
+ #		alarm(120);
+ # FIXME: this should use the LWP mechanism, not internal alarms.
+                 alarm(1200);
  		{
  		    my $ua=new LWP::UserAgent;
  		    my $request=new HTTP::Request('GET',"$remoteurl");
- Line 2081  sub update_resource_handler {
+ Line 2268  sub update_resource_handler {
  		}
  		alarm(0);
  		if ($response->is_error()) {
+ # FIXME: we should probably clean up here instead of just whine
  		    unlink($transname);
  		    my $message=$response->status_line;
  		    &logthis("LWP GET: $message for $fname ($remoteurl)");
  		} else {
  		    if ($remoteurl!~/\.meta$/) {
+ # FIXME: isn't there an internal LWP mechanism for this?
  			alarm(120);
  			{
  			    my $ua=new LWP::UserAgent;
- Line 2097  sub update_resource_handler {
+ Line 2286  sub update_resource_handler {
  			}
  			alarm(0);
  		    }
+                     # we successfully transfered, copy file over to real name
  		    rename($transname,$fname);
  		    &devalidate_meta_cache($fname);
  		}
- Line 2158  sub fetch_user_file_handler {
+ Line 2348  sub fetch_user_file_handler {
  	my $destname=$udir.'/'.$ufile;
  	my $transname=$udir.'/'.$ufile.'.in.transit';
- 	my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
+         my $clientprotocol=$Apache::lonnet::protocol{$clientname};
+         $clientprotocol = 'http' if ($clientprotocol ne 'https');
+ 	my $clienthost = &Apache::lonnet::hostname($clientname);
+ 	my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;
  	my $response;
  	Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
  	alarm(120);
- Line 2180  sub fetch_user_file_handler {
+ Line 2373  sub fetch_user_file_handler {
  		unlink($transname);
  		&Failure($client, "failed\n", $userinput);
  	    } else {
+                 if ($fname =~ /^default.+\.(page|sequence)$/) {
+                     my ($major,$minor) = split(/\./,$clientversion);
+                     if (($major < 2) || ($major == 2 && $minor < 11)) {
+                         my $now = time;
+                         &Apache::lonnet::do_cache_new('crschange',$udom.'_'.$uname,$now,600);
+                         my $key = &escape('internal.contentchange');
+                         my $what = "$key=$now";
+                         my $hashref = &tie_user_hash($udom,$uname,'environment',
+                                                      &GDBM_WRCREAT(),"P",$what);
+                         if ($hashref) {
+                             $hashref->{$key}=$now;
+                             if (!&untie_user_hash($hashref)) {
+                                 &logthis("error: ".($!+0)." untie (GDBM) failed ".
+                                          "when updating internal.contentchange");
+                             }
+                         }
+                     }
+                 }
  		&Reply($client, "ok\n", $userinput);
  	    }
  	}
- Line 2334  sub user_has_session_handler {
+ Line 2545  sub user_has_session_handler {
      my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));
-     &logthis("Looking for $udom $uname");
      opendir(DIR,$perlvar{'lonIDsDir'});
      my $filename;
      while ($filename=readdir(DIR)) {
- Line 3053  sub dump_profile_database {
+ Line 3263  sub dump_profile_database {
  #                                             that is matched against
  #                                             database keywords to do
  #                                             selective dumps.
+ #                               range       - optional range of entries
+ #                                             e.g., 10-20 would return the
+ #                                             10th to 19th items, etc.
  #   $client                   - Channel open on the client.
  # Returns:
  #    1    - Continue processing.
- Line 3086  sub dump_with_regexp {
+ Line 3299  sub dump_with_regexp {
      if ($hashref) {
          my $qresult='';
  	my $count=0;
+ #
+ # When dump is for roles.db, determine if LON-CAPA version checking is needed.
+ # Sessions on 2.10 and later do not require version checking, as that occurs
+ # on the server hosting the user session, when constructing the roles/courses
+ # screen).
+ #
+         my $skipcheck;
+         my @ids = &Apache::lonnet::current_machine_ids();
+         my (%homecourses,$major,$minor,$now);
+ #
+ # If dump is for roles.db from a pre-2.10 server, determine the LON-CAPA
+ # version on the server which requested the data. For LON-CAPA 2.9, the
+ # client session will have sent its LON-CAPA version when initiating the
+ # connection. For LON-CAPA 2.8 and older, the version is retrieved from
+ # the global %loncaparevs in lonnet.pm.
+ #
+ #
+         if ($namespace eq 'roles') {
+             my $loncaparev = $clientversion;
+             if ($loncaparev eq '') {
+                 $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
+             }
+             if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
+                 $major = $1;
+                 $minor = $2;
+             }
+             if (($major > 2) || (($major == 2) && ($minor > 9))) {
+                 $skipcheck = 1;
+             }
+             $now = time;
+         }
  	while (my ($key,$value) = each(%$hashref)) {
+             if (($namespace eq 'roles') && (!$skipcheck)) {
+                 if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc|co|in|ta|ep|ad|st|cr)$}) {
+                     my $cdom = $1;
+                     my $cnum = $2;
+                     my ($role,$roleend,$rolestart) = split(/\_/,$value);
+                     if (!$roleend || $roleend > $now) {
+ #
+ # For active course roles, check that requesting server is running a LON-CAPA
+ # version which meets any version requirements for the course. Do not include
+ # the role amongst the results returned if the requesting server's version is
+ # too old.
+ #
+ # This determination is handled differently depending on whether the course's
+ # homeserver is the current server, or whether it is a different server.
+ # In both cases, the course's version requirement needs to be retrieved.
+ #
+                         next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
+                                                         $minor,\%homecourses,\@ids));
+                     }
+                 }
+             }
  	    if ($regexp eq '.') {
  		$count++;
  		if (defined($range) && $count >= $end)   { last; }
- Line 3103  sub dump_with_regexp {
+ Line 3368  sub dump_with_regexp {
  	    }
  	}
  	if (&untie_user_hash($hashref)) {
+ #
+ # If dump is for roles.db from a pre-2.10 server, check if the LON-CAPA
+ # version requirements for courses for which the current server is the home
+ # server permit course roles to be usable on the client server hosting the
+ # user's session. If so, include those role results in the data returned to
+ # the client server.
+ #
+             if (($namespace eq 'roles') && (!$skipcheck)) {
+                 if (keys(%homecourses) > 0) {
+                     $qresult .= &check_homecourses(\%homecourses,$regexp,$count,
+                                                    $range,$start,$end,$major,$minor);
+                 }
+             }
  	    chop($qresult);
  	    &Reply($client, \$qresult, $userinput);
  	} else {
- Line 3651  sub put_course_id_hash_handler {
+ Line 3929  sub put_course_id_hash_handler {
  #                            will be returned. Pre-2.2.0 legacy entries from
  #                            nohist_courseiddump will only contain usernames.
  #                 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
  #                            each matched item as a frozen hash of all
  #                            key, value pairs in the item's hash, or as a
- Line 3668  sub put_course_id_hash_handler {
+ Line 3948  sub put_course_id_hash_handler {
  #                 caller -  if set to 'coursecatalog', courses set to be hidden
  #                           from course catalog will be excluded from results (unless
  #                           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.
  # Returns:
- Line 3680  sub dump_course_id_handler {
+ Line 3972  sub dump_course_id_handler {
      my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
          $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 ($cloneruname,$clonerudom,%cc_clone);
      if (defined($description)) {
  	$description=&unescape($description);
      } else {
- Line 3724  sub dump_course_id_handler {
+ Line 4018  sub dump_course_id_handler {
      if (defined($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;
-     if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
+     if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' &&
          $typefilter eq '.') {
          $unpack = 0;
      }
- Line 3735  sub dump_course_id_handler {
+ Line 4057  sub dump_course_id_handler {
      if ($hashref) {
  	while (my ($key,$value) = each(%$hashref)) {
              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);
              if ($unesc_key =~ /^lasttime:/) {
                  next;
- Line 3746  sub dump_course_id_handler {
+ Line 4069  sub dump_course_id_handler {
                  $lasttime = $hashref->{$lasttime_key};
                  next if ($lasttime<$since);
              }
+             my ($canclone,$valchange);
              my $items = &Apache::lonnet::thaw_unescape($value);
              if (ref($items) eq 'HASH') {
+                 if ($hashref->{$lasttime_key} eq '') {
+                     next if ($since > 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) {
                      $unesc_val{'descr'} = $items->{'description'};
                      $unesc_val{'inst_code'} = $items->{'inst_code'};
                      $unesc_val{'owner'} = $items->{'owner'};
                      $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_end = $items->{'selfenroll_end_date'};
+                 $created = $items->{'created'};
+                 $context = $items->{'context'};
                  if ($selfenrollonly) {
                      next if (!$selfenroll_types);
                      if (($selfenroll_end > 0) && ($selfenroll_end <= $now)) {
                          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 '') {
                      next if ($items->{'categories'} eq '');
                      my @categories = split('&',$items->{'categories'});
- Line 3784  sub dump_course_id_handler {
+ Line 4170  sub dump_course_id_handler {
                  }
              } else {
                  next if ($catfilter ne '');
                  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;
                  my @courseitems = split(/:/,$value);
                  $lasttime = pop(@courseitems);
- Line 3793  sub dump_course_id_handler {
+ Line 4187  sub dump_course_id_handler {
                  }
  	        ($val{'descr'},$val{'inst_code'},$val{'owner'},$val{'type'}) = @courseitems;
              }
+             if ($cloneonly) {
+                next unless ($canclone);
+             }
              my $match = 1;
  	    if ($description ne '.') {
                  if (!$is_hash) {
- Line 3806  sub dump_course_id_handler {
+ Line 4203  sub dump_course_id_handler {
                  if (!$is_hash) {
                      $unesc_val{'inst_code'} = &unescape($val{'inst_code'});
                  }
-                 if ($regexp_ok) {
+                 if ($regexp_ok == 1) {
                      if (eval{$unesc_val{'inst_code'} !~ /$instcodefilter/}) {
                          $match = 0;
                      }
+                 } elsif ($regexp_ok == -1) {
+                     if (eval{$unesc_val{'inst_code'} =~ /$instcodefilter/}) {
+                         $match = 0;
+                     }
                  } else {
                      if (eval{$unesc_val{'inst_code'} !~ /\Q$instcodefilter\E/i}) {
                          $match = 0;
- Line 3875  sub dump_course_id_handler {
+ Line 4276  sub dump_course_id_handler {
              if ($match == 1) {
                  if ($rtn_as_hash) {
                      if ($is_hash) {
-                         $qresult.=$key.'='.$value.'&';
+                         if ($valchange) {
+                             my $newvalue = &Apache::lonnet::freeze_escape($items);
+                             $qresult.=$key.'='.$newvalue.'&';
+                         } else {
+                             $qresult.=$key.'='.$value.'&';
+                         }
                      } else {
                          my %rtnhash = ( 'description' => &unescape($val{'descr'}),
                                          'inst_code' => &unescape($val{'inst_code'}),
                                          'owner'     => &unescape($val{'owner'}),
                                          'type'      => &unescape($val{'type'}),
+                                         'cloners'   => &unescape($val{'cloners'}),
                                        );
                          my $items = &Apache::lonnet::freeze_escape(\%rtnhash);
                          $qresult.=$key.'='.$items.'&';
- Line 3912  sub dump_course_id_handler {
+ Line 4319  sub dump_course_id_handler {
  }
  &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
  #
- Line 3977  sub put_domain_handler {
+ Line 4431  sub put_domain_handler {
  sub get_domain_handler {
      my ($cmd, $tail, $client) = @_;
      my $userinput = "$client:$tail";
      my ($udom,$namespace,$what)=split(/:/,$tail,3);
- Line 4004  sub get_domain_handler {
+ Line 4459  sub get_domain_handler {
  }
  &register_handler("getdom", \&get_domain_handler, 0, 1, 0);
  #
  #  Puts an id to a domains id database.
  #
- Line 4122  sub get_id_handler {
+ Line 4576  sub get_id_handler {
  sub put_dcmail_handler {
      my ($cmd,$tail,$client) = @_;
      my $userinput = "$cmd:$tail";
      my ($udom,$what)=split(/:/,$tail);
      chomp($what);
      my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
- Line 4311  sub dump_domainroles_handler {
+ Line 4766  sub dump_domainroles_handler {
          $rolesfilter=&unescape($rolesfilter);
  	@roles = split(/\&/,$rolesfilter);
      }
      my $hashref = &tie_domain_hash($udom, "nohist_domainroles", &GDBM_WRCREAT());
      if ($hashref) {
          my $qresult = '';
          while (my ($key,$value) = each(%$hashref)) {
              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));
-             unless ($startfilter eq '.' || !defined($startfilter)) {
+             unless (@roles < 1) {
-                 if ((defined($start)) && ($start >= $startfilter)) {
+                 unless (grep/^\Q$trole\E$/,@roles) {
                      $match = 0;
+                     next;
                  }
              }
-             unless ($endfilter eq '.' || !defined($endfilter)) {
+             unless ($startfilter eq '.' || !defined($startfilter)) {
-                 if ((defined($end)) && ($end <= $endfilter)) {
+                 if ((defined($start)) && ($start >= $startfilter)) {
                      $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;
+                     next;
                  }
              }
              if ($match == 1) {
- Line 4383  sub tmp_put_handler {
+ Line 4841  sub tmp_put_handler {
      }
      my ($id,$store);
      $tmpsnum++;
-     if ($context eq 'resetpw') {
+     if (($context eq 'resetpw') || ($context eq 'createaccount')) {
          $id = &md5_hex(&md5_hex(time.{}.rand().$$));
      } else {
          $id = $$.'_'.$clientip.'_'.$tmpsnum;
- Line 4618  sub enrollment_enabled_handler {
+ Line 5076  sub enrollment_enabled_handler {
  }
  &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.
  #   Since the admin people won't know about 'unofficial sections'
  #   we cannot auto-enroll on them.
- Line 4664  sub get_sections_handler {
+ Line 5159  sub get_sections_handler {
  sub validate_course_owner_handler {
      my ($cmd, $tail, $client)  = @_;
      my $userinput = "$cmd:$tail";
-     my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);
+     my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail);
      $owner = &unescape($owner);
-     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
+     $coowners = &unescape($coowners);
+     my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);
      &Reply($client, \$outcome, $userinput);
- Line 4821  sub retrieve_auto_file_handler {
+ Line 5317  sub retrieve_auto_file_handler {
  }
  &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).
  # Formal Parameters:
- Line 4905  sub get_institutional_defaults_handler {
+ Line 5456  sub get_institutional_defaults_handler {
  &register_handler("autoinstcodedefaults",
                    \&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 {
      my ($cmd, $tail, $client)   = @_;
      my $userinput               = "$cmd:$tail";
- Line 5567  if (-e $pidfile) {
+ Line 6151  if (-e $pidfile) {
  $server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
                                  Type      => SOCK_STREAM,
                                  Proto     => 'tcp',
-                                 Reuse     => 1,
+                                 ReuseAddr     => 1,
                                  Listen    => 10 )
    or die "making socket: $@\n";
- Line 5630  sub HUPSMAN {                      # sig
+ Line 6214  sub HUPSMAN {                      # sig
  #  a setuid perl script that can be root for us to do this job.
  #
  sub ReloadApache {
-     my $execdir = $perlvar{'lonDaemons'};
+ # --------------------------- Handle case of another apachereload process (locking)
-     my $script  = $execdir."/apachereload";
+     if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) {
-     system($script);
+         my $execdir = $perlvar{'lonDaemons'};
+         my $script  = $execdir."/apachereload";
+         system($script);
+         unlink('/tmp/lock_apachereload'); #  Remove the lock file.
+     }
  }
  #
- Line 5805  sub logstatus {
+ Line 6393  sub logstatus {
  sub initnewstatus {
      my $docdir=$perlvar{'lonDocRoot'};
      my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
-     my $now=time;
+     my $now=time();
      my $local=localtime($now);
      print $fh "LOND status $local - parent $$\n\n";
      opendir(DIR,"$docdir/lon-status/londchld");
- Line 5894  $SIG{USR2} = \&UpdateHosts;
+ Line 6482  $SIG{USR2} = \&UpdateHosts;
  #  Read the host hashes:
  &Apache::lonnet::load_hosts_tab();
+ my %iphost = &Apache::lonnet::get_iphost(1);
- my $dist=`$perlvar{'lonDaemons'}/distprobe`;
+ $dist=`$perlvar{'lonDaemons'}/distprobe`;
+ my $arch = `uname -i`;
+ chomp($arch);
+ if ($arch eq 'unknown') {
+     $arch = `uname -m`;
+     chomp($arch);
+ }
  # --------------------------------------------------------------
  #   Accept connections.  When a connection comes in, it is validated
- Line 5954  sub make_new_child {
+ Line 6550  sub make_new_child {
              or die "Can't unblock SIGINT for fork: $!\n";
          $children{$pid} = $clientip;
          &status('Started child '.$pid);
+ 	close($client);
          return;
      } else {
          # Child can *not* return from this subroutine.
- Line 5962  sub make_new_child {
+ Line 6559  sub make_new_child {
                                  #don't get intercepted
          $SIG{USR1}= \&logstatus;
          $SIG{ALRM}= \&timeout;
+ 	#
+ 	# Block sigpipe as it gets thrownon socket disconnect and we want to
+ 	# deal with that as a read faiure instead.
+ 	#
+ 	my $blockset = POSIX::SigSet->new(SIGPIPE);
+ 	sigprocmask(SIG_BLOCK, $blockset);
          $lastlog='Forked ';
          $status='Forked';
- Line 5973  sub make_new_child {
+ Line 6577  sub make_new_child {
  #---------------------------------------------------- kerberos 5 initialization
          &Authen::Krb5::init_context();
  	unless (($dist eq 'fedora5') || ($dist eq 'fedora4') ||
- 		($dist eq 'fedora6') || ($dist eq 'suse9.3')) {
+ 		($dist eq 'fedora6') || ($dist eq 'suse9.3') ||
+                 ($dist eq 'suse12.2')) {
  	    &Authen::Krb5::init_ets();
  	}
- Line 5987  sub make_new_child {
+ Line 6592  sub make_new_child {
  	if ($clientip eq '127.0.0.1') {
  	    $outsideip=&Apache::lonnet::get_host_ip($perlvar{'lonHostID'});
  	}
+ 	&ReadManagerTable();
  	my $clientrec=defined(&Apache::lonnet::get_hosts_from_ip($outsideip));
  	my $ismanager=($managers{$outsideip}    ne undef);
- 	$clientname  = "[unknonwn]";
+ 	$clientname  = "[unknown]";
  	if($clientrec) {	# Establish client type.
  	    $ConnectionType = "client";
  	    $clientname = (&Apache::lonnet::get_hosts_from_ip($outsideip))[-1];
- Line 6018  sub make_new_child {
+ Line 6623  sub make_new_child {
  		#
  		#  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
  		# certificate files yet, then I'll drop  back to
- Line 6038  sub make_new_child {
+ Line 6643  sub make_new_child {
  		}
  		if($inittype eq "local") {
+                     $clientversion = $perlvar{'lonVersion'};
  		    my $key = LocalConnection($client, $remotereq);
  		    if($key) {
  			Debug("Got local key $key");
- Line 6045  sub make_new_child {
+ Line 6651  sub make_new_child {
  			my $cipherkey = pack("H32", $key);
  			$cipher       = new IDEA($cipherkey);
  			print $client "ok:local\n";
- 			&logthis('<font color="green"'
+ 			&logthis('<font color="green">'
  				 . "Successful local authentication </font>");
  			$keymode = "local"
  		    } else {
- Line 6109  sub make_new_child {
+ Line 6715  sub make_new_child {
  # ------------------------------------------------------------ Process requests
  	    my $keep_going = 1;
  	    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) {
  		alarm(120);
  		Debug("Main: Got $user_input\n");
- Line 6158  sub is_author {
+ Line 6767  sub is_author {
      #  Author role should show up as a key /domain/_au
-     my $key    = "/$domain/_au";
      my $value;
-     if (defined($hashref)) {
+     if ($hashref) {
- 	$value = $hashref->{$key};
-     }
-     if(defined($value)) {
+ 	my $key    = "/$domain/_au";
- 	&Debug("$user @ $domain is an author");
+ 	if (defined($hashref)) {
+ 	    $value = $hashref->{$key};
+ 	    if(!untie_user_hash($hashref)) {
+ 		return 'error: ' .  ($!+0)." untie (GDBM) Failed";
+ 	    }
+ 	}
+ 	if(defined($value)) {
+ 	    &Debug("$user @ $domain is an author");
+ 	}
+     } else {
+ 	return 'error: '.($!+0)." tie (GDBM) Failed";
      }
      return defined($value);
  }
  #
  #   Checks to see if the input roleput request was to set
- # an author role.  If so, invokes the lchtmldir script to set
+ # an author role.  If so, creates construction space
- # up a correct public_html
  # Parameters:
  #    request   - The request sent to the rolesput subchunk.
  #                We're looking for  /domain/_au
- Line 6183  sub is_author {
+ Line 6799  sub is_author {
  #
  sub manage_permissions {
      my ($request, $domain, $user, $authtype) = @_;
-     &Debug("manage_permissions: $request $domain $user $authtype");
      # See if the request is of the form /$domain/_au
      if($request =~ /^(\/\Q$domain\E\/_au)$/) { # It's an author rolesput...
- 	my $execdir = $perlvar{'lonDaemons'};
+         my $path=$perlvar{'lonDocRoot'}."/priv/$domain";
- 	my $userhome= "/home/$user" ;
+         unless (-e $path) {
- 	&logthis("system $execdir/lchtmldir $userhome $user $authtype");
+            mkdir($path);
- 	&Debug("Setting homedir permissions for $userhome");
+         }
- 	system("$execdir/lchtmldir $userhome $user $authtype");
+         unless (-e $path.'/'.$user) {
+            mkdir($path.'/'.$user);
+         }
      }
  }
- Line 6267  sub rewrite_password_file {
+ Line 6882  sub rewrite_password_file {
  #     Returns the authorization type or nouser if there is no such user.
  #
- sub get_auth_type
+ sub get_auth_type {
- {
      my ($domain, $user)  = @_;
      Debug("get_auth_type( $domain, $user ) \n");
- Line 6364  sub validate_user {
+ Line 6977  sub validate_user {
  	    } else {
  		$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) {
-,
+                     $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.
- 	    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") {
  	    #  Authenticate via installation specific authentcation method:
  	    $validated = &localauth::localauth($user,
- Line 6442  sub validate_user {
+ Line 7025  sub validate_user {
      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,
+,
+                                                        $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 {
      my ($fname,$hostid,$ip,$newline)=@_;
- Line 6654  sub subscribe {
+ Line 7296  sub subscribe {
                  # the metadata
  		unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); }
  		$fname=~s/\/home\/httpd\/html\/res/raw/;
- 		$fname="http://".&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
+                 my $protocol = $Apache::lonnet::protocol{$perlvar{'lonHostID'}};
+                 $protocol = 'http' if ($protocol ne 'https');
+ 		$fname=$protocol.'://'.&Apache::lonnet::hostname($perlvar{'lonHostID'})."/".$fname;
  		$result="$fname\n";
  	    }
  	} else {
- Line 6696  sub change_unix_password {
+ Line 7340  sub change_unix_password {
  sub make_passwd_file {
-     my ($uname, $umode,$npass,$passfilename)=@_;
+     my ($uname,$udom,$umode,$npass,$passfilename)=@_;
      my $result="ok";
      if ($umode eq 'krb4' or $umode eq 'krb5') {
  	{
- Line 6737  sub make_passwd_file {
+ Line 7381  sub make_passwd_file {
  	    #
  	    my $uid = getpwnam($uname);
  	    if((defined $uid) && ($uid == 0)) {
- 		&logthis(">>>Attempted to create privilged account blocked");
+ 		&logthis(">>>Attempt to create privileged account blocked");
  		return "no_priv_account_error\n";
  	    }
- Line 6749  sub make_passwd_file {
+ Line 7393  sub make_passwd_file {
  		&Debug("user  = ".$uname.", Password =". $npass);
  		my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log");
  		print $se "$uname\n";
+                 print $se "$udom\n";
  		print $se "$npass\n";
  		print $se "$npass\n";
  		print $se "$lc_error_file\n"; # Status -> unique file.
- Line 6812  sub sethost {
+ Line 7457  sub sethost {
  	eq &Apache::lonnet::get_host_ip($hostid)) {
  	$currenthostid  =$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 {
  	&logthis("Requested host id $hostid not an alias of ".
  		 $perlvar{'lonHostID'}." refusing connection");
- Line 6827  sub version {
+ Line 7472  sub 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;
+ }
+ #
+ # releasereqd_check() will determine if a LON-CAPA version (defined in the
+ # $major,$minor args passed) is not too old to allow use of a role in a
+ # course ($cnum,$cdom args passed), if at least one of the following applies:
+ # (a) the course is a Community, (b) the course's home server is *not* the
+ # current server, or (c) cached course information is not stale.
+ #
+ # For the case where none of these apply, the course is added to the
+ # $homecourse hash ref (keys = courseIDs, values = array of a hash of roles).
+ # The $homecourse hash ref is for courses for which the current server is the
+ # home server.  LON-CAPA version requirements are checked elsewhere for the
+ # items in $homecourse.
+ #
+ sub releasereqd_check {
+     my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
+     my $home = &Apache::lonnet::homeserver($cnum,$cdom);
+     return if ($home eq 'no_host');
+     my ($reqdmajor,$reqdminor,$displayrole);
+     if ($cnum =~ /$LONCAPA::match_community/) {
+         if ($major eq '' && $minor eq '') {
+             return unless ((ref($ids) eq 'ARRAY') &&
+                            (grep(/^\Q$home\E$/,@{$ids})));
+         } else {
+             $reqdmajor = 2;
+             $reqdminor = 9;
+             return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
+         }
+     }
+     my $hashid = $cdom.':'.$cnum;
+     my ($courseinfo,$cached) =
+         &Apache::lonnet::is_cached_new('courseinfo',$hashid);
+     if (defined($cached)) {
+         if (ref($courseinfo) eq 'HASH') {
+             if (exists($courseinfo->{'releaserequired'})) {
+                 my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
+                 return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
+             }
+         }
+     } else {
+         if (ref($ids) eq 'ARRAY') {
+             if (grep(/^\Q$home\E$/,@{$ids})) {
+                 if (ref($homecourses) eq 'HASH') {
+                     if (ref($homecourses->{$cdom}) eq 'HASH') {
+                         if (ref($homecourses->{$cdom}{$cnum}) eq 'HASH') {
+                             if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
+                                 push(@{$homecourses->{$cdom}{$cnum}},{$key=>$value});
+                             } else {
+                                 $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
+                             }
+                         } else {
+                             $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
+                         }
+                     } else {
+                         $homecourses->{$cdom}{$cnum} = [{$key=>$value}];
+                     }
+                 }
+                 return;
+             }
+         }
+         my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
+         if (ref($courseinfo) eq 'HASH') {
+             if (exists($courseinfo->{'releaserequired'})) {
+                 my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
+                 return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
+             }
+         } else {
+             return;
+         }
+     }
+     return 1;
+ }
+ #
+ # get_courseinfo_hash() is used to retrieve course information from the db
+ # file: nohist_courseids.db for a course for which the current server is *not*
+ # the home server.
+ #
+ # A hash of a hash will be retrieved. The outer hash contains a single key --
+ # courseID -- for the course for which the data are being requested.
+ # The contents of the inner hash, for that single item in the outer hash
+ # are returned (and cached in memcache for 10 minutes).
+ #
+ sub get_courseinfo_hash {
+     my ($cnum,$cdom,$home) = @_;
+     my %info;
+     eval {
+         local($SIG{ALRM}) = sub { die "timeout\n"; };
+         local($SIG{__DIE__})='DEFAULT';
+         alarm(3);
+         %info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
+         alarm(0);
+     };
+     if ($@) {
+         if ($@ eq "timeout\n") {
+             &logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
+         } else {
+             &logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
+         }
+     } else {
+         if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
+             my $hashid = $cdom.':'.$cnum;
+             return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
+         }
+     }
+     return;
+ }
+ #
+ # check_homecourses() will retrieve course information for those courses which
+ # are keys of the $homecourses hash ref (first arg). The nohist_courseids.db
+ # GDBM file is tied and course information for each course retrieved. Last
+ # visit (lasttime key) is also retrieved for each, and cached values updated
+ # for any courses last visited less than 24 hours ago. Cached values are also
+ # updated for any courses included in the $homecourses hash ref.
+ #
+ # The reason for the 24 hours constraint is that the cron entry in
+ # /etc/cron.d/loncapa for /home/httpd/perl/refresh_courseids_db.pl causes
+ # cached course information to be updated nightly for courses with activity
+ # within the past 24 hours.
+ #
+ # Role information for the user (included in a ref to an array of hashes as the
+ # value for each key in $homecourses) is appended to the result returned by the
+ # routine, which will in turn be appended to the string returned to the client
+ # hosting the user's session.
+ #
+ sub check_homecourses {
+     my ($homecourses,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
+     my ($result,%addtocache);
+     my $yesterday = time - 24*3600;
+     if (ref($homecourses) eq 'HASH') {
+         my (%okcourses,%courseinfo,%recent);
+         foreach my $domain (keys(%{$homecourses})) {
+             my $hashref =
+                 &tie_domain_hash($domain, "nohist_courseids", &GDBM_WRCREAT());
+             if (ref($hashref) eq 'HASH') {
+                 while (my ($key,$value) = each(%$hashref)) {
+                     my $unesc_key = &unescape($key);
+                     if ($unesc_key =~ /^lasttime:(\w+)$/) {
+                         my $cid = $1;
+                         $cid =~ s/_/:/;
+                         if ($value > $yesterday ) {
+                             $recent{$cid} = 1;
+                         }
+                         next;
+                     }
+                     my $items = &Apache::lonnet::thaw_unescape($value);
+                     if (ref($items) eq 'HASH') {
+                         my ($cdom,$cnum) = split(/_/,$unesc_key);
+                         my $hashid = $cdom.':'.$cnum;
+                         $courseinfo{$hashid} = $items;
+                         if (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY') {
+                             my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
+                             if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
+                                $okcourses{$hashid} = 1;
+                             }
+                         }
+                     }
+                 }
+                 unless (&untie_domain_hash($hashref)) {
+                     &logthis("Failed to untie tied hash for nohist_courseids.db for $domain");
+                 }
+             } else {
+                 &logthis("Failed to tie hash for nohist_courseids.db for $domain");
+             }
+         }
+         foreach my $hashid (keys(%recent)) {
+             my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
+             unless ($cached) {
+                 &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
+             }
+         }
+         foreach my $cdom (keys(%{$homecourses})) {
+             if (ref($homecourses->{$cdom}) eq 'HASH') {
+                 foreach my $cnum (keys(%{$homecourses->{$cdom}})) {
+                     my $hashid = $cdom.':'.$cnum;
+                     next if ($recent{$hashid});
+                     &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
+                 }
+             }
+         }
+         foreach my $hashid (keys(%okcourses)) {
+             my ($cdom,$cnum) = split(/:/,$hashid);
+             if ((ref($homecourses->{$cdom}) eq 'HASH') &&
+                 (ref($homecourses->{$cdom}{$cnum}) eq 'ARRAY')) {
+                 foreach my $role (@{$homecourses->{$cdom}{$cnum}}) {
+                     if (ref($role) eq 'HASH') {
+                         while (my ($key,$value) = each(%{$role})) {
+                             if ($regexp eq '.') {
+                                 $count++;
+                                 if (defined($range) && $count >= $end)   { last; }
+                                 if (defined($range) && $count <  $start) { next; }
+                                 $result.=$key.'='.$value.'&';
+                             } else {
+                                 my $unescapeKey = &unescape($key);
+                                 if (eval('$unescapeKey=~/$regexp/')) {
+                                     $count++;
+                                     if (defined($range) && $count >= $end)   { last; }
+                                     if (defined($range) && $count <  $start) { next; }
+                                     $result.="$key=$value&";
+                                 }
+                             }
+                         }
+                     }
+                 }
+             }
+         }
+     }
+     return $result;
+ }
+ #
+ # useable_role() will compare the LON-CAPA version required by a course with
+ # the version available on the client server.  If the client server's version
+ # is compatible, 1 will be returned.
+ #
+ sub useable_role {
+     my ($reqdmajor,$reqdminor,$major,$minor) = @_;
+     if ($reqdmajor ne '' && $reqdminor ne '') {
+         return if (($major eq '' && $minor eq '') ||
+                    ($major < $reqdmajor) ||
+                    (($major == $reqdmajor) && ($minor < $reqdminor)));
+     }
+     return 1;
+ }
+ sub distro_and_arch {
+     return $dist.':'.$arch;
+ }
  # ----------------------------------- POD (plain old documentation, CPAN style)
- Line 7035  Place in B<logs/lond.log>
+ Line 7927  Place in B<logs/lond.log>
  stores hash in namespace
- =item rolesputy
+ =item rolesput
  put a role into a user's environment
- Line 7562  string.
+ Line 8454  string.
  =back
+ =back
  =cut

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

Removed from v.1.410.2.2
changed lines
	Added in v.1.489.2.2