[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.1369 and 1.1386

version 1.1369, 2018/03/27 04:36:11 version 1.1386, 2018/10/19 16:54:58
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 (grep { $_ eq $lonhost } &current_machine_ids()) {
         $uselocal = 1;          $uselocal = 1;
Line 250  sub get_servercerts_info { Line 255  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 652  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 716  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 758  sub appenv { Line 770  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 3182  sub ssi { Line 3197  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 5241  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 5262  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 9316  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 9339  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 10059  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 11928  sub metadata { Line 11974  sub metadata {
 # Check metadata for imported file to  # Check metadata for imported file to
 # see if it contained response items  # see if it contained response items
 #  #
                         my $libresponseorder = &metadata($location,'responseorder');                          my ($origfile,@libfilekeys);
                         my $origfile;                          my %currmetaentry = %metaentry;
                         if ($libresponseorder ne '') {                          @libfilekeys = split(/,/,&metadata($location,'keys',undef,undef,undef,
                             if ($#origfiletagids<0) {                                                             $depthcount+1));
                                 undef(%importedrespids);                          if (grep(/^responseorder$/,@libfilekeys)) {
                                 undef(%importedpartids);                              my $libresponseorder = &metadata($location,'responseorder',undef,undef,
                             }                                                               undef,$depthcount+1);
                             @{$importedrespids{$importid}} = split(/\s*,\s*/,$libresponseorder);                              if ($libresponseorder ne '') {
                             if (@{$importedrespids{$importid}} > 0) {                                  if ($#origfiletagids<0) {
                                 $importedresponses = 1;                                      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  # We need to get the original file and the imported file to get the response order correct
 # Load and inspect original file  # Load and inspect original file
                                 if ($#origfiletagids<0) {                                      if ($#origfiletagids<0) {
                                     my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);                                          my $origfilelocation=$perlvar{'lonDocRoot'}.&clutter($uri);
                                     $origfile=&getfile($origfilelocation);                                          $origfile=&getfile($origfilelocation);
                                     @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);                                          @origfiletagids=($origfile=~/<((?:\w+)response|import|part)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                                       }
                                 }                                  }
                             }                              }
                         }                          }
                         if ($importmode eq 'problem') {  # Do not overwrite contents of %metaentry hash for resource itself with 
 # Import as problem/response  # hash populated for imported library file
                            $unikey=&add_prefix_and_part($prefix,$token->[2]->{'part'});                          %metaentry = %currmetaentry;
                         } elsif ($importmode eq 'part') {                          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
Line 11965  sub metadata { Line 12021  sub metadata {
                                    @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);                                     @origfiletagids=($origfile=~/<(part|import)[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);
                                }                                 }
                            }                             }
                              my @impfilepartids;
 # Load and inspect imported file  # If <partorder> tag is included in metadata for the imported file
                            my $impfile=&getfile($location);  # get the parts in the imported file from that.
                            my @impfilepartids=($impfile=~/<part[^>]*id\s*=\s*[\"\']([^\"\']+)[\"\'][^>]*>/gs);                             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);
                              }
                            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 11979  sub metadata { Line 12048  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 12097  sub metadata { Line 12181  sub metadata {
                 } elsif ($origfiletagids[$index] eq 'import') {                  } elsif ($origfiletagids[$index] eq 'import') {
                     if ($importedparts) {                      if ($importedparts) {
 # We have imported parts at this position  # We have imported parts at this position
                         $metaentry{':partorder'}.=','.$importedpartids{$origid};                          if ($importedpartids{$origid} ne '') {
                               $metaentry{':partorder'}.=','.$importedpartids{$origid};
                           }
                     }                      }
                     if ($importedresponses) {                      if ($importedresponses) {
 # We have imported responses at this position  # We have imported responses at this position
                         if (ref($importedrespids{$origid}) eq 'ARRAY') {                          if ($importedrespids{$origid} ne '') {
                             $metaentry{':responseorder'}.=','.join(',',map { $origid.'_'.$_ } @{$importedrespids{$origid}});                              $metaentry{':responseorder'}.=','.$importedrespids{$origid};
                         }                          }
                     }                      }
                 } else {                  } else {
Line 12119  sub metadata { Line 12205  sub metadata {
                 $metaentry{':responseorder'}=~s/^\,//;                  $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 13463  sub get_dns { Line 13550  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 13479  sub get_dns { Line 13568  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 13551  sub fetch_dns_checksums { Line 13654  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 14846  only used internally for recursive metad Line 15022  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.1369  
changed lines
  Added in v.1.1386

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