--- loncom/lonnet/perl/lonnet.pm 2015/04/13 16:30:32 1.1281
+++ loncom/lonnet/perl/lonnet.pm 2015/12/03 20:40:42 1.1296
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1281 2015/04/13 16:30:32 raeburn Exp $
+# $Id: lonnet.pm,v 1.1296 2015/12/03 20:40:42 damieng Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -92,7 +92,7 @@ use GDBM_File;
use HTML::LCParser;
use Fcntl qw(:flock);
use Storable qw(thaw nfreeze);
-use Time::HiRes qw( gettimeofday tv_interval );
+use Time::HiRes qw( sleep gettimeofday tv_interval );
use Cache::Memcached;
use Digest::MD5;
use Math::Random;
@@ -105,7 +105,7 @@ use LONCAPA::Lond;
use File::Copy;
my $readit;
-my $max_connection_retries = 10; # Or some such value.
+my $max_connection_retries = 20; # Or some such value.
require Exporter;
@@ -375,7 +375,7 @@ sub subreply {
my $lockfile=$peerfile.".lock";
while (-e $lockfile) { # Need to wait for the lockfile to disappear.
- sleep(1);
+ sleep(0.1);
}
# At this point, either a loncnew parent is listening or an old lonc
# or loncnew child is listening so we can connect or everything's dead.
@@ -393,7 +393,7 @@ sub subreply {
} else {
&create_connection(&hostname($server),$server);
}
- sleep(1); # Try again later if failed connection.
+ sleep(0.1); # Try again later if failed connection.
}
my $answer;
if ($client) {
@@ -422,8 +422,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)");
@@ -448,7 +448,7 @@ sub reconlonc {
&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;
sleep 1;
- } else {
+ } else {
&logthis(
"<font color=\"blue\">WARNING:".
" lonc at pid $loncpid not responding, giving up</font>");
@@ -469,7 +469,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;
@@ -486,7 +486,7 @@ sub critical {
close($dfh);
}
}
- sleep 2;
+ sleep 1;
my $wcmd='';
{
my $dfh;
@@ -1939,6 +1939,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;
@@ -2101,6 +2158,16 @@ sub get_domain_defaults {
}
}
}
+ 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') {
if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
@@ -4270,7 +4337,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=''; }
@@ -4293,7 +4360,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).':'.
@@ -4304,8 +4372,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);
@@ -4444,7 +4512,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)=@_;
@@ -4506,6 +4574,7 @@ sub set_first_access {
return 'already_set';
}
}
+
# --------------------------------------------- Set Expire Date for Spreadsheet
sub expirespread {
@@ -7144,7 +7213,7 @@ sub constructaccess {
my ($ownername,$ownerdomain,$ownerhome);
($ownerdomain,$ownername) =
- ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)/priv/($match_domain)/($match_username)/});
+ ($url=~ m{^(?:\Q$perlvar{'lonDocRoot'}\E|)(?:/daxeopen)?/priv/($match_domain)/($match_username)/});
# The URL does not really point to any authorspace, forget it
unless (($ownername) && ($ownerdomain)) { return ''; }
@@ -7199,6 +7268,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 '') {
@@ -7219,27 +7314,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);
@@ -7247,17 +7336,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'};
}
}
}
@@ -7268,61 +7353,68 @@ 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,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;
- }
+ 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;
}
}
}
}
}
}
- 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 ($timelimit) = split(/_/,$interval[0]);
+ 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+$timelimit;
+ 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'};
}
}
}
@@ -7333,33 +7425,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:
@@ -7611,7 +7736,7 @@ sub get_query_reply {
my $replyfile=LONCAPA::tempdir().$queryid;
my $reply='';
for (1..100) {
- sleep 2;
+ sleep(0.2);
if (-e $replyfile.'.end') {
if (open(my $fh,$replyfile)) {
$reply = join('',<$fh>);
@@ -8034,6 +8159,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 {
@@ -9380,9 +9579,9 @@ sub modify_access_controls {
my $tries = 0;
my $gotlock = &newput('file_permissions',$lockhash,$domain,$user);
- while (($gotlock ne 'ok') && $tries <3) {
+ while (($gotlock ne 'ok') && $tries < 10) {
$tries ++;
- sleep 1;
+ sleep(0.1);
$gotlock = &newput('file_permissions',$lockhash,$domain,$user);
}
if ($gotlock eq 'ok') {
@@ -9975,10 +10174,12 @@ sub get_userresdata {
}
#error 2 occurs when the .db doesn't exist
if ($tmp!~/error: 2 /) {
- &logthis("<font color=\"blue\">WARNING:".
- " Trying to get resource data for ".
- $uname." at ".$udom.": ".
- $tmp."</font>");
+ if ((!defined($cached)) || ($tmp ne 'con_lost')) {
+ &logthis("<font color=\"blue\">WARNING:".
+ " Trying to get resource data for ".
+ $uname." at ".$udom.": ".
+ $tmp."</font>");
+ }
} elsif ($tmp=~/error: 2 /) {
#&EXT_cache_set($udom,$uname);
&do_cache_new('userres',$hashid,undef,600);
@@ -11108,9 +11309,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'}) {
@@ -11172,18 +11379,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=''; }
@@ -11191,7 +11426,7 @@ sub symbread {
$syval='';
}
}
- untie(%bighash)
+ untie(%bighash);
}
}
if ($syval) {
@@ -12162,8 +12397,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>;
@@ -12249,8 +12484,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);
@@ -12272,7 +12507,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;
}
@@ -12394,7 +12630,7 @@ sub fetch_dns_checksums {
}
sub get_iphost {
- my ($ignore_cache) = @_;
+ my ($ignore_cache,$nocache) = @_;
if (!$ignore_cache) {
if (%iphost) {
@@ -12418,7 +12654,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})) {
@@ -12443,9 +12679,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;
}
@@ -12636,10 +12874,11 @@ BEGIN {
my $item = $token->[1];
my $name = $token->[2]{'name'};
my $value = $token->[2]{'value'};
- if ($item ne '' && $name ne '' && $value ne '') {
+ my $valuematch = $token->[2]{'valuematch'};
+ if ($item ne '' && $name ne '' && ($value ne '' || $valuematch ne '')) {
my $release = $parser->get_text();
$release =~ s/(^\s*|\s*$ )//gx;
- $needsrelease{$item.':'.$name.':'.$value} = $release;
+ $needsrelease{$item.':'.$name.':'.$value.':'.$valuematch} = $release;
}
}
}
@@ -12963,7 +13202,7 @@ escaped strings of the action recorded i
=item *
allowed($priv,$uri,$symb,$role,$clientip,$noblockcheck) : check for a user privilege;
-returns codes for allowed actions
+returns codes for allowed actions.
The first argument is required, all others are optional.
@@ -12976,7 +13215,7 @@ $role is the role for which a priv is be
$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.
+prevents recursive calls to &allowed.
F: full access
U,I,K: authentication modes (cxx only)
@@ -13378,7 +13617,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 *