--- loncom/lonnet/perl/lonnet.pm 2018/09/02 02:13:59 1.1172.2.95 +++ loncom/lonnet/perl/lonnet.pm 2018/09/02 23:22:47 1.1172.2.96 @@ -1,7 +1,7 @@ # The LearningOnline Network # TCP networking package # -# $Id: lonnet.pm,v 1.1172.2.95 2018/09/02 02:13:59 raeburn Exp $ +# $Id: lonnet.pm,v 1.1172.2.96 2018/09/02 23:22:47 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'; @@ -1829,7 +1841,7 @@ sub inst_directory_query { &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); @@ -3194,7 +3206,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 +3264,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 +3380,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 +3415,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 +3490,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 +3548,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 +4509,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); @@ -8113,7 +8126,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 +8155,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'; } @@ -9806,7 +9819,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"); } @@ -9820,7 +9833,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"); @@ -9830,7 +9843,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); @@ -9852,7 +9865,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); @@ -12340,7 +12353,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; @@ -12453,7 +12466,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); @@ -12597,15 +12610,17 @@ sub get_dns { } my %alldns; - open(my $config,"<$perlvar{'lonTabDir'}/hosts.tab"); - foreach my $dns (<$config>) { - next if ($dns !~ /^\^(\S*)/x); - my $line = $1; - my ($host,$protocol) = split(/:/,$line); - if ($protocol ne 'https') { - $protocol = 'http'; + if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) { + foreach my $dns (<$config>) { + next if ($dns !~ /^\^(\S*)/x); + my $line = $1; + my ($host,$protocol) = split(/:/,$line); + if ($protocol ne 'https') { + $protocol = 'http'; + } + $alldns{$host} = $protocol; } - $alldns{$host} = $protocol; + close($config); } while (%alldns) { my ($dns) = sort { $b cmp $a } keys(%alldns); @@ -12625,7 +12640,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; @@ -12718,7 +12733,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); } @@ -12770,8 +12785,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)) { @@ -12804,7 +12834,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); @@ -13070,7 +13100,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); @@ -13086,7 +13116,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); @@ -13111,7 +13141,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); @@ -13125,7 +13155,7 @@ BEGIN { } # ------------------------------------------------------------ Read permissions { - open(my $config,"<$perlvar{'lonTabDir'}/roles.tab"); + open(my $config,"<","$perlvar{'lonTabDir'}/roles.tab"); while (my $configline=<$config>) { chomp($configline); @@ -13139,7 +13169,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); @@ -13159,7 +13189,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; } @@ -13205,7 +13235,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 =~ /^\#/);