--- loncom/lonnet/perl/lonnet.pm 2017/05/13 13:58:49 1.1172.2.93
+++ loncom/lonnet/perl/lonnet.pm 2018/03/28 10:22:10 1.1172.2.93.4.8
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.1172.2.93 2017/05/13 13:58:49 raeburn Exp $
+# $Id: lonnet.pm,v 1.1172.2.93.4.8 2018/03/28 10:22:10 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -142,7 +142,7 @@ our @EXPORT = qw(%env);
sub logtouch {
my $execdir=$perlvar{'lonDaemons'};
unless (-e "$execdir/logs/lonnet.log") {
- open(my $fh,">>$execdir/logs/lonnet.log");
+ open(my $fh,">>","$execdir/logs/lonnet.log");
close $fh;
}
my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
@@ -154,7 +154,7 @@ sub logthis {
my $execdir=$perlvar{'lonDaemons'};
my $now=time;
my $local=localtime($now);
- if (open(my $fh,">>$execdir/logs/lonnet.log")) {
+ if (open(my $fh,">>","$execdir/logs/lonnet.log")) {
my $logstring = $local. " ($$): ".$message."\n"; # Keep any \'s in string.
print $fh $logstring;
close($fh);
@@ -167,7 +167,7 @@ sub logperm {
my $execdir=$perlvar{'lonDaemons'};
my $now=time;
my $local=localtime($now);
- if (open(my $fh,">>$execdir/logs/lonnet.perm.log")) {
+ if (open(my $fh,">>","$execdir/logs/lonnet.perm.log")) {
print $fh "$now:$message:$local\n";
close($fh);
}
@@ -436,7 +436,7 @@ sub reconlonc {
&logthis("Trying to reconnect lonc");
my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
- if (open(my $fh,"<$loncfile")) {
+ if (open(my $fh,"<",$loncfile)) {
my $loncpid=<$fh>;
chomp($loncpid);
if (kill 0 => $loncpid) {
@@ -476,7 +476,7 @@ sub critical {
$dumpcount++;
{
my $dfh;
- if (open($dfh,">$dfilename")) {
+ if (open($dfh,">",$dfilename)) {
print $dfh "$cmd\n";
close($dfh);
}
@@ -485,7 +485,7 @@ sub critical {
my $wcmd='';
{
my $dfh;
- if (open($dfh,"<$dfilename")) {
+ if (open($dfh,"<",$dfilename)) {
$wcmd=<$dfh>;
close($dfh);
}
@@ -601,7 +601,7 @@ sub transfer_profile_to_env {
# ---------------------------------------------------- Check for valid session
sub check_for_valid_session {
- my ($r,$name,$userhashref) = @_;
+ my ($r,$name,$userhashref,$domref) = @_;
my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
if ($name eq '') {
$name = 'lonID';
@@ -616,7 +616,16 @@ sub check_for_valid_session {
} else {
$lonidsdir=$r->dir_config('lonIDsDir');
}
- return undef if (!-e "$lonidsdir/$handle.id");
+ if (!-e "$lonidsdir/$handle.id") {
+ if ((ref($domref)) && ($name eq 'lonID') &&
+ ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
+ my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
+ if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
+ $$domref = $possudom;
+ }
+ }
+ return undef;
+ }
my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
return undef if (!$opened);
@@ -1688,7 +1697,12 @@ sub get_dom {
}
}
if ($udom && $uhome && ($uhome ne 'no_host')) {
- my $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+ my $rep;
+ if ($namespace =~ /^enc/) {
+ $rep=&reply("encrypt:egetdom:$udom:$namespace:$items",$uhome);
+ } else {
+ $rep=&reply("getdom:$udom:$namespace:$items",$uhome);
+ }
my %returnhash;
if ($rep eq '' || $rep =~ /^error: 2 /) {
return %returnhash;
@@ -1732,7 +1746,11 @@ sub put_dom {
$items.=&escape($item).'='.&freeze_escape($$storehash{$item}).'&';
}
$items=~s/\&$//;
- return &reply("putdom:$udom:$namespace:$items",$uhome);
+ if ($namespace =~ /^enc/) {
+ return &reply("encrypt:putdom:$udom:$namespace:$items",$uhome);
+ } else {
+ return &reply("putdom:$udom:$namespace:$items",$uhome);
+ }
} else {
&logthis("put_dom failed - no homeserver and/or domain");
}
@@ -1823,13 +1841,24 @@ sub inst_directory_query {
my $homeserver = &domain($udom,'primary');
my $outcome;
if ($homeserver ne '') {
+ unless ($homeserver eq $perlvar{'lonHostID'}) {
+ if ($srch->{'srchby'} eq 'email') {
+ my $lcrev = &get_server_loncaparev(undef,$homeserver);
+ my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.([\w.\-]+)\'?$/);
+ if (($major eq '' && $minor eq '') || ($major < 2) ||
+ (($major == 2) && ($minor < 11)) ||
+ (($major == 2) && ($minor == 11) && ($subver !~ /^2\.B/))) {
+ return;
+ }
+ }
+ }
my $queryid=&reply("querysend:instdirsearch:".
&escape($srch->{'srchby'}).':'.
&escape($srch->{'srchterm'}).':'.
&escape($srch->{'srchtype'}),$homeserver);
my $host=&hostname($homeserver);
if ($queryid !~/^\Q$host\E\_/) {
- &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.'in domain '.$udom);
+ &logthis('institutional directory search invalid queryid: '.$queryid.' for host: '.$homeserver.' in domain '.$udom);
return;
}
my $response = &get_query_reply($queryid);
@@ -1864,6 +1893,15 @@ sub usersearch {
my $query = 'usersearch';
foreach my $tryserver (keys(%libserv)) {
if (&host_domain($tryserver) eq $dom) {
+ unless ($tryserver eq $perlvar{'lonHostID'}) {
+ if ($srch->{'srchby'} eq 'email') {
+ my $lcrev = &get_server_loncaparev(undef,$tryserver);
+ my ($major,$minor,$subver) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.([\w.\-]+)\'?$/);
+ next if (($major eq '' && $minor eq '') || ($major < 2) ||
+ (($major == 2) && ($minor < 11)) ||
+ (($major == 2) && ($minor == 11) && ($subver !~ /^2\.B/)));
+ }
+ }
my $host=&hostname($tryserver);
my $queryid=
&reply("querysend:".&escape($query).':'.
@@ -2244,6 +2282,22 @@ sub get_domain_defaults {
return %domdefaults;
}
+sub course_portal_url {
+ my ($cnum,$cdom) = @_;
+ my $chome = &homeserver($cnum,$cdom);
+ my $hostname = &hostname($chome);
+ my $protocol = $protocol{$chome};
+ $protocol = 'http' if ($protocol ne 'https');
+ my %domdefaults = &get_domain_defaults($cdom);
+ my $firsturl;
+ if ($domdefaults{'portal_def'}) {
+ $firsturl = $domdefaults{'portal_def'};
+ } else {
+ $firsturl = $protocol.'://'.$hostname;
+ }
+ return $firsturl;
+}
+
# --------------------------------------------------- Assign a key to a student
sub assign_access_key {
@@ -3004,6 +3058,14 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
+ } elsif ($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) {
+ $incourse = 1;
+ if ($env{'form.forceedit'}) {
+ $forceview = 1;
+ } else {
+ $forceedit = 1;
+ }
+ $cfile = $resurl;
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
$incourse = 1;
if ($env{'form.forceedit'}) {
@@ -3028,6 +3090,14 @@ sub can_edit_resource {
$forceedit = 1;
}
$cfile = $resurl;
+ } elsif (($resurl =~ m{^/adm/wrapper/adm/$cdom/$cnum/\d+/ext\.tool$}) && ($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;
@@ -3037,8 +3107,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+/ext\.tool$}) {
+ $cfile = '/adm/wrapper'.$escfile;
+ } else {
+ $escfile =~ s{^http://}{};
+ $cfile = &escape("/adm/wrapper/ext/$escfile");
+ }
}
} elsif ($resurl =~ m{^/?adm/viewclasslist$}) {
if ($env{'form.forceedit'}) {
@@ -3194,7 +3269,7 @@ sub process_coursefile {
$home);
}
} elsif ($action eq 'uploaddoc') {
- open(my $fh,'>'.$filepath.'/'.$fname);
+ open(my $fh,'>',$filepath.'/'.$fname);
print $fh $env{'form.'.$source};
close($fh);
if ($parser eq 'parse') {
@@ -3252,7 +3327,7 @@ sub store_edited_file {
($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
$fpath=$docudom.'/'.$docuname.'/'.$fpath;
my $filepath = &build_filepath($fpath);
- open(my $fh,'>'.$filepath.'/'.$fname);
+ open(my $fh,'>',$filepath.'/'.$fname);
print $fh $content;
close($fh);
my $home=&homeserver($docuname,$docudom);
@@ -3368,12 +3443,12 @@ sub userfileupload {
'_'.$env{'user.domain'}.'/pending';
} elsif (($context eq 'existingfile') || ($context eq 'canceloverwrite')) {
my ($docuname,$docudom);
- if ($destudom) {
+ if ($destudom =~ /^$match_domain$/) {
$docudom = $destudom;
} else {
$docudom = $env{'user.domain'};
}
- if ($destuname) {
+ if ($destuname =~ /^$match_username$/) {
$docuname = $destuname;
} else {
$docuname = $env{'user.name'};
@@ -3403,7 +3478,7 @@ sub userfileupload {
mkdir($fullpath,0777);
}
}
- open(my $fh,'>'.$fullpath.'/'.$fname);
+ open(my $fh,'>',$fullpath.'/'.$fname);
print $fh $env{'form.'.$formname};
close($fh);
if ($context eq 'existingfile') {
@@ -3478,7 +3553,7 @@ sub finishuserfileupload {
# Save the file
{
- if (!open(FH,'>'.$filepath.'/'.$file)) {
+ if (!open(FH,'>',$filepath.'/'.$file)) {
&logthis('Failed to create '.$filepath.'/'.$file);
print STDERR ('Failed to create '.$filepath.'/'.$file."\n");
return '/adm/notfound.html';
@@ -3536,7 +3611,8 @@ sub finishuserfileupload {
my $input = $filepath.'/'.$file;
my $output = $filepath.'/'.'tn-'.$file;
my $thumbsize = $thumbwidth.'x'.$thumbheight;
- system("convert -sample $thumbsize $input $output");
+ my @args = ('convert','-sample',$thumbsize,$input,$output);
+ system({$args[0]} @args);
if (-e $filepath.'/'.'tn-'.$file) {
$fetchthumb = 1;
}
@@ -4496,7 +4572,7 @@ sub postannounce {
sub getannounce {
- if (open(my $fh,$perlvar{'lonDocRoot'}.'/announcement.txt')) {
+ if (open(my $fh,"<",$perlvar{'lonDocRoot'}.'/announcement.txt')) {
my $announcement='';
while (my $line = <$fh>) { $announcement .= $line; }
close($fh);
@@ -4752,9 +4828,10 @@ my %cachedtimes=();
my $cachedtime='';
sub load_all_first_access {
- my ($uname,$udom)=@_;
+ my ($uname,$udom,$ignorecache)=@_;
if (($cachedkey eq $uname.':'.$udom) &&
- (abs($cachedtime-time)<5) && (!$env{'form.markaccess'})) {
+ (abs($cachedtime-time)<5) && (!$env{'form.markaccess'}) &&
+ (!$ignorecache)) {
return;
}
$cachedtime=time;
@@ -4763,7 +4840,7 @@ sub load_all_first_access {
}
sub get_first_access {
- my ($type,$argsymb,$argmap)=@_;
+ my ($type,$argsymb,$argmap,$ignorecache)=@_;
my ($symb,$courseid,$udom,$uname)=&whichuser();
if ($argsymb) { $symb=$argsymb; }
my ($map,$id,$res)=&decode_symb($symb);
@@ -4775,7 +4852,7 @@ sub get_first_access {
} else {
$res=$symb;
}
- &load_all_first_access($uname,$udom);
+ &load_all_first_access($uname,$udom,$ignorecache);
return $cachedtimes{"$courseid\0$res"};
}
@@ -6181,7 +6258,7 @@ sub currentdump {
#
my %returnhash=();
#
- if ($rep eq "unknown_cmd") {
+ if ($rep eq 'unknown_cmd') {
# an old lond will not know currentdump
# Do a dump and make it look like a currentdump
my @tmp = &dumpstore($courseid,$sdom,$sname,'.');
@@ -7114,7 +7191,7 @@ sub allowed {
if (defined($env{'allowed.'.$priv})) { return $env{'allowed.'.$priv}; }
# Free bre access to adm and meta resources
- if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard)$}))
+ if (((($uri=~/^adm\//) && ($uri !~ m{/(?:smppg|bulletinboard|ext\.tool)$}))
|| (($uri=~/\.meta$/) && ($uri!~m|^uploaded/|) ))
&& ($priv eq 'bre')) {
return 'F';
@@ -7775,7 +7852,8 @@ sub get_commblock_resources {
}
}
}
- if ($interval[0] =~ /^\d+$/) {
+ if ($interval[0] =~ /^(\d+)/) {
+ my $timelimit = $1;
my $first_access;
if ($type eq 'resource') {
$first_access=&get_first_access($interval[1],$item);
@@ -7785,7 +7863,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) {
@@ -8113,7 +8191,7 @@ sub fetch_enrollment_query {
if ($xml_classlist =~ /^error/) {
&logthis('fetch_enrollment_query - autoretrieve error: '.$xml_classlist.' for '.$filename.' from server: '.$homeserver.' '.$context.' '.$cnum);
} else {
- if ( open(FILE,">$destname") ) {
+ if ( open(FILE,">",$destname) ) {
print FILE &unescape($xml_classlist);
close(FILE);
} else {
@@ -8142,7 +8220,7 @@ sub get_query_reply {
for (1..$loopmax) {
sleep($sleep);
if (-e $replyfile.'.end') {
- if (open(my $fh,$replyfile)) {
+ if (open(my $fh,"<",$replyfile)) {
$reply = join('',<$fh>);
close($fh);
} else { return 'error: reply_file_error'; }
@@ -9767,7 +9845,7 @@ sub save_selected_files {
my ($user, $path, @files) = @_;
my $filename = $user."savedfiles";
my @other_files = &files_not_in_path($user, $path);
- open (OUT, '>'.$tmpdir.$filename);
+ open (OUT,'>',LONCAPA::tempdir().$filename);
foreach my $file (@files) {
print (OUT $env{'form.currentpath'}.$file."\n");
}
@@ -9781,7 +9859,7 @@ sub save_selected_files {
sub clear_selected_files {
my ($user) = @_;
my $filename = $user."savedfiles";
- open (OUT, '>'.LONCAPA::tempdir().$filename);
+ open (OUT,'>',LONCAPA::tempdir().$filename);
print (OUT undef);
close (OUT);
return ("ok");
@@ -9791,7 +9869,7 @@ sub files_in_path {
my ($user, $path) = @_;
my $filename = $user."savedfiles";
my %return_files;
- open (IN, '<'.LONCAPA::tempdir().$filename);
+ open (IN,'<',LONCAPA::tempdir().$filename);
while (my $line_in = <IN>) {
chomp ($line_in);
my @paths_and_file = split (m!/!, $line_in);
@@ -9813,7 +9891,7 @@ sub files_not_in_path {
my $filename = $user."savedfiles";
my @return_files;
my $path_part;
- open(IN, '<'.LONCAPA::.$filename);
+ open(IN,'<',LONCAPA::tempdir().$filename);
while (my $line = <IN>) {
#ok, I know it's clunky, but I want it to work
my @paths_and_file = split(m|/|, $line);
@@ -10473,7 +10551,7 @@ sub get_userresdata {
# Parameters:
# $name - Course/user name.
# $domain - Name of the domain the user/course is registered on.
-# $type - Type of thing $name is (must be 'course' or 'user'
+# $type - Type of thing $name is (must be 'course' or 'user')
# @which - Array of names of resources desired.
# Returns:
# The value of the first reasource in @which that is found in the
@@ -10492,13 +10570,44 @@ sub resdata {
}
if (!ref($result)) { return $result; }
foreach my $item (@which) {
- if (defined($result->{$item->[0]})) {
- return [$result->{$item->[0]},$item->[1]];
- }
+ if (ref($item) eq 'ARRAY') {
+ if (defined($result->{$item->[0]})) {
+ return [$result->{$item->[0]},$item->[1]];
+ }
+ }
}
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 %encdomconfig = &get_dom('encconfig',['ltitools'],$cdom);
+ if (ref($encdomconfig{'ltitools'}) eq 'HASH') {
+ foreach my $id (keys(%ltitools)) {
+ if (ref($encdomconfig{'ltitools'}{$id}) eq 'HASH') {
+ foreach my $item ('key','secret') {
+ $ltitools{$id}{$item} = $encdomconfig{'ltitools'}{$id}{$item};
+ }
+ }
+ }
+ }
+ }
+ 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;
@@ -10947,13 +11056,14 @@ sub add_prefix_and_part {
my %metaentry;
my %importedpartids;
+my %importedrespids;
sub metadata {
my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
$uri=&declutter($uri);
# 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|ext\.tool)$})) ||
($uri =~ m|/$|) || ($uri =~ m|/.meta$|) || ($uri =~ m{^/*uploaded/.+\.sequence$})) {
return undef;
}
@@ -10974,9 +11084,11 @@ sub metadata {
}
{
# Imported parts would go here
- my %importedids=();
- my @origfileimportpartids=();
+ my @origfiletagids=();
my $importedparts=0;
+
+# Imported responseids would go here
+ my $importedresponses=0;
#
# Is this a recursive call for a library?
#
@@ -11071,8 +11183,32 @@ sub metadata {
my $dir=$filename;
$dir=~s|[^/]*$||;
$location=&filelocation($dir,$location);
-
+
+ my $importid=$token->[2]->{'id'};
my $importmode=$token->[2]->{'importmode'};
+#
+# Check metadata for imported file to
+# see if it contained response items
+#
+ my $libresponseorder = &metadata($location,'responseorder');
+ my $origfile;
+ if ($libresponseorder ne '') {
+ if ($#origfiletagids<0) {
+ undef(%importedrespids);
+ undef(%importedpartids);
+ }
+ @{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder);
+ if (@{$importedrespids{$importid}} > 0) {
+ $importedresponses = 1;
+# We need to get the original file and the imported file to get the response order correct
+# Load and inspect original file
+ if ($#origfiletagids<0) {
+ my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+ $origfile=&getfile($origfilelocation);
+ @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ }
+ }
+ }
if ($importmode eq 'problem') {
# Import as problem/response
$unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
@@ -11081,12 +11217,15 @@ sub metadata {
$importedparts=1;
# We need to get the original file and the imported file to get the part order correct
# Good news: we do not need to worry about nested libraries, since parts cannot be nested
-# Load and inspect original file
+# Load and inspect original file if we didn't do that already
if ($#origfileimportpartids<0) {
- undef(%importedpartids);
- my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
- my $origfile=&getfile($origfilelocation);
- @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ undef(%importedrespids);
+ undef(%importedpartids);
+ if ($origfile eq '') {
+ my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
+ $origfile=&getfile($origfilelocation);
+ @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
+ }
}
# Load and inspect imported file
@@ -11200,20 +11339,48 @@ sub metadata {
grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
$metaentry{':packages'} = join(',',@uniq_packages);
- if ($importedparts) {
+ if (($importedresponses) || ($importedparts)) {
+ if ($importedparts) {
# We had imported parts and need to rebuild partorder
- $metaentry{':partorder'}='';
- $metathesekeys{'partorder'}=1;
- for (my $index=0;$index<$#origfileimportpartids;$index+=2) {
- if ($origfileimportpartids[$index] eq 'part') {
-# original part, part of the problem
- $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];
- } else {
-# we have imported parts at this position
- $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};
- }
- }
- $metaentry{':partorder'}=~s/^\,//;
+ $metaentry{':partorder'}='';
+ $metathesekeys{'partorder'}=1;
+ }
+ if ($importedresponses) {
+# We had imported responses and need to rebuild responseorder
+ $metaentry{':responseorder'}='';
+ $metathesekeys{'responseorder'}=1;
+ }
+ for (my $index=0;$index<$#origfiletagids;$index+=2) {
+ my $origid = $origfiletagids[$index+1];
+ if ($origfiletagids[$index] eq 'part') {
+# Original part, part of the problem
+ if ($importedparts) {
+ $metaentry{':partorder'}.=','.$origid;
+ }
+ } elsif ($origfiletagids[$index] eq 'import') {
+ if ($importedparts) {
+# We have imported parts at this position
+ $metaentry{':partorder'}.=','.$importedpartids{$origid};
+ }
+ if ($importedresponses) {
+# We have imported responses at this position
+ if (ref($importedrespids{$origid}) eq 'ARRAY') {
+ $metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}});
+ }
+ }
+ } else {
+# Original response item, part of the problem
+ if ($importedresponses) {
+ $metaentry{':responseorder'}.=','.$origid;
+ }
+ }
+ }
+ if ($importedparts) {
+ $metaentry{':partorder'}=~s/^\,//;
+ }
+ if ($importedresponses) {
+ $metaentry{':responseorder'}=~s/^\,//;
+ }
}
$metaentry{':keys'} = join(',',keys(%metathesekeys));
@@ -12301,7 +12468,7 @@ sub readfile {
my $file = shift;
if ( (! -e $file ) || ($file eq '') ) { return -1; };
my $fh;
- open($fh,"<$file");
+ open($fh,"<",$file);
my $a='';
while (my $line = <$fh>) { $a .= $line; }
return $a;
@@ -12414,7 +12581,7 @@ sub machine_ids {
sub additional_machine_domains {
my @domains;
- open(my $fh,"<$perlvar{'lonTabDir'}/expected_domains.tab");
+ open(my $fh,"<","$perlvar{'lonTabDir'}/expected_domains.tab");
while( my $line = <$fh>) {
$line =~ s/\s//g;
push(@domains,$line);
@@ -12485,6 +12652,8 @@ sub clutter {
# &logthis("Got a blank emb style");
}
}
+ } elsif ($thisfn =~ m{^/adm/$match_domain/$match_courseid/\d+/ext\.tool$}) {
+ $thisfn='/adm/wrapper'.$thisfn;
}
return $thisfn;
}
@@ -12558,7 +12727,7 @@ sub get_dns {
}
my %alldns;
- open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+ open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab");
foreach my $dns (<$config>) {
next if ($dns !~ /^\^(\S*)/x);
my $line = $1;
@@ -12586,7 +12755,7 @@ sub get_dns {
close($config);
my $which = (split('/',$url))[3];
&logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
- open($config,"<$perlvar{'lonTabDir'}/dns_$which.tab");
+ open($config,"<","$perlvar{'lonTabDir'}/dns_$which.tab");
my @content = <$config>;
&$func(\@content,$hashref);
return;
@@ -12679,7 +12848,7 @@ sub fetch_dns_checksums {
my ($ignore_cache,$nocache) = @_;
&get_dns('/adm/dns/domain',\&parse_domain_tab,$ignore_cache,$nocache);
my $fh;
- if (open($fh,"<".$perlvar{'lonTabDir'}.'/domain.tab')) {
+ if (open($fh,"<",$perlvar{'lonTabDir'}.'/domain.tab')) {
my @lines = <$fh>;
&parse_domain_tab(\@lines);
}
@@ -12731,8 +12900,23 @@ sub fetch_dns_checksums {
my ($id,$domain,$role,$name,$protocol,$intdom)=split(/:/,$configline);
$name=~s/\s//g;
if ($id && $domain && $role && $name) {
+ if ((exists($hostname{$id})) && ($hostname{$id} ne '')) {
+ my $curr = $hostname{$id};
+ my $skip;
+ if (ref($name_to_host{$curr}) eq 'ARRAY') {
+ if (($curr eq $name) && (@{$name_to_host{$curr}} == 1)) {
+ $skip = 1;
+ } else {
+ @{$name_to_host{$curr}} = grep { $_ ne $id } @{$name_to_host{$curr}};
+ }
+ }
+ unless ($skip) {
+ push(@{$name_to_host{$name}},$id);
+ }
+ } else {
+ push(@{$name_to_host{$name}},$id);
+ }
$hostname{$id}=$name;
- push(@{$name_to_host{$name}}, $id);
$hostdom{$id}=$domain;
if ($role eq 'library') { $libserv{$id}=$name; }
if (defined($protocol)) {
@@ -12765,7 +12949,7 @@ sub fetch_dns_checksums {
sub load_hosts_tab {
my ($ignore_cache,$nocache) = @_;
&get_dns('/adm/dns/hosts',\&parse_hosts_tab,$ignore_cache,$nocache);
- open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab");
+ open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab");
my @config = <$config>;
&parse_hosts_tab(\@config);
close($config);
@@ -13031,7 +13215,7 @@ sub all_loncaparevs {
{
sub load_loncaparevs {
if (-e "$perlvar{'lonTabDir'}/loncaparevs.tab") {
- if (open(my $config,"<$perlvar{'lonTabDir'}/loncaparevs.tab")) {
+ if (open(my $config,"<","$perlvar{'lonTabDir'}/loncaparevs.tab")) {
while (my $configline=<$config>) {
chomp($configline);
my ($hostid,$loncaparev)=split(/:/,$configline);
@@ -13047,7 +13231,7 @@ sub all_loncaparevs {
{
sub load_serverhomeIDs {
if (-e "$perlvar{'lonTabDir'}/serverhomeIDs.tab") {
- if (open(my $config,"<$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
+ if (open(my $config,"<","$perlvar{'lonTabDir'}/serverhomeIDs.tab")) {
while (my $configline=<$config>) {
chomp($configline);
my ($name,$id)=split(/:/,$configline);
@@ -13072,7 +13256,7 @@ BEGIN {
# ------------------------------------------------------ Read spare server file
{
- open(my $config,"<$perlvar{'lonTabDir'}/spare.tab");
+ open(my $config,"<","$perlvar{'lonTabDir'}/spare.tab");
while (my $configline=<$config>) {
chomp($configline);
@@ -13086,7 +13270,7 @@ BEGIN {
}
# ------------------------------------------------------------ Read permissions
{
- open(my $config,"<$perlvar{'lonTabDir'}/roles.tab");
+ open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab");
while (my $configline=<$config>) {
chomp($configline);
@@ -13100,7 +13284,7 @@ BEGIN {
# -------------------------------------------- Read plain texts for permissions
{
- open(my $config,"<$perlvar{'lonTabDir'}/rolesplain.tab");
+ open(my $config,"<","$perlvar{'lonTabDir'}/rolesplain.tab");
while (my $configline=<$config>) {
chomp($configline);
@@ -13120,7 +13304,7 @@ BEGIN {
# ---------------------------------------------------------- Read package table
{
- open(my $config,"<$perlvar{'lonTabDir'}/packages.tab");
+ open(my $config,"<","$perlvar{'lonTabDir'}/packages.tab");
while (my $configline=<$config>) {
if ($configline !~ /\S/ || $configline=~/^#/) { next; }
@@ -13166,7 +13350,7 @@ BEGIN {
# ---------------------------------------------------------- Read managers table
{
if (-e "$perlvar{'lonTabDir'}/managers.tab") {
- if (open(my $config,"<$perlvar{'lonTabDir'}/managers.tab")) {
+ if (open(my $config,"<","$perlvar{'lonTabDir'}/managers.tab")) {
while (my $configline=<$config>) {
chomp($configline);
next if ($configline =~ /^\#/);