--- loncom/lond 2011/10/24 21:30:09 1.483
+++ loncom/lond 2013/04/07 17:42:16 1.489.2.4
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.483 2011/10/24 21:30:09 www Exp $
+# $Id: lond,v 1.489.2.4 2013/04/07 17:42:16 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -34,6 +34,7 @@ use strict;
use lib '/home/httpd/lib/perl/';
use LONCAPA;
use LONCAPA::Configuration;
+use LONCAPA::Lond;
use IO::Socket;
use IO::File;
@@ -60,7 +61,7 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.483 $'; #' stupid emacs
+my $VERSION='$Revision: 1.489.2.4 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid="default";
my $currentdomainid;
@@ -2350,7 +2351,8 @@ sub fetch_user_file_handler {
my $transname=$udir.'/'.$ufile.'.in.transit';
my $clientprotocol=$Apache::lonnet::protocol{$clientname};
$clientprotocol = 'http' if ($clientprotocol ne 'https');
- my $remoteurl=$clientprotocol.'://'.$clientip.'/userfiles/'.$fname;
+ my $clienthost = &Apache::lonnet::hostname($clientname);
+ my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;
my $response;
Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
alarm(120);
@@ -2372,6 +2374,24 @@ 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);
}
}
@@ -3244,6 +3264,9 @@ 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.
@@ -3253,93 +3276,12 @@ sub dump_profile_database {
sub dump_with_regexp {
my ($cmd, $tail, $client) = @_;
+ my $res = LONCAPA::Lond::dump_with_regexp($tail, $clientversion);
- my $userinput = "$cmd:$tail";
-
- my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);
- if (defined($regexp)) {
- $regexp=&unescape($regexp);
- } else {
- $regexp='.';
- }
- my ($start,$end);
- if (defined($range)) {
- if ($range =~/^(\d+)\-(\d+)$/) {
- ($start,$end) = ($1,$2);
- } elsif ($range =~/^(\d+)$/) {
- ($start,$end) = (0,$1);
- } else {
- undef($range);
- }
- }
- my $hashref = &tie_user_hash($udom, $uname, $namespace,
- &GDBM_READER());
- my $skipcheck;
- if ($hashref) {
- my $qresult='';
- my $count=0;
- if ($extra ne '') {
- $extra = &Apache::lonnet::thaw_unescape($extra);
- $skipcheck = $extra->{'skipcheck'};
- }
- my @ids = &Apache::lonnet::current_machine_ids();
- my (%homecourses,$major,$minor,$now);
- if (($namespace eq 'roles') && (!$skipcheck)) {
- my $loncaparev = $clientversion;
- if ($loncaparev eq '') {
- $loncaparev = $Apache::lonnet::loncaparevs{$clientname};
- }
- if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
- $major = $1;
- $minor = $2;
- }
- $now = time;
- }
- 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 ($skipcheck) {
- my ($role,$end,$start) = split(/\_/,$value);
- if (!$end || $end > $now) {
- next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
- $minor,\%homecourses,\@ids));
- }
- }
- }
- }
- if ($regexp eq '.') {
- $count++;
- if (defined($range) && $count >= $end) { last; }
- if (defined($range) && $count < $start) { next; }
- $qresult.=$key.'='.$value.'&';
- } else {
- my $unescapeKey = &unescape($key);
- if (eval('$unescapeKey=~/$regexp/')) {
- $count++;
- if (defined($range) && $count >= $end) { last; }
- if (defined($range) && $count < $start) { next; }
- $qresult.="$key=$value&";
- }
- }
- }
- if (&untie_user_hash($hashref)) {
- if (($namespace eq 'roles') && (!$skipcheck)) {
- if (keys(%homecourses) > 0) {
- $qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count,
- $range,$start,$end,$major,$minor);
- }
- }
- chop($qresult);
- &Reply($client, \$qresult, $userinput);
- } else {
- &Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
- "while attempting dump\n", $userinput);
- }
+ if ($res =~ /^error:/) {
+ &Failure($client, \$res, "$cmd:$tail");
} else {
- &Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
- "while attempting dump\n", $userinput);
+ &Reply($client, \$res, "$cmd:$tail");
}
return 1;
@@ -3997,7 +3939,7 @@ sub dump_course_id_handler {
$creationcontext = '.';
}
my $unpack = 1;
- if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
+ if ($description eq '.' && $instcodefilter eq '.' && $ownerfilter eq '.' &&
$typefilter eq '.') {
$unpack = 0;
}
@@ -5054,9 +4996,10 @@ sub validate_instcode_handler {
my ($dom,$instcode,$owner) = split(/:/, $tail);
$instcode = &unescape($instcode);
$owner = &unescape($owner);
- my ($outcome,$description) =
+ my ($outcome,$description,$credits) =
&localenroll::validate_instcode($dom,$instcode,$owner);
- my $result = &escape($outcome).'&'.&escape($description);
+ my $result = &escape($outcome).'&'.&escape($description).'&'.
+ &escape($credits);
&Reply($client, \$result, $userinput);
return 1;
@@ -6527,7 +6470,8 @@ 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') || ($dist eq 'suse12.3')) {
&Authen::Krb5::init_ets();
}
@@ -6573,6 +6517,12 @@ sub make_new_child {
# If the remote is attempting a local init... give that a try:
#
(my $i, my $inittype, $clientversion) = split(/:/, $remotereq);
+ # 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.
+ # $clientversion contains path to keyfile if $inittype eq 'local'
+ # it's overridden below in this case
+ $clientversion ||= $Apache::lonnet::loncaparevs{$clientname};
# If the connection type is ssl, but I didn't get my
# certificate files yet, then I'll drop back to
@@ -6716,14 +6666,22 @@ sub is_author {
# Author role should show up as a key /domain/_au
- my $key = "/$domain/_au";
my $value;
- if (defined($hashref)) {
- $value = $hashref->{$key};
- }
+ if ($hashref) {
- if(defined($value)) {
- &Debug("$user @ $domain is an author");
+ my $key = "/$domain/_au";
+ 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);
@@ -6742,7 +6700,7 @@ sub manage_permissions {
my ($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 $path="/home/httpd/html/priv/".$domain;
+ my $path=$perlvar{'lonDocRoot'}."/priv/$domain";
unless (-e $path) {
mkdir($path);
}
@@ -7428,167 +7386,6 @@ sub get_usersession_config {
return;
}
-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->{$hashid}) eq 'ARRAY') {
- push(@{$homecourses->{$hashid}},{$key=>$value});
- } else {
- $homecourses->{$hashid} = [{$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;
-}
-
-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("WARNING courseiddump for $cnum:$cdom from $home timedout");
- } else {
- &logthis("WARNING unexpected error during eval of call for courseiddump from $home");
- }
- } 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;
-}
-
-sub check_homecourses {
- my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
- my ($result,%addtocache);
- my $yesterday = time - 24*3600;
- if (ref($homecourses) eq 'HASH') {
- my (%okcourses,%courseinfo,%recent);
- my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
- if ($hashref) {
- 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 $hashid = $unesc_key;
- $hashid =~ s/_/:/;
- $courseinfo{$hashid} = $items;
- if (ref($homecourses->{$hashid}) 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');
- }
- } else {
- &logthis('Failed to tie hash for nohist_courseids.db');
- return;
- }
- 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 $hashid (keys(%{$homecourses})) {
- next if ($recent{$hashid});
- &Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
- }
- foreach my $hashid (keys(%okcourses)) {
- if (ref($homecourses->{$hashid}) eq 'ARRAY') {
- foreach my $role (@{$homecourses->{$hashid}}) {
- 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;
-}
-
-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;
@@ -7801,7 +7598,7 @@ Place in B
stores hash in namespace
-=item rolesputy
+=item rolesput
put a role into a user's environment