--- loncom/lonnet/perl/lonnet.pm 2017/01/30 19:29:57 1.1172.2.90 +++ loncom/lonnet/perl/lonnet.pm 2018/05/02 20:33:18 1.1172.2.93.4.11 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.90 2017/01/30 19:29:57 raeburn Exp $ +# $Id: lonnet.pm,v 1.1172.2.93.4.11 2018/05/02 20:33:18 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); @@ -686,16 +695,19 @@ sub appenv { $env{$key}=$newenv->{$key}; } } - my $opened = open(my $env_file,'+<',$env{'user.environment'}); - if ($opened - && &timed_flock($env_file,LOCK_EX) - && - tie(my %disk_env,'GDBM_File',$env{'user.environment'}, - (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { - while (my ($key,$value) = each(%{$newenv})) { - $disk_env{$key} = $value; - } - untie(%disk_env); + my $lonids = $perlvar{'lonIDsDir'}; + if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) { + my $opened = open(my $env_file,'+<',$env{'user.environment'}); + if ($opened + && &timed_flock($env_file,LOCK_EX) + && + tie(my %disk_env,'GDBM_File',$env{'user.environment'}, + (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) { + while (my ($key,$value) = each(%{$newenv})) { + $disk_env{$key} = $value; + } + untie(%disk_env); + } } } return 'ok'; @@ -1688,7 +1700,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 +1749,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 +1844,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('instituional 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 +1896,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).':'. @@ -2112,6 +2153,9 @@ sub get_domain_defaults { $domdefaults{'timezone_def'} = $domconfig{'defaults'}{'timezone_def'}; $domdefaults{'datelocale_def'} = $domconfig{'defaults'}{'datelocale_def'}; $domdefaults{'portal_def'} = $domconfig{'defaults'}{'portal_def'}; + $domdefaults{'intauth_cost'} = $domconfig{'defaults'}{'intauth_cost'}; + $domdefaults{'intauth_switch'} = $domconfig{'defaults'}{'intauth_switch'}; + $domdefaults{'intauth_check'} = $domconfig{'defaults'}{'intauth_check'}; } else { $domdefaults{'lang_def'} = &domain($domain,'lang_def'); $domdefaults{'auth_def'} = &domain($domain,'auth_def'); @@ -2241,6 +2285,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 { @@ -3001,6 +3061,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'}) { @@ -3025,6 +3093,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; @@ -3034,8 +3110,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'}) { @@ -3191,7 +3272,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') { @@ -3249,7 +3330,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); @@ -3365,12 +3446,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'}; @@ -3400,7 +3481,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') { @@ -3475,7 +3556,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'; @@ -3533,7 +3614,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; } @@ -4493,7 +4575,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); @@ -4749,9 +4831,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; @@ -4760,7 +4843,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); @@ -4772,7 +4855,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"}; } @@ -5673,9 +5756,10 @@ sub rolesinit { } } - @userroles{'user.author', 'user.adv'} = &set_userprivs(\%userroles, - \%allroles, \%allgroups); + @userroles{'user.author','user.adv','user.rar'} = &set_userprivs(\%userroles, + \%allroles, \%allgroups); $env{'user.adv'} = $userroles{'user.adv'}; + $env{'user.rar'} = $userroles{'user.rar'}; return (\%userroles,\%firstaccenv,\%timerintenv); } @@ -5799,6 +5883,7 @@ sub set_userprivs { my ($userroles,$allroles,$allgroups,$groups_roles) = @_; my $author=0; my $adv=0; + my $rar=0; my %grouproles = (); if (keys(%{$allgroups}) > 0) { my @groupkeys; @@ -5846,6 +5931,7 @@ sub set_userprivs { $thesepriv{$privilege}.=$restrictions; } if ($thesepriv{'adv'} eq 'F') { $adv=1; } + if ($thesepriv{'rar'} eq 'F') { $rar=1; } } } my $thesestr=''; @@ -5854,7 +5940,7 @@ sub set_userprivs { } $userroles->{'user.priv.'.$role} = $thesestr; } - return ($author,$adv); + return ($author,$adv,$rar); } sub role_status { @@ -5899,9 +5985,10 @@ sub role_status { push(@rolecodes,$$role); &standard_roleprivs(\%allroles,$$role,$tdomain,$spec,$trest,$$where); } - my ($author,$adv)= &set_userprivs(\%userroles,\%allroles,\%allgroups,\%groups_roles); + my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%allroles,\%allgroups, + \%groups_roles); &appenv(\%userroles,\@rolecodes); - &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); } } $$tstatus = 'is'; @@ -6020,9 +6107,9 @@ sub set_adhoc_privileges { } else { &standard_roleprivs(\%rolehash,$role,$dcdom,$spec,$pickedcourse,$area); } - my ($author,$adv)= &set_userprivs(\%userroles,\%rolehash); + my ($author,$adv,$rar)= &set_userprivs(\%userroles,\%rolehash); &appenv(\%userroles,[$role,'cm']); - &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$role); + &log($env{'user.domain'},$env{'user.name'},$env{'user.home'},"Role ".$spec); unless ($caller eq 'constructaccess' && $env{'request.course.id'}) { &appenv( {'request.role' => $spec, 'request.role.domain' => $dcdom, @@ -6174,7 +6261,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,'.'); @@ -7107,7 +7194,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'; @@ -7768,7 +7855,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); @@ -7778,7 +7866,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) { @@ -8078,7 +8166,7 @@ sub fetch_enrollment_query { &logthis('fetch_enrollment_query: invalid queryid: '.$queryid.' for host: '.$host.' and homeserver: '.$homeserver.' context: '.$context.' '.$cnum); return 'error: '.$queryid; } - my $reply = &get_query_reply($queryid,$sleep.$loopmax); + my $reply = &get_query_reply($queryid,$sleep,$loopmax); my $tries = 1; while (($reply=~/^timeout/) && ($tries < $maxtries)) { $reply = &get_query_reply($queryid,$sleep,$loopmax); @@ -8106,7 +8194,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 { @@ -8135,7 +8223,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'; } @@ -8527,6 +8615,33 @@ sub auto_validate_class_sec { return $response; } +sub auto_validate_instclasses { + my ($cdom,$cnum,$owners,$classesref) = @_; + my ($homeserver,%validations); + $homeserver = &homeserver($cnum,$cdom); + unless ($homeserver eq 'no_host') { + my $ownerlist; + if (ref($owners) eq 'ARRAY') { + $ownerlist = join(',',@{$owners}); + } else { + $ownerlist = $owners; + } + if (ref($classesref) eq 'HASH') { + my $classes = &freeze_escape($classesref); + my $response=&reply('autovalidateinstclasses:'.&escape($ownerlist). + ':'.$cdom.':'.$classes,$homeserver); + unless ($response =~ /(con_lost|error|no_such_host|refused)/) { + my @items = split(/&/,$response); + foreach my $item (@items) { + my ($key,$value) = split('=',$item); + $validations{&unescape($key)} = &thaw_unescape($value); + } + } + } + } + return %validations; +} + sub auto_crsreq_update { my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title, $code,$accessstart,$accessend,$inbound) = @_; @@ -9760,7 +9875,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"); } @@ -9774,7 +9889,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"); @@ -9784,7 +9899,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 = ) { chomp ($line_in); my @paths_and_file = split (m!/!, $line_in); @@ -9806,7 +9921,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 = ) { #ok, I know it's clunky, but I want it to work my @paths_and_file = split(m|/|, $line); @@ -10466,7 +10581,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 @@ -10485,13 +10600,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; @@ -10940,13 +11086,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; } @@ -10967,9 +11114,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? # @@ -11064,8 +11213,37 @@ 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 %currmetaentry = %metaentry; + 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); + } + } + } +# Do not overwrite contents of %metaentry hash for resource itself with +# hash populated for imported library file + %metaentry = %currmetaentry; + undef(%currmetaentry); if ($importmode eq 'problem') { # Import as problem/response $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'}); @@ -11074,12 +11252,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 - if ($#origfileimportpartids<0) { - undef(%importedpartids); - my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri); - my $origfile=&getfile($origfilelocation); - @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs); +# Load and inspect original file if we didn't do that already + if ($#origfiletagids<0) { + 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 @@ -11193,20 +11374,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)); @@ -12294,7 +12503,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; @@ -12407,7 +12616,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); @@ -12478,6 +12687,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; } @@ -12551,7 +12762,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; @@ -12579,7 +12790,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; @@ -12672,7 +12883,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); } @@ -12724,8 +12935,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)) { @@ -12758,7 +12984,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); @@ -13024,7 +13250,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); @@ -13040,7 +13266,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); @@ -13065,7 +13291,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); @@ -13079,7 +13305,7 @@ BEGIN { } # ------------------------------------------------------------ Read permissions { - open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab"); while (my $configline=<$config>) { chomp($configline); @@ -13093,7 +13319,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); @@ -13113,7 +13339,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; } @@ -13159,7 +13385,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 =~ /^\#/);