--- loncom/lonnet/perl/lonnet.pm 2014/10/24 00:37:15 1.1172.2.56
+++ loncom/lonnet/perl/lonnet.pm 2016/08/05 15:34:27 1.1172.2.72
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1172.2.56 2014/10/24 00:37:15 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.72 2016/08/05 15:34:27 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -417,8 +417,8 @@ sub reply {
sub reconlonc {
my ($lonid) = @_;
- my $hostname = &hostname($lonid);
if ($lonid) {
+ my $hostname = &hostname($lonid);
my $peerfile="$perlvar{'lonSockDir'}/$hostname";
if ($hostname && -e $peerfile) {
&logthis("Trying to reconnect lonc for $lonid ($hostname)");
@@ -464,7 +464,7 @@ sub critical {
}
my $answer=reply($cmd,$server);
if ($answer eq 'con_lost') {
- &reconlonc("$perlvar{'lonSockDir'}/$server");
+ &reconlonc($server);
my $answer=reply($cmd,$server);
if ($answer eq 'con_lost') {
my $now=time;
@@ -844,10 +844,8 @@ sub spareserver {
if (ref($spareshash) eq 'HASH') {
if (ref($spareshash->{'primary'}) eq 'ARRAY') {
foreach my $try_server (@{ $spareshash->{'primary'} }) {
- if ($uint_dom) {
- next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
- $try_server));
- }
+ next unless (&spare_can_host($udom,$uint_dom,$remotesessions,
+ $try_server));
($spare_server, $lowest_load) =
&compare_server_load($try_server, $spare_server, $lowest_load);
}
@@ -858,10 +856,8 @@ sub spareserver {
if (!$found_server) {
if (ref($spareshash->{'default'}) eq 'ARRAY') {
foreach my $try_server (@{ $spareshash->{'default'} }) {
- if ($uint_dom) {
- next unless (&spare_can_host($udom,$uint_dom,
- $remotesessions,$try_server));
- }
+ next unless (&spare_can_host($udom,$uint_dom,
+ $remotesessions,$try_server));
($spare_server, $lowest_load) =
&compare_server_load($try_server, $spare_server, $lowest_load);
}
@@ -1173,19 +1169,27 @@ sub can_host_session {
sub spare_can_host {
my ($udom,$uint_dom,$remotesessions,$try_server)=@_;
my $canhost=1;
- my @intdoms;
- my $internet_names = &Apache::lonnet::get_internet_names($try_server);
- if (ref($internet_names) eq 'ARRAY') {
- @intdoms = @{$internet_names};
- }
- unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
- my $serverhomeID = &Apache::lonnet::get_server_homeID($try_server);
- my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID);
- my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom);
- my $remoterev = &Apache::lonnet::get_server_loncaparev(undef,$try_server);
- $canhost = &can_host_session($udom,$try_server,$remoterev,
- $remotesessions,
- $defdomdefaults{'hostedsessions'});
+ my $try_server_hostname = &hostname($try_server);
+ my $serverhomeID = &get_server_homeID($try_server_hostname);
+ my $serverhomedom = &host_domain($serverhomeID);
+ my %defdomdefaults = &get_domain_defaults($serverhomedom);
+ if (ref($defdomdefaults{'offloadnow'}) eq 'HASH') {
+ if ($defdomdefaults{'offloadnow'}{$try_server}) {
+ $canhost = 0;
+ }
+ }
+ if (($canhost) && ($uint_dom)) {
+ my @intdoms;
+ my $internet_names = &get_internet_names($try_server);
+ if (ref($internet_names) eq 'ARRAY') {
+ @intdoms = @{$internet_names};
+ }
+ unless (grep(/^\Q$uint_dom\E$/,@intdoms)) {
+ my $remoterev = &get_server_loncaparev(undef,$try_server);
+ $canhost = &can_host_session($udom,$try_server,$remoterev,
+ $remotesessions,
+ $defdomdefaults{'hostedsessions'});
+ }
}
return $canhost;
}
@@ -1647,6 +1651,7 @@ sub dump_dom {
sub get_dom {
my ($namespace,$storearr,$udom,$uhome)=@_;
+ return if ($udom eq 'public');
my $items='';
foreach my $item (@$storearr) {
$items.=&escape($item).'&';
@@ -1654,6 +1659,7 @@ sub get_dom {
$items=~s/\&$//;
if (!$udom) {
$udom=$env{'user.domain'};
+ return if ($udom eq 'public');
if (defined(&domain($udom,'primary'))) {
$uhome=&domain($udom,'primary');
} else {
@@ -1928,6 +1934,63 @@ sub get_instuser {
return ($outcome,%userinfo);
}
+sub get_multiple_instusers {
+ my ($udom,$users,$caller) = @_;
+ my ($outcome,$results);
+ if (ref($users) eq 'HASH') {
+ my $count = keys(%{$users});
+ my $requested = &freeze_escape($users);
+ my $homeserver = &domain($udom,'primary');
+ if ($homeserver ne '') {
+ my $queryid=&reply('querysend:getmultinstusers:::'.$caller.'='.$requested,$homeserver);
+ my $host=&hostname($homeserver);
+ if ($queryid !~/^\Q$host\E\_/) {
+ &logthis('get_multiple_instusers invalid queryid: '.$queryid.
+ ' for host: '.$homeserver.'in domain '.$udom);
+ return ($outcome,$results);
+ }
+ my $response = &get_query_reply($queryid);
+ my $maxtries = 5;
+ if ($count > 100) {
+ $maxtries = 1+int($count/20);
+ }
+ my $tries = 1;
+ while (($response=~/^timeout/) && ($tries <= $maxtries)) {
+ $response = &get_query_reply($queryid);
+ $tries ++;
+ }
+ if ($response eq '') {
+ $results = {};
+ foreach my $key (keys(%{$users})) {
+ my ($uname,$id);
+ if ($caller eq 'id') {
+ $id = $key;
+ } else {
+ $uname = $key;
+ }
+ my ($resp,%info) = &get_instuser($udom,$uname,$id);
+ $outcome = $resp;
+ if ($resp eq 'ok') {
+ %{$results} = (%{$results}, %info);
+ } else {
+ last;
+ }
+ }
+ } elsif(!&error($response) && ($response ne 'refused')) {
+ if (($response eq 'unavailable') || ($response eq 'invalid') || ($response eq 'timeout')) {
+ $outcome = $response;
+ } else {
+ ($outcome,my $userdata) = split(/=/,$response,2);
+ if ($outcome eq 'ok') {
+ $results = &thaw_unescape($userdata);
+ }
+ }
+ }
+ }
+ }
+ return ($outcome,$results);
+}
+
sub inst_rulecheck {
my ($udom,$uname,$id,$item,$rules) = @_;
my %returnhash;
@@ -2068,6 +2131,11 @@ sub get_domain_defaults {
}
}
if (ref($domconfig{'coursedefaults'}) eq 'HASH') {
+ $domdefaults{'usejsme'} = $domconfig{'coursedefaults'}{'usejsme'};
+ $domdefaults{'uselcmath'} = $domconfig{'coursedefaults'}{'uselcmath'};
+ if (ref($domconfig{'coursedefaults'}{'postsubmit'}) eq 'HASH') {
+ $domdefaults{'postsubmit'} = $domconfig{'coursedefaults'}{'postsubmit'}{'client'};
+ }
foreach my $type (@coursetypes) {
if (ref($domconfig{'coursedefaults'}{'coursecredits'}) eq 'HASH') {
unless ($type eq 'community') {
@@ -2077,6 +2145,22 @@ sub get_domain_defaults {
if (ref($domconfig{'coursedefaults'}{'uploadquota'}) eq 'HASH') {
$domdefaults{$type.'quota'} = $domconfig{'coursedefaults'}{'uploadquota'}{$type};
}
+ if ($domdefaults{'postsubmit'} eq 'on') {
+ if (ref($domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}) eq 'HASH') {
+ $domdefaults{$type.'postsubtimeout'} =
+ $domconfig{'coursedefaults'}{'postsubmit'}{'timeout'}{$type};
+ }
+ }
+ }
+ if (ref($domconfig{'coursedefaults'}{'canclone'}) eq 'HASH') {
+ if (ref($domconfig{'coursedefaults'}{'canclone'}{'instcode'}) eq 'ARRAY') {
+ my @clonecodes = @{$domconfig{'coursedefaults'}{'canclone'}{'instcode'}};
+ if (@clonecodes) {
+ $domdefaults{'canclone'} = join('+',@clonecodes);
+ }
+ }
+ } elsif ($domconfig{'coursedefaults'}{'canclone'}) {
+ $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};
}
}
if (ref($domconfig{'usersessions'}) eq 'HASH') {
@@ -2086,6 +2170,9 @@ sub get_domain_defaults {
if (ref($domconfig{'usersessions'}{'hosted'}) eq 'HASH') {
$domdefaults{'hostedsessions'} = $domconfig{'usersessions'}{'hosted'};
}
+ if (ref($domconfig{'usersessions'}{'offloadnow'}) eq 'HASH') {
+ $domdefaults{'offloadnow'} = $domconfig{'usersessions'}{'offloadnow'};
+ }
}
if (ref($domconfig{'selfenrollment'}) eq 'HASH') {
if (ref($domconfig{'selfenrollment'}{'admin'}) eq 'HASH') {
@@ -2715,7 +2802,12 @@ sub ssi {
&Apache::lonenc::check_encrypt(\$fn);
if (%form) {
$request=new HTTP::Request('POST',&absolute_url().$fn);
- $request->content(join('&',map { &escape($_).'='.&escape($form{$_}) } keys(%form)));
+ $request->content(join('&',map {
+ my $name = escape($_);
+ "$name=" . ( ref($form{$_}) eq 'ARRAY'
+ ? join("&$name=", map {escape($_) } @{$form{$_}})
+ : &escape($form{$_}) );
+ } keys(%form)));
} else {
$request=new HTTP::Request('GET',&absolute_url().$fn);
}
@@ -4236,7 +4328,7 @@ sub courseiddump {
$coursefilter,$hostidflag,$hostidref,$typefilter,$regexp_ok,
$selfenrollonly,$catfilter,$showhidden,$caller,$cloner,$cc_clone,
$cloneonly,$createdbefore,$createdafter,$creationcontext,$domcloner,
- $hasuniquecode)=@_;
+ $hasuniquecode,$reqcrsdom,$reqinstcode)=@_;
my $as_hash = 1;
my %returnhash;
if (!$domfilter) { $domfilter=''; }
@@ -4259,7 +4351,8 @@ sub courseiddump {
&escape($catfilter), $showhidden, $caller,
&escape($cloner), &escape($cc_clone), $cloneonly,
&escape($createdbefore), &escape($createdafter),
- &escape($creationcontext), $domcloner, $hasuniquecode)));
+ &escape($creationcontext),$domcloner,$hasuniquecode,
+ $reqcrsdom,&escape($reqinstcode))));
} else {
$rep = &reply('courseiddump:'.&host_domain($tryserver).':'.
$sincefilter.':'.&escape($descfilter).':'.
@@ -4270,8 +4363,8 @@ sub courseiddump {
$showhidden.':'.$caller.':'.&escape($cloner).':'.
&escape($cc_clone).':'.$cloneonly.':'.
&escape($createdbefore).':'.&escape($createdafter).':'.
- &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode,
- $tryserver);
+ &escape($creationcontext).':'.$domcloner.':'.$hasuniquecode.
+ ':'.$reqcrsdom.':'.&escape($reqinstcode),$tryserver);
}
my @pairs=split(/\&/,$rep);
@@ -4410,7 +4503,7 @@ my $cachedkey='';
# The cached times for this user
my %cachedtimes=();
# When this was last done
-my $cachedtime=();
+my $cachedtime='';
sub load_all_first_access {
my ($uname,$udom)=@_;
@@ -4928,7 +5021,7 @@ sub tmprestore {
# ----------------------------------------------------------------------- Store
sub store {
- my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+ my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
my $home='';
if ($stuname) { $home=&homeserver($stuname,$domain); }
@@ -4958,13 +5051,13 @@ sub store {
}
$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
- return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
+ return reply("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
}
# -------------------------------------------------------------- Critical Store
sub cstore {
- my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
+ my ($storehash,$symb,$namespace,$domain,$stuname,$laststore) = @_;
my $home='';
if ($stuname) { $home=&homeserver($stuname,$domain); }
@@ -4995,7 +5088,7 @@ sub cstore {
$namevalue=~s/\&$//;
&courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
return critical
- ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
+ ("store:$domain:$stuname:$namespace:$symb:$namevalue:$laststore","$home");
}
# --------------------------------------------------------------------- Restore
@@ -5175,7 +5268,7 @@ sub privileged {
my %rolesdump = &dump("roles", $domain, $username) or return 0;
my $now = time;
- for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys %rolesdump}) {
+ for my $role (@rolesdump{grep { ! /^rolesdef_/ } keys(%rolesdump)}) {
my ($trole, $tend, $tstart) = split(/_/, $role);
if (grep(/^\Q$trole\E$/,@{$roles})) {
return 1 unless ($tend && $tend < $now)
@@ -5264,7 +5357,7 @@ sub rolesinit {
my %allroles=();
my %allgroups=();
- for my $area (grep { ! /^rolesdef_/ } keys %rolesdump) {
+ for my $area (grep { ! /^rolesdef_/ } keys(%rolesdump)) {
my $role = $rolesdump{$area};
$area =~ s/\_\w\w$//;
@@ -5891,7 +5984,7 @@ sub newput {
# --------------------------------------------------------- putstore interface
sub putstore {
- my ($namespace,$symb,$version,$storehash,$udomain,$uname)=@_;
+ my ($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog)=@_;
if (!$udomain) { $udomain=$env{'user.domain'}; }
if (!$uname) { $uname=$env{'user.name'}; }
my $uhome=&homeserver($uname,$udomain);
@@ -5905,6 +5998,17 @@ sub putstore {
my $reply =
&reply("putstore:$udomain:$uname:$namespace:$esc_symb:$esc_v:$items",
$uhome);
+ if (($tolog) && ($reply eq 'ok')) {
+ my $namevalue='';
+ foreach my $key (keys(%{$storehash})) {
+ $namevalue.=&escape($key).'='.&freeze_escape($storehash->{$key}).'&';
+ }
+ $namevalue .= 'ip='.&escape($ENV{'REMOTE_ADDR'}).
+ '&host='.&escape($perlvar{'lonHostID'}).
+ '&version='.$esc_v.
+ '&by='.&escape($env{'user.name'}.':'.$env{'user.domain'});
+ &Apache::lonnet::courselog($symb.':'.$uname.':'.$udomain.':PUTSTORE:'.$namevalue);
+ }
if ($reply eq 'unknown_cmd') {
# gfall back to way things use to be done
return &old_putstore($namespace,$symb,$version,$storehash,$udomain,
@@ -6097,6 +6201,9 @@ sub get_timebased_id {
} else {
$error = "error: could not obtain lockfile\n";
$dellock = 'ok';
+ if (($prefix eq 'paste') && ($namespace eq 'courseeditor') && ($keyid eq 'num')) {
+ $dellock = 'nolock';
+ }
}
return ($newid,$dellock,$error);
}
@@ -6660,7 +6767,7 @@ sub customaccess {
# ------------------------------------------------- Check for a user privilege
sub allowed {
- my ($priv,$uri,$symb,$role)=@_;
+ my ($priv,$uri,$symb,$role,$clientip,$noblockcheck)=@_;
my $ver_orguri=$uri;
$uri=&deversion($uri);
my $orguri=$uri;
@@ -6855,11 +6962,16 @@ sub allowed {
if ($match) {
if ($env{'user.priv.'.$env{'request.role'}.'./'}
=~/\Q$priv\E\&([^\:]*)/) {
- my @blockers = &has_comm_blocking($priv,$symb,$uri);
- if (@blockers > 0) {
- $thisallowed = 'B';
+ my $value = $1;
+ if ($noblockcheck) {
+ $thisallowed.=$value;
} else {
- $thisallowed.=$1;
+ my @blockers = &has_comm_blocking($priv,$symb,$uri);
+ if (@blockers > 0) {
+ $thisallowed = 'B';
+ } else {
+ $thisallowed.=$value;
+ }
}
}
} else {
@@ -6871,11 +6983,15 @@ sub allowed {
$refuri=&declutter($refuri);
my ($match) = &is_on_map($refuri);
if ($match) {
- my @blockers = &has_comm_blocking($priv,$symb,$refuri);
- if (@blockers > 0) {
- $thisallowed = 'B';
- } else {
+ if ($noblockcheck) {
$thisallowed='F';
+ } else {
+ my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+ if (@blockers > 0) {
+ $thisallowed = 'B';
+ } else {
+ $thisallowed='F';
+ }
}
}
}
@@ -6930,11 +7046,15 @@ sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;
if ($priv eq 'bre') {
- my @blockers = &has_comm_blocking($priv,$symb,$uri);
- if (@blockers > 0) {
- $thisallowed = 'B';
- } else {
+ if ($noblockcheck) {
$thisallowed.=$value;
+ } else {
+ my @blockers = &has_comm_blocking($priv,$symb,$uri);
+ if (@blockers > 0) {
+ $thisallowed = 'B';
+ } else {
+ $thisallowed.=$value;
+ }
}
} else {
$thisallowed.=$value;
@@ -6968,11 +7088,15 @@ sub allowed {
=~/\Q$priv\E\&([^\:]*)/) {
my $value = $1;
if ($priv eq 'bre') {
- my @blockers = &has_comm_blocking($priv,$symb,$refuri);
- if (@blockers > 0) {
- $thisallowed = 'B';
- } else {
+ if ($noblockcheck) {
$thisallowed.=$value;
+ } else {
+ my @blockers = &has_comm_blocking($priv,$symb,$refuri);
+ if (@blockers > 0) {
+ $thisallowed = 'B';
+ } else {
+ $thisallowed.=$value;
+ }
}
} else {
$thisallowed.=$value;
@@ -7203,6 +7327,32 @@ sub constructaccess {
return '';
}
+# ----------------------------------------------------------- Content Blocking
+
+{
+# Caches for faster Course Contents display where content blocking
+# is in operation (i.e., interval param set) for timed quiz.
+#
+# User for whom data are being temporarily cached.
+my $cacheduser='';
+# Cached blockers for this user (a hash of blocking items).
+my %cachedblockers=();
+# When the data were last cached.
+my $cachedlast='';
+
+sub load_all_blockers {
+ my ($uname,$udom,$blocks)=@_;
+ if (($uname ne '') && ($udom ne '')) {
+ if (($cacheduser eq $uname.':'.$udom) &&
+ (abs($cachedlast-time)<5)) {
+ return;
+ }
+ }
+ $cachedlast=time;
+ $cacheduser=$uname.':'.$udom;
+ %cachedblockers = &get_commblock_resources($blocks);
+}
+
sub get_comm_blocks {
my ($cdom,$cnum) = @_;
if ($cdom eq '' || $cnum eq '') {
@@ -7223,27 +7373,21 @@ sub get_comm_blocks {
return %commblocks;
}
-sub has_comm_blocking {
- my ($priv,$symb,$uri,$blocks) = @_;
- return unless ($env{'request.course.id'});
- return unless ($priv eq 'bre');
- return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
+sub get_commblock_resources {
+ my ($blocks) = @_;
+ my %blockers = ();
+ return %blockers unless ($env{'request.course.id'});
+ return %blockers if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
my %commblocks;
if (ref($blocks) eq 'HASH') {
%commblocks = %{$blocks};
} else {
%commblocks = &get_comm_blocks();
}
- return unless (keys(%commblocks) > 0);
- if (!$symb) { $symb=&symbread($uri,1); }
- my ($map,$resid,undef)=&decode_symb($symb);
- my %tocheck = (
- maps => $map,
- resources => $symb,
- );
- my @blockers;
- my $now = time;
+ return %blockers unless (keys(%commblocks) > 0);
my $navmap = Apache::lonnavmaps::navmap->new();
+ return %blockers unless (ref($navmap));
+ my $now = time;
foreach my $block (keys(%commblocks)) {
if ($block =~ /^(\d+)____(\d+)$/) {
my ($start,$end) = ($1,$2);
@@ -7251,17 +7395,13 @@ sub has_comm_blocking {
if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
- if ($commblocks{$block}{'blocks'}{'docs'}{'maps'}{$map}) {
- unless (grep(/^\Q$block\E$/,@blockers)) {
- push(@blockers,$block);
- }
+ if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
+ $blockers{$block}{maps} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
}
}
if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
- if ($commblocks{$block}{'blocks'}{'docs'}{'resources'}{$symb}) {
- unless (grep(/^\Q$block\E$/,@blockers)) {
- push(@blockers,$block);
- }
+ if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
+ $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
}
}
}
@@ -7272,32 +7412,31 @@ sub has_comm_blocking {
my @to_test;
if (ref($commblocks{$block}{'blocks'}) eq 'HASH') {
if (ref($commblocks{$block}{'blocks'}{'docs'}) eq 'HASH') {
- my $check_interval;
- if (&check_docs_block($commblocks{$block}{'blocks'}{'docs'},\%tocheck)) {
- my @interval;
- my $type = 'map';
- if ($item eq 'course') {
- $type = 'course';
- @interval=&EXT("resource.0.interval");
+ my @interval;
+ my $type = 'map';
+ if ($item eq 'course') {
+ $type = 'course';
+ @interval=&EXT("resource.0.interval");
+ } else {
+ if ($item =~ /___\d+___/) {
+ $type = 'resource';
+ @interval=&EXT("resource.0.interval",$item);
+ if (ref($navmap)) {
+ my $res = $navmap->getBySymb($item);
+ push(@to_test,$res);
+ }
} else {
- if ($item =~ /___\d+___/) {
- $type = 'resource';
- @interval=&EXT("resource.0.interval",$item);
- if (ref($navmap)) {
- my $res = $navmap->getBySymb($item);
- push(@to_test,$res);
- }
- } else {
- my $mapsymb = &symbread($item,1);
- if ($mapsymb) {
- if (ref($navmap)) {
- my $mapres = $navmap->getBySymb($mapsymb);
- @to_test = $mapres->retrieveResources($mapres,undef,0,1);
- foreach my $res (@to_test) {
- my $symb = $res->symb();
- next if ($symb eq $mapsymb);
- if ($symb ne '') {
- @interval=&EXT("resource.0.interval",$symb);
+ my $mapsymb = &symbread($item,1);
+ if ($mapsymb) {
+ if (ref($navmap)) {
+ my $mapres = $navmap->getBySymb($mapsymb);
+ @to_test = $mapres->retrieveResources($mapres,undef,0,0,0,1);
+ foreach my $res (@to_test) {
+ my $symb = $res->symb();
+ next if ($symb eq $mapsymb);
+ if ($symb ne '') {
+ @interval=&EXT("resource.0.interval",$symb);
+ if ($interval[1] eq 'map') {
last;
}
}
@@ -7305,26 +7444,35 @@ sub has_comm_blocking {
}
}
}
- if ($interval[0] =~ /\d+/) {
- my $first_access;
- if ($type eq 'resource') {
- $first_access=&get_first_access($interval[1],$item);
- } elsif ($type eq 'map') {
- $first_access=&get_first_access($interval[1],undef,$item);
- } else {
- $first_access=&get_first_access($interval[1]);
- }
- if ($first_access) {
- my $timesup = $first_access+$interval[0];
- if ($timesup > $now) {
- foreach my $res (@to_test) {
- if ($res->is_problem()) {
- if ($res->completable()) {
- unless (grep(/^\Q$block\E$/,@blockers)) {
- push(@blockers,$block);
- }
- last;
- }
+ }
+ if ($interval[0] =~ /^\d+$/) {
+ my $first_access;
+ if ($type eq 'resource') {
+ $first_access=&get_first_access($interval[1],$item);
+ } elsif ($type eq 'map') {
+ $first_access=&get_first_access($interval[1],undef,$item);
+ } else {
+ $first_access=&get_first_access($interval[1]);
+ }
+ if ($first_access) {
+ my $timesup = $first_access+$interval[0];
+ if ($timesup > $now) {
+ my $activeblock;
+ foreach my $res (@to_test) {
+ if ($res->answerable()) {
+ $activeblock = 1;
+ last;
+ }
+ }
+ if ($activeblock) {
+ if (ref($commblocks{$block}{'blocks'}{'docs'}{'maps'}) eq 'HASH') {
+ if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'maps'}})) {
+ $blockers{$block}{'maps'} = $commblocks{$block}{'blocks'}{'docs'}{'maps'};
+ }
+ }
+ if (ref($commblocks{$block}{'blocks'}{'docs'}{'resources'}) eq 'HASH') {
+ if (keys(%{$commblocks{$block}{'blocks'}{'docs'}{'resources'}})) {
+ $blockers{$block}{'resources'} = $commblocks{$block}{'blocks'}{'docs'}{'resources'};
}
}
}
@@ -7335,33 +7483,66 @@ sub has_comm_blocking {
}
}
}
- return @blockers;
+ return %blockers;
}
-sub check_docs_block {
- my ($docsblock,$tocheck) =@_;
- if ((ref($docsblock) ne 'HASH') || (ref($tocheck) ne 'HASH')) {
- return;
+sub has_comm_blocking {
+ my ($priv,$symb,$uri,$blocks) = @_;
+ my @blockers;
+ return unless ($env{'request.course.id'});
+ return unless ($priv eq 'bre');
+ return if ($env{'user.priv.'.$env{'request.role'}} =~/evb\&([^\:]*)/);
+ return if ($env{'request.state'} eq 'construct');
+ &load_all_blockers($env{'user.name'},$env{'user.domain'},$blocks);
+ return unless (keys(%cachedblockers) > 0);
+ my (%possibles,@symbs);
+ if (!$symb) {
+ $symb = &symbread($uri,1,1,1,\%possibles);
}
- if (ref($docsblock->{'maps'}) eq 'HASH') {
- if ($tocheck->{'maps'}) {
- if ($docsblock->{'maps'}{$tocheck->{'maps'}}) {
- return 1;
+ if ($symb) {
+ @symbs = ($symb);
+ } elsif (keys(%possibles)) {
+ @symbs = keys(%possibles);
+ }
+ my $noblock;
+ foreach my $symb (@symbs) {
+ last if ($noblock);
+ my ($map,$resid,$resurl)=&decode_symb($symb);
+ foreach my $block (keys(%cachedblockers)) {
+ if ($block =~ /^firstaccess____(.+)$/) {
+ my $item = $1;
+ if (($item eq $map) || ($item eq $symb)) {
+ $noblock = 1;
+ last;
+ }
}
- }
- }
- if (ref($docsblock->{'resources'}) eq 'HASH') {
- if ($tocheck->{'resources'}) {
- if ($docsblock->{'resources'}{$tocheck->{'resources'}}) {
- return 1;
+ if (ref($cachedblockers{$block}) eq 'HASH') {
+ if (ref($cachedblockers{$block}{'resources'}) eq 'HASH') {
+ if ($cachedblockers{$block}{'resources'}{$symb}) {
+ unless (grep(/^\Q$block\E$/,@blockers)) {
+ push(@blockers,$block);
+ }
+ }
+ }
+ }
+ if (ref($cachedblockers{$block}{'maps'}) eq 'HASH') {
+ if ($cachedblockers{$block}{'maps'}{$map}) {
+ unless (grep(/^\Q$block\E$/,@blockers)) {
+ push(@blockers,$block);
+ }
+ }
}
}
}
- return;
+ return if ($noblock);
+ return @blockers;
}
+}
+
+# -------------------------------- Deversion and split uri into path an filename
#
-# Removes the versino from a URI and
+# Removes the version from a URI and
# splits it in to its filename and path to the filename.
# Seems like File::Basename could have done this more clearly.
# Parameters:
@@ -8035,6 +8216,80 @@ sub auto_crsreq_update {
return \%crsreqresponse;
}
+sub check_instcode_cloning {
+ my ($codedefaults,$code_order,$cloner,$clonefromcode,$clonetocode) = @_;
+ unless ((ref($codedefaults) eq 'HASH') && (ref($code_order) eq 'ARRAY')) {
+ return;
+ }
+ my $canclone;
+ if (@{$code_order} > 0) {
+ my $instcoderegexp ='^';
+ my @clonecodes = split(/\&/,$cloner);
+ foreach my $item (@{$code_order}) {
+ if (grep(/^\Q$item\E=/,@clonecodes)) {
+ foreach my $pair (@clonecodes) {
+ my ($key,$val) = split(/\=/,$pair,2);
+ $val = &unescape($val);
+ if ($key eq $item) {
+ $instcoderegexp .= '('.$val.')';
+ last;
+ }
+ }
+ } else {
+ $instcoderegexp .= $codedefaults->{$item};
+ }
+ }
+ $instcoderegexp .= '$';
+ my (@from,@to);
+ eval {
+ (@from) = ($clonefromcode =~ /$instcoderegexp/);
+ (@to) = ($clonetocode =~ /$instcoderegexp/);
+ };
+ if ((@from > 0) && (@to > 0)) {
+ my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);
+ if (!@diffs) {
+ $canclone = 1;
+ }
+ }
+ }
+ return $canclone;
+}
+
+sub default_instcode_cloning {
+ my ($clonedom,$domdefclone,$clonefromcode,$clonetocode,$codedefaultsref,$codeorderref) = @_;
+ my (%codedefaults,@code_order,$canclone);
+ if ((ref($codedefaultsref) eq 'HASH') && (ref($codeorderref) eq 'ARRAY')) {
+ %codedefaults = %{$codedefaultsref};
+ @code_order = @{$codeorderref};
+ } elsif ($clonedom) {
+ &auto_instcode_defaults($clonedom,\%codedefaults,\@code_order);
+ }
+ if (($domdefclone) && (@code_order)) {
+ my @clonecodes = split(/\+/,$domdefclone);
+ my $instcoderegexp ='^';
+ foreach my $item (@code_order) {
+ if (grep(/^\Q$item\E$/,@clonecodes)) {
+ $instcoderegexp .= '('.$codedefaults{$item}.')';
+ } else {
+ $instcoderegexp .= $codedefaults{$item};
+ }
+ }
+ $instcoderegexp .= '$';
+ my (@from,@to);
+ eval {
+ (@from) = ($clonefromcode =~ /$instcoderegexp/);
+ (@to) = ($clonetocode =~ /$instcoderegexp/);
+ };
+ if ((@from > 0) && (@to > 0)) {
+ my @diffs = &Apache::loncommon::compare_arrays(\@from,\@to);
+ if (!@diffs) {
+ $canclone = 1;
+ }
+ }
+ }
+ return $canclone;
+}
+
# ------------------------------------------------------- Course Group routines
sub get_coursegroups {
@@ -9809,10 +10064,12 @@ sub get_userresdata {
}
#error 2 occurs when the .db doesn't exist
if ($tmp!~/error: 2 /) {
- &logthis("WARNING:".
- " Trying to get resource data for ".
- $uname." at ".$udom.": ".
- $tmp."");
+ if ((!defined($cached)) || ($tmp ne 'con_lost')) {
+ &logthis("WARNING:".
+ " Trying to get resource data for ".
+ $uname." at ".$udom.": ".
+ $tmp."");
+ }
} elsif ($tmp=~/error: 2 /) {
#&EXT_cache_set($udom,$uname);
&do_cache_new('userres',$hashid,undef,600);
@@ -10571,7 +10828,7 @@ sub metadata {
$metaentry{':keys'} = join(',',keys(%metathesekeys));
&metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
- $metaentry{':allpossiblekeys'}=join(',',keys %metathesekeys);
+ $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
&do_cache_new('meta',$uri,\%metaentry,$cachetime);
# this is the end of "was not already recently cached
}
@@ -10942,9 +11199,15 @@ sub deversion {
# ------------------------------------------------------ Return symb list entry
sub symbread {
- my ($thisfn,$donotrecurse)=@_;
+ my ($thisfn,$donotrecurse,$ignorecachednull,$checkforblock,$possibles)=@_;
my $cache_str='request.symbread.cached.'.$thisfn;
- if (defined($env{$cache_str})) { return $env{$cache_str}; }
+ if (defined($env{$cache_str})) {
+ if ($ignorecachednull) {
+ return $env{$cache_str} unless ($env{$cache_str} eq '');
+ } else {
+ return $env{$cache_str};
+ }
+ }
# no filename provided? try from environment
unless ($thisfn) {
if ($env{'request.symb'}) {
@@ -11006,18 +11269,46 @@ sub symbread {
my ($mapid,$resid)=split(/\./,$ids);
$syval=&encode_symb($bighash{'map_id_'.$mapid},
$resid,$thisfn);
- } elsif (!$donotrecurse) {
+ if (ref($possibles) eq 'HASH') {
+ $possibles->{$syval} = 1;
+ }
+ if ($checkforblock) {
+ my @blockers = &has_comm_blocking('bre',$syval,$bighash{'src_'.$ids});
+ if (@blockers) {
+ $syval = '';
+ return;
+ }
+ }
+ } elsif ((!$donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {
# ------------------------------------------ There is more than one possibility
my $realpossible=0;
foreach my $id (@possibilities) {
my $file=$bighash{'src_'.$id};
- if (&allowed('bre',$file)) {
- my ($mapid,$resid)=split(/\./,$id);
- if ($bighash{'map_type_'.$mapid} ne 'page') {
- $realpossible++;
- $syval=&encode_symb($bighash{'map_id_'.$mapid},
- $resid,$thisfn);
- }
+ my $canaccess;
+ if (($donotrecurse) || ($checkforblock) || (ref($possibles) eq 'HASH')) {
+ $canaccess = 1;
+ } else {
+ $canaccess = &allowed('bre',$file);
+ }
+ if ($canaccess) {
+ my ($mapid,$resid)=split(/\./,$id);
+ if ($bighash{'map_type_'.$mapid} ne 'page') {
+ my $poss_syval=&encode_symb($bighash{'map_id_'.$mapid},
+ $resid,$thisfn);
+ if (ref($possibles) eq 'HASH') {
+ $possibles->{$syval} = 1;
+ }
+ if ($checkforblock) {
+ my @blockers = &has_comm_blocking('bre',$poss_syval,$file);
+ unless (@blockers > 0) {
+ $syval = $poss_syval;
+ $realpossible++;
+ }
+ } else {
+ $syval = $poss_syval;
+ $realpossible++;
+ }
+ }
}
}
if ($realpossible!=1) { $syval=''; }
@@ -11025,7 +11316,7 @@ sub symbread {
$syval='';
}
}
- untie(%bighash)
+ untie(%bighash);
}
}
if ($syval) {
@@ -11995,8 +12286,8 @@ sub fetch_dns_checksums {
}
sub load_domain_tab {
- my ($ignore_cache) = @_;
- &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache);
+ my ($ignore_cache,$nocache) = @_;
+ &get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);
my $fh;
if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
my @lines = <$fh>;
@@ -12082,8 +12373,8 @@ sub fetch_dns_checksums {
}
sub load_hosts_tab {
- my ($ignore_cache) = @_;
- &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache);
+ my ($ignore_cache,$nocache) = @_;
+ &get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);
open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
my @config = <$config>;
&parse_hosts_tab(\@config);
@@ -12105,7 +12396,8 @@ sub fetch_dns_checksums {
}
sub all_names {
- &load_hosts_tab() if (!$loaded);
+ my ($ignore_cache,$nocache) = @_;
+ &load_hosts_tab($ignore_cache,$nocache) if (!$loaded);
return %name_to_host;
}
@@ -12227,7 +12519,7 @@ sub fetch_dns_checksums {
}
sub get_iphost {
- my ($ignore_cache) = @_;
+ my ($ignore_cache,$nocache) = @_;
if (!$ignore_cache) {
if (%iphost) {
@@ -12251,7 +12543,7 @@ sub fetch_dns_checksums {
%old_name_to_ip = %{$ip_info->[1]};
}
- my %name_to_host = &all_names();
+ my %name_to_host = &all_names($ignore_cache,$nocache);
foreach my $name (keys(%name_to_host)) {
my $ip;
if (!exists($name_to_ip{$name})) {
@@ -12276,9 +12568,11 @@ sub fetch_dns_checksums {
}
push(@{$iphost{$ip}},@{$name_to_host{$name}});
}
- &do_cache_new('iphost','iphost',
- [\%iphost,\%name_to_ip,\%lonid_to_ip],
- 48*60*60);
+ unless ($nocache) {
+ &do_cache_new('iphost','iphost',
+ [\%iphost,\%name_to_ip,\%lonid_to_ip],
+ 48*60*60);
+ }
return %iphost;
}
@@ -12659,7 +12953,7 @@ were new keys. I.E. 1:foo will become 1:
Calling convention:
my %record=&Apache::lonnet::restore($symb,$courseid,$domain,$uname);
- &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname);
+ &Apache::lonnet::cstore(\%newrecord,$symb,$courseid,$domain,$uname,$laststore);
For more detailed information, see lonnet specific documentation.
@@ -12795,13 +13089,29 @@ escaped strings of the action recorded i
=item *
-allowed($priv,$uri,$symb,$role) : check for a user privilege; returns codes for allowed actions
+allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege;
+returns codes for allowed actions.
+
+The first argument is required, all others are optional.
+
+$priv is the privilege being checked.
+$uri contains additional information about what is being checked for access (e.g.,
+URL, course ID etc.).
+$symb is the unique resource instance identifier in a course; if needed,
+but not provided, it will be retrieved via a call to &symbread().
+$role is the role for which a priv is being checked (only used if priv is evb).
+$clientip is the user's IP address (only used when checking for access to portfolio
+files).
+$noblockcheck, if true, skips calls to &has_comm_blocking() for the bre priv. This
+prevents recursive calls to &allowed.
+
F: full access
U,I,K: authentication modes (cxx only)
'': forbidden
1: user needs to choose course
2: browse allowed
A: passphrase authentication needed
+ B: access temporarily blocked because of a blocking event in a course.
=item *
@@ -13195,7 +13505,20 @@ will be stored for query
=item *
-symbread($filename) : return symbolic list entry (filename argument optional);
+symbread($filename,$donotrecurse,$ignorecachednull,$checkforblock,$possibles) :
+return symbolic list entry (all arguments optional).
+
+Args: filename is the filename (including path) for the file for which a symb
+is required; donotrecurse, if true will prevent calls to allowed() being made
+to check access status if more than one resource was found in the bighash
+(see rev. 1.249) to avoid an infinite loop if an ambiguous resource is part of
+a randompick); ignorecachednull, if true will prevent a symb of '' being
+returned if $env{$cache_str} is defined as ''; checkforblock if true will
+cause possible symbs to be checked to determine if they are subject to content
+blocking, if so they will not be included as possible symbs; possibles is a
+ref to a hash, which, as a side effect, will be populated with all possible
+symbs (content blocking not tested).
+
returns the data handle
=item *
@@ -13296,15 +13619,21 @@ homeserver.
=item *
-store($storehash,$symb,$namespace,$udom,$uname) : stores hash permanently
-for this url; hashref needs to be given and should be a \%hashname; the
-remaining args aren't required and if they aren't passed or are '' they will
-be derived from the env
+store($storehash,$symb,$namespace,$udom,$uname,$laststore) : stores hash
+permanently for this url; hashref needs to be given and should be a \%hashname;
+the remaining args aren't required and if they aren't passed or are '' they will
+be derived from the env (with the exception of $laststore, which is an
+optional arg used when a user's submission is stored in grading).
+$laststore is $version=$timestamp, where $version is the most recent version
+number retrieved for the corresponding $symb in the $namespace db file, and
+$timestamp is the timestamp for that transaction (UNIX time).
+$laststore is currently only passed when cstore() is called by
+structuretags::finalize_storage().
=item *
-cstore($storehash,$symb,$namespace,$udom,$uname) : same as store but
-uses critical subroutine
+cstore($storehash,$symb,$namespace,$udom,$uname,$laststore) : same as store
+but uses critical subroutine
=item *
@@ -13327,10 +13656,11 @@ $range should be either an integer '100'
=item *
-putstore($namespace,$symb,$version,$storehash,$udomain,$uname) :
+putstore($namespace,$symb,$version,$storehash,$udomain,$uname,$tolog) :
replaces a &store() version of data with a replacement set of data
for a particular resource in a namespace passed in the $storehash hash
-reference
+reference. If $tolog is true, the transaction is logged in the courselog
+with an action=PUTSTORE.
=item *
@@ -13495,7 +13825,8 @@ for course's uploaded content.
=over
=item
-canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota, communityquota, textbookquota
+canuse_pdfforms, officialcredits, unofficialcredits, textbookcredits, officialquota, unofficialquota,
+communityquota, textbookquota
=back
500 Internal Server Error
Internal Server Error
The server encountered an internal error or
misconfiguration and was unable to complete
your request.
Please contact the server administrator at
root@localhost to inform them of the time this error occurred,
and the actions you performed just before this error.
More information about this error may be available
in the server error log.