[BACK]Return to lonnet.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / lonnet / perl

Diff for /loncom/lonnet/perl/lonnet.pm between versions 1.1368 and 1.1392

version 1.1368, 2018/03/23 01:02:04 version 1.1392, 2018/12/05 03:29:11
Line 73  package Apache::lonnet; Line 73  package Apache::lonnet;
 use strict;  use strict;
 use HTTP::Date;  use HTTP::Date;
 use Image::Magick;  use Image::Magick;
   use CGI::Cookie;
   
 use Encode;  use Encode;
   
Line 230  sub get_server_distarch { Line 230  sub get_server_distarch {
 }  }
   
 sub get_servercerts_info {  sub get_servercerts_info {
     my ($lonhost,$context) = @_;      my ($lonhost,$hostname,$context) = @_;
       return if ($lonhost eq '');
       if ($hostname eq '') {
           $hostname = &hostname($lonhost);
       }
       return if ($hostname eq '');
     my ($rep,$uselocal);      my ($rep,$uselocal);
     if (grep { $_ eq $lonhost } &current_machine_ids()) {      if ($context eq 'install') {
           $uselocal = 1;
       } elsif (grep { $_ eq $lonhost } &current_machine_ids()) {
         $uselocal = 1;          $uselocal = 1;
     }      }
     if (($context ne 'cgi') && ($uselocal)) {      if (($context ne 'cgi') && ($context ne 'install') && ($uselocal)) {
         my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];          my $distro = (split(/\:/,&get_server_distarch($lonhost)))[0];
         if ($distro eq '') {          if ($distro eq '') {
             $uselocal = 0;              $uselocal = 0;
Line 250  sub get_servercerts_info { Line 257  sub get_servercerts_info {
         }          }
     }      }
     if ($uselocal) {      if ($uselocal) {
         $rep = LONCAPA::Lond::server_certs(\%perlvar);          $rep = LONCAPA::Lond::server_certs(\%perlvar,$lonhost,$hostname);
     } else {      } else {
         $rep=&reply('servercerts',$lonhost);          $rep=&reply('servercerts',$lonhost);
     }      }
     my ($result,%returnhash);      my ($result,%returnhash);
     if (defined($lonhost)) {  
         if (!defined(&hostname($lonhost))) {  
             return;  
         }  
     }  
     if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||      if (($rep=~/^(refused|rejected|error)/) || ($rep eq 'con_lost') ||
         ($rep eq 'unknown_cmd')) {          ($rep eq 'unknown_cmd')) {
         $result = $rep;          $result = $rep;
Line 652  sub transfer_profile_to_env { Line 654  sub transfer_profile_to_env {
 sub check_for_valid_session {  sub check_for_valid_session {
     my ($r,$name,$userhashref,$domref) = @_;      my ($r,$name,$userhashref,$domref) = @_;
     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     my ($linkname,$pubname);      my ($lonidsdir,$linkname,$pubname,$secure,$lonid);
     if ($name eq '') {      if ($name eq 'lonDAV') {
         $name = 'lonID';          $lonidsdir=$r->dir_config('lonDAVsessDir');
       } else {
           $lonidsdir=$r->dir_config('lonIDsDir');
           if ($name eq '') {
               $name = 'lonID';
           }
       }
       if ($name eq 'lonID') {
           $secure = 'lonSID';
         $linkname = 'lonLinkID';          $linkname = 'lonLinkID';
         $pubname = 'lonPubID';          $pubname = 'lonPubID';
     }          if (exists($cookies{$secure})) {
     my $lonid=$cookies{$name};              $lonid=$cookies{$secure};
     if (!$lonid) {          } elsif (exists($cookies{$name})) {
         if (($name eq 'lonID') && ($ENV{'SERVER_PORT'} != 443) && ($linkname)) {              $lonid=$cookies{$name};
           } elsif (exists($cookies{$linkname})) {
             $lonid=$cookies{$linkname};              $lonid=$cookies{$linkname};
           } elsif (exists($cookies{$pubname})) {
               $lonid=$cookies{$pubname};
         }          }
         if (!$lonid) {      } else {
             if (($name eq 'lonID') && ($pubname)) {          $lonid=$cookies{$name};
                 $lonid=$cookies{$pubname};  
             }  
         }  
     }      }
     return undef if (!$lonid);      return undef if (!$lonid);
   
     my $handle=&LONCAPA::clean_handle($lonid->value);      my $handle=&LONCAPA::clean_handle($lonid->value);
     my $lonidsdir;      if (-l "$lonidsdir/$handle.id") {
     if ($name eq 'lonDAV') {          my $link = readlink("$lonidsdir/$handle.id");
         $lonidsdir=$r->dir_config('lonDAVsessDir');          if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
     } else {              $handle = $1;
         $lonidsdir=$r->dir_config('lonIDsDir');          }
     }      }
     if (!-e "$lonidsdir/$handle.id") {      if (!-e "$lonidsdir/$handle.id") {
         if ((ref($domref)) && ($name eq 'lonID') &&           if ((ref($domref)) && ($name eq 'lonID') && 
Line 708  sub check_for_valid_session { Line 718  sub check_for_valid_session {
         $userhashref->{'name'} = $disk_env{'user.name'};          $userhashref->{'name'} = $disk_env{'user.name'};
         $userhashref->{'domain'} = $disk_env{'user.domain'};          $userhashref->{'domain'} = $disk_env{'user.domain'};
         $userhashref->{'lti'} = $disk_env{'request.lti.login'};          $userhashref->{'lti'} = $disk_env{'request.lti.login'};
           if ($userhashref->{'lti'}) {
               $userhashref->{'ltitarget'} = $disk_env{'request.lti.target'};
               $userhashref->{'ltiuri'} = $disk_env{'request.lti.uri'};
           }
     }      }
   
     return $handle;      return $handle;
Line 733  sub timed_flock { Line 747  sub timed_flock {
     }      }
 }  }
   
   sub get_sessionfile_vars {
       my ($handle,$lonidsdir,$storearr) = @_;
       my %returnhash;
       unless (ref($storearr) eq 'ARRAY') {
           return %returnhash;
       }
       if (-l "$lonidsdir/$handle.id") {
           my $link = readlink("$lonidsdir/$handle.id");
           if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
               $handle = $1;
           }
       }
       if ((-e "$lonidsdir/$handle.id") &&
           ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
           my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
           if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
               if (open(my $idf,'+<',"$lonidsdir/$handle.id")) {
                   flock($idf,LOCK_SH);
                   if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",
                           &GDBM_READER(),0640)) {
                       foreach my $item (@{$storearr}) {
                           $returnhash{$item} = $disk_env{$item};
                       }
                       untie(%disk_env);
                   }
               }
           }
       }
       return %returnhash;
   }
   
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------------- Append Environment
   
 sub appenv {  sub appenv {
Line 758  sub appenv { Line 803  sub appenv {
                 $env{$key}=$newenv->{$key};                  $env{$key}=$newenv->{$key};
             }              }
         }          }
         my $opened = open(my $env_file,'+<',$env{'user.environment'});          my $lonids = $perlvar{'lonIDsDir'};
         if ($opened          if ($env{'user.environment'} =~ m{^\Q$lonids/\E$match_username\_\d+\_$match_domain\_[\w\-.]+\.id$}) {
     && &timed_flock($env_file,LOCK_EX)              my $opened = open(my $env_file,'+<',$env{'user.environment'});
     &&              if ($opened
     tie(my %disk_env,'GDBM_File',$env{'user.environment'},          && &timed_flock($env_file,LOCK_EX)
         (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {          &&
     while (my ($key,$value) = each(%{$newenv})) {          tie(my %disk_env,'GDBM_File',$env{'user.environment'},
         $disk_env{$key} = $value;              (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
     }          while (my ($key,$value) = each(%{$newenv})) {
     untie(%disk_env);              $disk_env{$key} = $value;
           }
           untie(%disk_env);
               }
         }          }
     }      }
     return 'ok';      return 'ok';
Line 883  sub userload { Line 931  sub userload {
  while ($filename=readdir(LONIDS)) {   while ($filename=readdir(LONIDS)) {
     next if ($filename eq '.' || $filename eq '..');      next if ($filename eq '.' || $filename eq '..');
     next if ($filename =~ /publicuser_\d+\.id/);      next if ($filename =~ /publicuser_\d+\.id/);
               next if ($filename =~ /^[a-f0-9]+_linked\.id$/);
     my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];      my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9];
     if ($curtime-$mtime < 1800) { $numusers++; }      if ($curtime-$mtime < 1800) { $numusers++; }
  }   }
Line 1011  sub find_existing_session { Line 1060  sub find_existing_session {
     return;      return;
 }  }
   
   # check if user's browser sent load balancer cookie and server still has session
   # and is not overloaded.
   sub check_for_balancer_cookie {
       my ($r,$update_mtime) = @_;
       my ($otherserver,$cookie);
       my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
       if (exists($cookies{'balanceID'})) {
           my $balid = $cookies{'balanceID'};
           $cookie=&LONCAPA::clean_handle($balid->value);
           my $balancedir=$r->dir_config('lonBalanceDir');
           if ((-d $balancedir) && (-e "$balancedir/$cookie.id")) {
               if ($cookie =~ /^($match_domain)_($match_username)_[a-f0-9]+$/) {
                   my ($possudom,$possuname) = ($1,$2);
                   my $has_session = 0;
                   if ((&domain($possudom) ne '') &&
                       (&homeserver($possuname,$possudom) ne 'no_host')) {
                       my $try_server;
                       my $opened = open(my $idf,'+<',"$balancedir/$cookie.id");
                       if ($opened) {
                           flock($idf,LOCK_SH);
                           while (my $line = <$idf>) {
                               chomp($line);
                               if (&hostname($line) ne '') {
                                   $try_server = $line;
                                   last;
                               }
                           }
                           close($idf);
                           if (($try_server) &&
                               (&has_user_session($try_server,$possudom,$possuname))) {
                               my $lowest_load = 30000;
                               ($otherserver,$lowest_load) =
                                   &compare_server_load($try_server,undef,$lowest_load);
                               if ($otherserver ne '' && $lowest_load < 100) {
                                   $has_session = 1;
                               } else {
                                   undef($otherserver);
                               }
                           }
                       }
                   }
                   if ($has_session) {
                       if ($update_mtime) {
                           my $atime = my $mtime = time;
                           utime($atime,$mtime,"$balancedir/$cookie.id");
                       }
                   } else {
                       unlink("$balancedir/$cookie.id");
                   }
               }
           }
       }
       return ($otherserver,$cookie);
   }
   
   sub delbalcookie {
       my ($cookie,$balancer) =@_;
       if ($cookie =~ /^($match_domain)\_($match_username)\_[a-f0-9]{32}$/) {
           my ($udom,$uname) = ($1,$2);
           my $uprimary_id = &domain($udom,'primary');
           my $uintdom = &internet_dom($uprimary_id);
           my $intdom = &internet_dom($balancer);
           my $serverhomedom = &host_domain($balancer);
           if (($uintdom ne '') && ($uintdom eq $intdom)) {
               return &reply("delbalcookie:$cookie",$balancer);
           }
       }
   }
   
 # -------------------------------- ask if server already has a session for user  # -------------------------------- ask if server already has a session for user
 sub has_user_session {  sub has_user_session {
     my ($lonid,$udom,$uname) = @_;      my ($lonid,$udom,$uname) = @_;
Line 1046  sub choose_server { Line 1164  sub choose_server {
             if (ref($balancers) eq 'HASH') {              if (ref($balancers) eq 'HASH') {
                 next if (exists($balancers->{$lonhost}));                  next if (exists($balancers->{$lonhost}));
             }              }
         }             }
         my $loginvia;          my $loginvia;
         if ($checkloginvia) {          if ($checkloginvia) {
             $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};              $loginvia = $domconfhash{$udom.'.login.loginvia_'.$lonhost};
Line 1348  sub get_lonbalancer_config { Line 1466  sub get_lonbalancer_config {
 sub check_loadbalancing {  sub check_loadbalancing {
     my ($uname,$udom,$caller) = @_;      my ($uname,$udom,$caller) = @_;
     my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,      my ($is_balancer,$currtargets,$currrules,$dom_in_use,$homeintdom,
         $rule_in_effect,$offloadto,$otherserver);          $rule_in_effect,$offloadto,$otherserver,$setcookie,$dom_balancers);
     my $lonhost = $perlvar{'lonHostID'};      my $lonhost = $perlvar{'lonHostID'};
     my @hosts = &current_machine_ids();      my @hosts = &current_machine_ids();
     my $uprimary_id = &Apache::lonnet::domain($udom,'primary');      my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
Line 1375  sub check_loadbalancing { Line 1493  sub check_loadbalancing {
         }          }
     }      }
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         ($is_balancer,$currtargets,$currrules) =           ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
             &check_balancer_result($result,@hosts);              &check_balancer_result($result,@hosts);
         if ($is_balancer) {          if ($is_balancer) {
             if (ref($currrules) eq 'HASH') {              if (ref($currrules) eq 'HASH') {
Line 1436  sub check_loadbalancing { Line 1554  sub check_loadbalancing {
             }              }
         }          }
         if (ref($result) eq 'HASH') {          if (ref($result) eq 'HASH') {
             ($is_balancer,$currtargets,$currrules) =               ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers) =
                 &check_balancer_result($result,@hosts);                  &check_balancer_result($result,@hosts);
             if ($is_balancer) {              if ($is_balancer) {
                 if (ref($currrules) eq 'HASH') {                  if (ref($currrules) eq 'HASH') {
Line 1502  sub check_loadbalancing { Line 1620  sub check_loadbalancing {
                 $is_balancer = 0;                  $is_balancer = 0;
                 if ($uname ne '' && $udom ne '') {                  if ($uname ne '' && $udom ne '') {
                     if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {                      if (($env{'user.name'} eq $uname) && ($env{'user.domain'} eq $udom)) {
                                               &appenv({'user.loadbalexempt'     => $lonhost,
                         &appenv({'user.loadbalexempt'     => $lonhost,    
                                  'user.loadbalcheck.time' => time});                                   'user.loadbalcheck.time' => time});
                     }                      }
                 }                  }
             }              }
         }          }
           unless ($homeintdom) {
               undef($setcookie);
           }
     }      }
     return ($is_balancer,$otherserver);      return ($is_balancer,$otherserver,$setcookie,$offloadto,$dom_balancers);
 }  }
   
 sub check_balancer_result {  sub check_balancer_result {
     my ($result,@hosts) = @_;      my ($result,@hosts) = @_;
     my ($is_balancer,$currtargets,$currrules);      my ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
     if (ref($result) eq 'HASH') {      if (ref($result) eq 'HASH') {
         if ($result->{'lonhost'} ne '') {          if ($result->{'lonhost'} ne '') {
             my $currbalancer = $result->{'lonhost'};              my $currbalancer = $result->{'lonhost'};
Line 1523  sub check_balancer_result { Line 1643  sub check_balancer_result {
                 $is_balancer = 1;                  $is_balancer = 1;
                 $currtargets = $result->{'targets'};                  $currtargets = $result->{'targets'};
                 $currrules = $result->{'rules'};                  $currrules = $result->{'rules'};
                   $dom_balancers = $currbalancer;
             }              }
               $dom_balancers = $currbalancer;
         } else {          } else {
             foreach my $key (keys(%{$result})) {              if (keys(%{$result})) {
                 if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&                  foreach my $key (keys(%{$result})) {
                     (ref($result->{$key}) eq 'HASH')) {                      if (($key ne '') && (grep(/^\Q$key\E$/,@hosts)) &&
                     $is_balancer = 1;                          (ref($result->{$key}) eq 'HASH')) {
                     $currrules = $result->{$key}{'rules'};                          $is_balancer = 1;
                     $currtargets = $result->{$key}{'targets'};                          $currrules = $result->{$key}{'rules'};
                     last;                          $currtargets = $result->{$key}{'targets'};
                           $setcookie = $result->{$key}{'cookie'};
                           last;
                       }
                 }                  }
                   $dom_balancers = join(',',sort(keys(%{$result})));
             }              }
         }          }
     }      }
     return ($is_balancer,$currtargets,$currrules);      return ($is_balancer,$currtargets,$currrules,$setcookie,$dom_balancers);
 }  }
   
 sub get_loadbalancer_targets {  sub get_loadbalancer_targets {
Line 3182  sub ssi { Line 3308  sub ssi {
   
     $request->header(Cookie => $ENV{'HTTP_COOKIE'});      $request->header(Cookie => $ENV{'HTTP_COOKIE'});
     my $lonhost = $perlvar{'lonHostID'};      my $lonhost = $perlvar{'lonHostID'};
     my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar);      my $islocal;
       if (($env{'request.course.id'}) &&
           ($form{'grade_courseid'} eq $env{'request.course.id'}) &&
           ($form{'grade_username'} ne '') && ($form{'grade_domain'} ne '') &&
           ($form{'grade_symb'} ne '') &&
           (&Apache::lonnet::allowed('mgr',$env{'request.course.id'}.
                                    ($env{'request.course.sec'}?'/'.$env{'request.course.sec'}:'')))) {
           $islocal = 1;
       }
       my $response= &LONCAPA::LWPReq::makerequest($lonhost,$request,'',\%perlvar,
                                                   '','','',$islocal);
   
     if (wantarray) {      if (wantarray) {
  return ($response->content, $response);   return ($response->content, $response);
Line 5216  sub set_first_access { Line 5352  sub set_first_access {
     }      }
     $cachedkey='';      $cachedkey='';
     my $firstaccess=&get_first_access($type,$symb,$map);      my $firstaccess=&get_first_access($type,$symb,$map);
     if (!$firstaccess) {      if ($firstaccess) {
           &logthis("First access time already set ($firstaccess) when attempting ".
                    "to set new value (type: $type, extent: $res) for $uname:$udom ". 
                    "in $courseid"); 
           return 'already_set';
       } else {
         my $start = time;          my $start = time;
  my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},   my $putres = &put('firstaccesstimes',{"$courseid\0$res"=>$start},
                           $udom,$uname);                            $udom,$uname);
Line 5232  sub set_first_access { Line 5373  sub set_first_access {
             if (($cachedtime) && (abs($start-$cachedtime) < 5)) {              if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
                 $cachedtimes{"$courseid\0$res"} = $start;                  $cachedtimes{"$courseid\0$res"} = $start;
             }              }
           } elsif ($putres ne 'refused') {
               &logthis("Result: $putres when attempting to set first access time ".
                        "(type: $type, extent: $res) for $uname:$udom in $courseid");
         }          }
         return $putres;          return $putres;
     }      }
Line 9283  sub assignrole { Line 9427  sub assignrole {
             }              }
             if ($refused) {              if ($refused) {
                 my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});                  my ($cdom,$cnum) = ($cwosec =~ m{^/?($match_domain)/($match_courseid)$});
                 if (!$selfenroll && $context eq 'course') {                  if (!$selfenroll && (($context eq 'course') || ($context eq 'ltienroll' && $env{'request.lti.login'}))) {
                     my %crsenv;                      my %crsenv;
                     if ($role eq 'cc' || $role eq 'co') {                      if ($role eq 'cc' || $role eq 'co') {
                         %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));                          %crsenv = &userenvironment($cdom,$cnum,('internal.courseowner'));
Line 9306  sub assignrole { Line 9450  sub assignrole {
                 } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {                  } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
                     if ($role eq 'st') {                      if ($role eq 'st') {
                         $refused = '';                          $refused = '';
                     } elsif (($context eq 'ltienroll') && ($env{'request.lti'})) {                      } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
                         $refused = '';                          $refused = '';
                     }                      }
                 } elsif ($context eq 'requestcourses') {                  } elsif ($context eq 'requestcourses') {
Line 10026  sub is_course { Line 10170  sub is_course {
     my ($cdom, $cnum) = scalar(@_) == 1 ?       my ($cdom, $cnum) = scalar(@_) == 1 ? 
          ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;           ($_[0] =~ /^($match_domain)_($match_courseid)$/)  :  @_;
   
     return unless $cdom and $cnum;      return unless (($cdom =~ /^$match_domain$/) && ($cnum =~ /^$match_courseid$/));
       my $uhome=&homeserver($cnum,$cdom);
     my %courses = &courseiddump($cdom, '.', 1, '.', '.', $cnum, undef, undef,      my $iscourse;
         '.');      if (grep { $_ eq $uhome } current_machine_ids()) {
           $iscourse = &LONCAPA::Lond::is_course($cdom,$cnum);
     return unless(exists($courses{$cdom.'_'.$cnum}));      } else {
           my $hashid = $cdom.':'.$cnum;
           ($iscourse,my $cached) = &is_cached_new('iscourse',$hashid);
           unless (defined($cached)) {
               my %courses = &courseiddump($cdom, '.', 1, '.', '.',
                                           $cnum,undef,undef,'.');
               $iscourse = 0;
               if (exists($courses{$cdom.'_'.$cnum})) {
                   $iscourse = 1;
               }
               &do_cache_new('iscourse',$hashid,$iscourse,3600);
           }
       }
       return unless ($iscourse);
     return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;      return wantarray ? ($cdom, $cnum) : $cdom.'_'.$cnum;
 }  }
   
Line 11735  sub add_prefix_and_part { Line 11892  sub add_prefix_and_part {
   
 my %metaentry;  my %metaentry;
 my %importedpartids;  my %importedpartids;
   my %importedrespids;
 sub metadata {  sub metadata {
     my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;      my ($uri,$what,$toolsymb,$liburi,$prefix,$depthcount)=@_;
     $uri=&declutter($uri);      $uri=&declutter($uri);
Line 11821  sub metadata { Line 11979  sub metadata {
   
     {      {
 # Imported parts would go here  # Imported parts would go here
         my %importedids=();          my @origfiletagids=();
         my @origfileimportpartids=();  
         my $importedparts=0;          my $importedparts=0;
   
   # Imported responseids would go here
           my $importedresponses=0;
 #  #
 # Is this a recursive call for a library?  # Is this a recursive call for a library?
 #  #
Line 11918  sub metadata { Line 12078  sub metadata {
                         my $dir=$filename;                          my $dir=$filename;
                         $dir=~s|[^/]*$||;                          $dir=~s|[^/]*$||;
                         $location=&filelocation($dir,$location);                          $location=&filelocation($dir,$location);
                          
                           my $importid=$token->[2]->{'id'};
                         my $importmode=$token->[2]->{'importmode'};                          my $importmode=$token->[2]->{'importmode'};
                         if ($importmode eq 'problem') {  #
 # Import as problem/response  # Check metadata for imported file to
                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});  # see if it contained response items
                         } elsif ($importmode eq 'part') {  #
                           my ($origfile,@libfilekeys);
                           my %currmetaentry = %metaentry;
                           @libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef,
                                                              $depthcount+1));
                           if (grep(/^responseorder$/,@libfilekeys)) {
                               my $libresponseorder = &metadata($location,'responseorder',undef,undef,
                                                                undef,$depthcount+1);
                               if ($libresponseorder ne '') {
                                   if ($#origfiletagids<0) {
                                       undef(%importedrespids);
                                       undef(%importedpartids);
                                   }
                                   my @respids = split(/\s*,\s*/,$libresponseorder);
                                   if (@respids) {
                                       $importedrespids{$importid} = join(',',map { $importid.'_'.$_ } @respids);
                                   }
                                   if ($importedrespids{$importid} ne '') {
                                       $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 'part') {
 # Import as part(s)  # Import as part(s)
                            $importedparts=1;                             $importedparts=1;
 # We need to get the original file and the imported file to get the part order correct  # 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  # 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) {                             if ($#origfiletagids<0) {
                               undef(%importedpartids);                                 undef(%importedrespids);
                               my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);                                 undef(%importedpartids);
                               my $origfile=&getfile($origfilelocation);                                 if ($origfile eq '') {
                               @origfileimportpartids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);                                     my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                      $origfile=&getfile($origfilelocation);
                                      @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                                  }
                              }
                              my @impfilepartids;
   # If <partorder> tag is included in metadata for the imported file
   # get the parts in the imported file from that.
                              if (grep(/^partorder$/,@libfilekeys)) {
                                  %currmetaentry = %metaentry;
                                  my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
                                                               $depthcount+1);
                                  %metaentry = %currmetaentry;
                                  undef(%currmetaentry);
                                  if ($libpartorder ne '') {
                                      @impfilepartids=split(/\s*,\s*/,$libpartorder);
                                  }
                              } else {
   # If no <partorder> tag available, load and inspect imported file
                                  my $impfile=&getfile($location);
                                  @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                            }                             }
   
 # Load and inspect imported file  
                            my $impfile=&getfile($location);  
                            my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);  
                            if ($#impfilepartids>=0) {                             if ($#impfilepartids>=0) {
 # This problem had parts  # This problem had parts
                                $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);                                 $importedpartids{$token->[2]->{'id'}}=join(',',@impfilepartids);
Line 11949  sub metadata { Line 12159  sub metadata {
                                $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};                                 $importedpartids{$token->[2]->{'id'}}=$token->[2]->{'id'};
                            }                             }
                         } else {                          } else {
   # Import as problem or as normal import
                               $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});
                               unless ($importmode eq 'problem') {
 # Normal import  # Normal import
                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});                                  if (defined($token->[2]->{'id'})) {
                            if (defined($token->[2]->{'id'})) {                                      $unikey.='_'.$token->[2]->{'id'};
                               $unikey.='_'.$token->[2]->{'id'};                                  }
                            }                              }
   # Check metadata for imported file to
   # see if it contained parts
                               if (grep(/^partorder$/,@libfilekeys)) {
                                   %currmetaentry = %metaentry;
                                   my $libpartorder = &metadata($location,'partorder',undef,undef,undef,
                                                                $depthcount+1);
                                   %metaentry = %currmetaentry;
                                   undef(%currmetaentry);
                                   if ($libpartorder ne '') {
                                       $importedparts = 1;
                                       $importedpartids{$token->[2]->{'id'}}=$libpartorder;
                                   }
                               }
                         }                          }
   
  if ($depthcount<20) {   if ($depthcount<20) {
     my $metadata =       my $metadata = 
  &metadata($uri,'keys',$toolsymb,$location,$unikey,   &metadata($uri,'keys',$toolsymb,$location,$unikey,
Line 11964  sub metadata { Line 12189  sub metadata {
  $metaentry{':'.$meta}=$metaentry{':'.$meta};   $metaentry{':'.$meta}=$metaentry{':'.$meta};
  $metathesekeys{$meta}=1;   $metathesekeys{$meta}=1;
     }      }
   
                         }                          }
     } else {      } else {
 #  #
Line 12047  sub metadata { Line 12271  sub metadata {
     grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));      grep { ! $seen{$_} ++ } (split(',',$metaentry{':packages'}));
  $metaentry{':packages'} = join(',',@uniq_packages);   $metaentry{':packages'} = join(',',@uniq_packages);
   
         if ($importedparts) {          if (($importedresponses) || ($importedparts)) {
               if ($importedparts) {
 # We had imported parts and need to rebuild partorder  # We had imported parts and need to rebuild partorder
            $metaentry{':partorder'}='';                  $metaentry{':partorder'}='';
            $metathesekeys{'partorder'}=1;                  $metathesekeys{'partorder'}=1;
            for (my $index=0;$index<$#origfileimportpartids;$index+=2) {              }
                if ($origfileimportpartids[$index] eq 'part') {              if ($importedresponses) {
 # original part, part of the problem  # We had imported responses and need to rebuil responseorder
                   $metaentry{':partorder'}.=','.$origfileimportpartids[$index+1];                  $metaentry{':responseorder'}='';
                } else {                  $metathesekeys{'responseorder'}=1;
 # we have imported parts at this position              }
                   $metaentry{':partorder'}.=','.$importedpartids{$origfileimportpartids[$index+1]};              for (my $index=0;$index<$#origfiletagids;$index+=2) {
                }                  my $origid = $origfiletagids[$index+1];
            }                  if ($origfiletagids[$index] eq 'part') {
            $metaentry{':partorder'}=~s/^\,//;  # 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
                           if ($importedpartids{$origid} ne '') {
                               $metaentry{':partorder'}.=','.$importedpartids{$origid};
                           }
                       }
                       if ($importedresponses) {
   # We have imported responses at this position
                           if ($importedrespids{$origid} ne '') {
                               $metaentry{':responseorder'}.=','.$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));   $metaentry{':keys'} = join(',',keys(%metathesekeys));
  &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);   &metadata_generate_part0(\%metathesekeys,\%metaentry,$uri);
  $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));   $metaentry{':allpossiblekeys'}=join(',',keys(%metathesekeys));
  &do_cache_new('meta',$uri,\%metaentry,$cachetime);          unless ($liburi) {
       &do_cache_new('meta',$uri,\%metaentry,$cachetime);
           }
 # this is the end of "was not already recently cached  # this is the end of "was not already recently cached
     }      }
     return $metaentry{':'.$what};      return $metaentry{':'.$what};
Line 13406  sub get_dns { Line 13661  sub get_dns {
     }      }
   
     my %alldns;      my %alldns;
     open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab");      if (open(my $config,"<","$perlvar{'lonTabDir'}/hosts.tab")) {
     foreach my $dns (<$config>) {          foreach my $dns (<$config>) {
  next if ($dns !~ /^\^(\S*)/x);      next if ($dns !~ /^\^(\S*)/x);
         my $line = $1;              my $line = $1;
         my ($host,$protocol) = split(/:/,$line);              my ($host,$protocol) = split(/:/,$line);
         if ($protocol ne 'https') {              if ($protocol ne 'https') {
             $protocol = 'http';                  $protocol = 'http';
               }
       $alldns{$host} = $protocol;
         }          }
  $alldns{$host} = $protocol;          close($config);
     }      }
     while (%alldns) {      while (%alldns) {
  my ($dns) = sort { $b cmp $a } keys(%alldns);   my ($dns) = sort { $b cmp $a } keys(%alldns);
Line 13422  sub get_dns { Line 13679  sub get_dns {
         my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);          my $response = &LONCAPA::LWPReq::makerequest('',$request,'',\%perlvar,30,0);
         delete($alldns{$dns});          delete($alldns{$dns});
  next if ($response->is_error());   next if ($response->is_error());
  my @content = split("\n",$response->content);          if ($url eq '/adm/dns/loncapaCRL') {
  unless ($nocache) {              return &$func($response);
     &do_cache_new('dns',$url,\@content,30*24*60*60);          } else {
  }      my @content = split("\n",$response->content);
  &$func(\@content,$hashref);      unless ($nocache) {
  return;          &do_cache_new('dns',$url,\@content,30*24*60*60);
       }
       &$func(\@content,$hashref);
               return;
           }
       }
       my $which = (split('/',$url,4))[3];
       if ($which eq 'loncapaCRL') {
           my $diskfile = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
           if (-e $diskfile) {
               &logthis("unable to contact DNS, on disk file $diskfile not updated");
           } else {
               &logthis("unable to contact DNS, no on disk file $diskfile available");
           }
       } else {
           &logthis("unable to contact DNS defaulting to on disk file dns_$which.tab\n");
           if (open(my $config,"<","$perlvar{'lonTabDir'}/dns_$which.tab")) {
               my @content = <$config>;
               close($config);
               &$func(\@content,$hashref);
           }
     }      }
     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");  
     my @content = <$config>;  
     &$func(\@content,$hashref);  
     return;      return;
 }  }
   
Line 13494  sub fetch_dns_checksums { Line 13765  sub fetch_dns_checksums {
     return \%checksums;      return \%checksums;
 }  }
   
   sub fetch_crl_pemfile {
       return &get_dns("/adm/dns/loncapaCRL",\&save_crl_pem,1,1);
   }
   
   sub save_crl_pem {
       my ($response) = @_;
       my ($msg,$hadchanges);
       if (ref($response)) {
           my $now = time;
           my $lonca = $perlvar{'lonCertificateDirectory'}.'/'.$perlvar{'lonnetCertificateAuthority'};
           my $tmpcrl = $tmpdir.'/'.$perlvar{'lonnetCertRevocationList'}.'_'.$now.'.'.$$.'.tmp';
           if (open(my $fh,'>',"$tmpcrl")) {
               print $fh $response->content;
               close($fh);
               if (-e $lonca) {
                   if (open(PIPE,"openssl crl -in $tmpcrl -inform pem -CAfile $lonca -noout 2>&1 |")) {
                       my $check = <PIPE>;
                       close(PIPE);
                       chomp($check);
                       if ($check eq 'verify OK') {
                           my $dest = "$perlvar{'lonCertificateDirectory'}/$perlvar{'lonnetCertRevocationList'}";
                           my $backup;
                           if (-e $dest) {
                               if (&File::Copy::move($dest,"$dest.bak")) {
                                   $backup = 'ok';
                               }
                           }
                           if (&File::Copy::move($tmpcrl,$dest)) {
                               $msg = 'ok';
                               if ($backup) {
                                   my (%oldnums,%newnums);
                                   if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest.bak |grep 'Serial Number' |")) {
                                       while (<PIPE>) {
                                           $oldnums{(split(/:/))[1]} = 1;
                                       }
                                       close(PIPE);
                                   }
                                   if (open(PIPE, "openssl crl -inform PEM -text -noout -in $dest |grep 'Serial Number' |")) {
                                       while(<PIPE>) {
                                           $newnums{(split(/:/))[1]} = 1;
                                       }
                                       close(PIPE);
                                   }
                                   foreach my $key (sort {$b <=> $a } (keys(%newnums))) {
                                       unless (exists($oldnums{$key})) {
                                           $hadchanges = 1;
                                           last;
                                       }
                                   }
                                   unless ($hadchanges) {
                                       foreach my $key (sort {$b <=> $a } (keys(%oldnums))) {
                                           unless (exists($newnums{$key})) {
                                               $hadchanges = 1;
                                               last;
                                           }
                                       }
                                   }
                               }
                           }
                       } else {
                           unlink($tmpcrl);
                       }
                   } else {
                       unlink($tmpcrl);
                   }
               } else {
                   unlink($tmpcrl);
               }
           }
       }
       return ($msg,$hadchanges);
   }
   
 # ------------------------------------------------------------ Read domain file  # ------------------------------------------------------------ Read domain file
 {  {
     my $loaded;      my $loaded;
Line 14789  only used internally for recursive metad Line 15133  only used internally for recursive metad
 the toolsymb is only used where the uri is for an external tool (for which  the toolsymb is only used where the uri is for an external tool (for which
 the uri as well as the symb are guaranteed to be unique).  the uri as well as the symb are guaranteed to be unique).
   
 this function automatically caches all requests  this function automatically caches all requests except any made recursively
   to retrieve a list of metadata keys for an imported library file ($liburi is 
   defined).
   
 =item *  =item *
   
Removed from v.1.1368  
changed lines
  Added in v.1.1392

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>