--- loncom/lonnet/perl/lonnet.pm 2015/06/12 21:11:20 1.1288
+++ loncom/lonnet/perl/lonnet.pm 2016/01/26 20:17:53 1.1298
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1288 2015/06/12 21:11:20 damieng Exp $
+# $Id: lonnet.pm,v 1.1298 2016/01/26 20:17:53 raeburn 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;
@@ -101,7 +101,6 @@ use LONCAPA qw(:DEFAULT :match);
use LONCAPA::Configuration;
use LONCAPA::lonmetadata;
use LONCAPA::Lond;
-use Time::HiRes qw(sleep);
use File::Copy;
@@ -376,7 +375,7 @@ sub subreply {
my $lockfile=$peerfile.".lock";
while (-e $lockfile) { # Need to wait for the lockfile to disappear.
- Time::HiRes::sleep(0.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.
@@ -394,7 +393,7 @@ sub subreply {
} else {
&create_connection(&hostname($server),$server);
}
- Time::HiRes::sleep(0.1); # Try again later if failed connection.
+ sleep(0.1); # Try again later if failed connection.
}
my $answer;
if ($client) {
@@ -423,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)");
@@ -449,7 +448,7 @@ sub reconlonc {
&logthis("lonc at pid $loncpid responding, sending USR1");
kill USR1 => $loncpid;
sleep 1;
- } else {
+ } else {
&logthis(
"WARNING:".
" lonc at pid $loncpid not responding, giving up");
@@ -470,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;
@@ -1940,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;
@@ -2924,6 +2980,14 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
+ } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) {
+ $incourse = 1;
+ if ($env{'form.forceedit'}) {
+ $forceview = 1;
+ } else {
+ $forceedit = 1;
+ }
+ $cfile = $resurl;
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
$incourse = 1;
if ($env{'form.forceedit'}) {
@@ -2948,6 +3012,14 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
+ } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/exttools?$}) && ($env{'form.folderpath'} =~ /^supplemental/)) {
+ $incourse = 1;
+ if ($env{'form.forceedit'}) {
+ $forceview = 1;
+ } else {
+ $forceedit = 1;
+ }
+ $cfile = $resurl;
} elsif (($resurl eq '/adm/extresedit') && ($symb || $env{'form.folderpath'})) {
$incourse = 1;
$forceview = 1;
@@ -2957,8 +3029,13 @@ sub can_edit_resource {
$cfile = &clutter($res);
} else {
$cfile = $env{'form.suppurl'};
- $cfile =~ s{^http://}{};
- $cfile = '/adm/wrapper/ext/'.$cfile;
+ my $escfile = &unescape($cfile);
+ if ($escfile =~ m{^/adm/$cdom/$cnum/\d+/exttools?$}) {
+ $cfile = '/adm/wrapper'.$escfile;
+ } else {
+ $escfile =~ s{^http://}{};
+ $cfile = &escape("/adm/wrapper/ext/$escfile");
+ }
}
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
if ($env{'form.forceedit'}) {
@@ -7157,7 +7234,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|)(?:/daxepage|/daxeopen)?/priv/($match_domain)/($match_username)/});
# The URL does not really point to any authorspace, forget it
unless (($ownername) && ($ownerdomain)) { return ''; }
@@ -7330,7 +7407,8 @@ sub get_commblock_resources {
}
}
}
- if ($interval[0] =~ /^\d+$/) {
+ if ($interval[0] =~ /^\d+/) {
+ my ($timelimit) = split(/_/,$interval[0]);
my $first_access;
if ($type eq 'resource') {
$first_access=&get_first_access($interval[1],$item);
@@ -7340,7 +7418,7 @@ sub get_commblock_resources {
$first_access=&get_first_access($interval[1]);
}
if ($first_access) {
- my $timesup = $first_access+$interval[0];
+ my $timesup = $first_access+$timelimit;
if ($timesup > $now) {
my $activeblock;
foreach my $res (@to_test) {
@@ -7679,7 +7757,7 @@ sub get_query_reply {
my $replyfile=LONCAPA::tempdir().$queryid;
my $reply='';
for (1..100) {
- Time::HiRes::sleep(0.2);
+ sleep(0.2);
if (-e $replyfile.'.end') {
if (open(my $fh,$replyfile)) {
$reply = join('',<$fh>);
@@ -9524,7 +9602,7 @@ sub modify_access_controls {
while (($gotlock ne 'ok') && $tries < 10) {
$tries ++;
- Time::HiRes::sleep(0.1);
+ sleep(0.1);
$gotlock = &newput('file_permissions',$lockhash,$domain,$user);
}
if ($gotlock eq 'ok') {
@@ -10117,10 +10195,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);
@@ -10160,6 +10240,25 @@ sub resdata {
return undef;
}
+sub get_domain_ltitools {
+ my ($cdom) = @_;
+ my %ltitools;
+ my ($result,$cached)=&is_cached_new('ltitools',$cdom);
+ if (defined($cached)) {
+ if (ref($result) eq 'HASH') {
+ %ltitools = %{$result};
+ }
+ } else {
+ my %domconfig = &get_dom('configuration',['ltitools'],$cdom);
+ if (ref($domconfig{'ltitools'}) eq 'HASH') {
+ %ltitools = %{$domconfig{'ltitools'}};
+ }
+ my $cachetime = 24*60*60;
+ &do_cache_new('ltitools',$cdom,\%ltitools,$cachetime);
+ }
+ return %ltitools;
+}
+
sub get_numsuppfiles {
my ($cnum,$cdom,$ignorecache)=@_;
my $hashid=$cnum.':'.$cdom;
@@ -10614,7 +10713,7 @@ sub metadata {
# if it is a non metadata possible uri return quickly
if (($uri eq '') ||
(($uri =~ m|^/*adm/|) &&
- ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard)$})) ||
+ ($uri !~ m|^adm/includes|) && ($uri !~ m{/(smppg|bulletinboard|exttools?)$})) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;
}
@@ -12147,6 +12246,8 @@ sub clutter {
# &logthis("Got a blank emb style");
}
}
+ } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/exttools?$}) {
+ $thisfn='/adm/wrapper'.$thisfn;
}
return $thisfn;
}
@@ -12338,8 +12439,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>;
@@ -12425,8 +12526,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);
@@ -12448,7 +12549,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;
}
@@ -12570,7 +12672,7 @@ sub fetch_dns_checksums {
}
sub get_iphost {
- my ($ignore_cache) = @_;
+ my ($ignore_cache,$nocache) = @_;
if (!$ignore_cache) {
if (%iphost) {
@@ -12594,7 +12696,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})) {
@@ -12619,9 +12721,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;
}