[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.1364 and 1.1387

version 1.1364, 2017/12/22 17:58:16 version 1.1387, 2018/11/01 04:33:11
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 758  sub appenv { Line 772  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 3199  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 5243  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 5229  sub set_first_access { Line 5261  sub set_first_access {
                         'course.'.$courseid.'.timerinterval.'.$res => $interval,                          'course.'.$courseid.'.timerinterval.'.$res => $interval,
                      }                       }
                   );                    );
               if (($cachedtime) && (abs($start-$cachedtime) < 5)) {
                   $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 7143  sub usertools_access { Line 7181  sub usertools_access {
                       community  => 1,                        community  => 1,
                       textbook   => 1,                        textbook   => 1,
                       placement  => 1,                        placement  => 1,
                         lti        => 1,
                  );                   );
     } elsif ($context eq 'requestauthor') {      } elsif ($context eq 'requestauthor') {
         %tools = (          %tools = (
Line 7339  sub is_advanced_user { Line 7378  sub is_advanced_user {
 }  }
   
 sub check_can_request {  sub check_can_request {
     my ($dom,$can_request,$request_domains) = @_;      my ($dom,$can_request,$request_domains,$uname,$udom) = @_;
     my $canreq = 0;      my $canreq = 0;
       if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '')) {
           $uname = $env{'user.name'};
           $udom = $env{'user.domain'};
       }
     my ($types,$typename) = &Apache::loncommon::course_types();      my ($types,$typename) = &Apache::loncommon::course_types();
     my @options = ('approval','validate','autolimit');      my @options = ('approval','validate','autolimit');
     my $optregex = join('|',@options);      my $optregex = join('|',@options);
     if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {      if ((ref($can_request) eq 'HASH') && (ref($types) eq 'ARRAY')) {
         foreach my $type (@{$types}) {          foreach my $type (@{$types}) {
             if (&usertools_access($env{'user.name'},              if (&usertools_access($uname,$udom,$type,undef,
                                   $env{'user.domain'},                                    'requestcourses')) {
                                   $type,undef,'requestcourses')) {  
                 $canreq ++;                  $canreq ++;
                 if (ref($request_domains) eq 'HASH') {                  if (ref($request_domains) eq 'HASH') {
                     push(@{$request_domains->{$type}},$env{'user.domain'});                      push(@{$request_domains->{$type}},$udom);
                 }                  }
                 if ($dom eq $env{'user.domain'}) {                  if ($dom eq $udom) {
                     $can_request->{$type} = 1;                      $can_request->{$type} = 1;
                 }                  }
             }              }
             if ($env{'environment.reqcrsotherdom.'.$type} ne '') {              if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
                   ($env{'environment.reqcrsotherdom.'.$type} ne '')) {
                 my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});                  my @curr = split(',',$env{'environment.reqcrsotherdom.'.$type});
                 if (@curr > 0) {                  if (@curr > 0) {
                     foreach my $item (@curr) {                      foreach my $item (@curr) {
Line 7374  sub check_can_request { Line 7417  sub check_can_request {
                             }                              }
                         }                          }
                     }                      }
                     unless($dom eq $env{'user.domain'}) {                      unless ($dom eq $env{'user.domain'}) {
                         $canreq ++;                          $canreq ++;
                         if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {                          if (grep(/^\Q$dom\E:($optregex)(=?\d*)$/,@curr)) {
                             $can_request->{$type} = 1;                              $can_request->{$type} = 1;
Line 8889  sub auto_validate_class_sec { Line 8932  sub auto_validate_class_sec {
     return $response;      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 {  sub auto_crsreq_update {
     my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,      my ($cdom,$cnum,$crstype,$action,$ownername,$ownerdomain,$fullname,$title,
         $code,$accessstart,$accessend,$inbound) = @_;          $code,$accessstart,$accessend,$inbound) = @_;
Line 9248  sub assignrole { Line 9318  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 9268  sub assignrole { Line 9338  sub assignrole {
                             }                              }
                         }                          }
                     }                      }
                 } elsif (($selfenroll == 1) && ($role eq 'st') && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {                  } elsif (($selfenroll == 1) && ($udom eq $env{'user.domain'}) && ($uname eq $env{'user.name'})) {
                     $refused = '';                      if ($role eq 'st') {
                           $refused = '';
                       } elsif (($context eq 'ltienroll') && ($env{'request.lti.login'})) {
                           $refused = '';
                       }
                 } elsif ($context eq 'requestcourses') {                  } elsif ($context eq 'requestcourses') {
                     my @possroles = ('st','ta','ep','in','cc','co');                      my @possroles = ('st','ta','ep','in','cc','co');
                     if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {                      if ((grep(/^\Q$role\E$/,@possroles)) && ($env{'user.name'} ne '' && $env{'user.domain'} ne '')) {
Line 9535  sub modifyuser { Line 9609  sub modifyuser {
     my $newuser;      my $newuser;
     if ($uhome eq 'no_host') {      if ($uhome eq 'no_host') {
         $newuser = 1;          $newuser = 1;
           unless (($umode && ($upass ne '')) || ($umode eq 'localauth') ||
                   ($umode eq 'lti')) {
               return 'error: more information needed to create new user';
           }
     }      }
 # ----------------------------------------------------------------- Create User  # ----------------------------------------------------------------- Create User
     if (($uhome eq 'no_host') &&       if (($uhome eq 'no_host') && 
  (($umode && $upass) || ($umode eq 'localauth'))) {   (($umode && $upass) || ($umode eq 'localauth') || ($umode eq 'lti'))) {
         my $unhome='';          my $unhome='';
         if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) {           if (defined($desiredhome) && &host_domain($desiredhome) eq $udom) { 
             $unhome = $desiredhome;              $unhome = $desiredhome;
Line 9983  sub is_course { Line 10061  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 11201  sub get_numsuppfiles { Line 11292  sub get_numsuppfiles {
     unless (defined($cached)) {      unless (defined($cached)) {
         my $chome=&homeserver($cnum,$cdom);          my $chome=&homeserver($cnum,$cdom);
         unless ($chome eq 'no_host') {          unless ($chome eq 'no_host') {
             ($suppcount,my $errors) = (0,0);              ($suppcount,my $supptools,my $errors) = (0,0,0);
             my $suppmap = 'supplemental.sequence';              my $suppmap = 'supplemental.sequence';
             ($suppcount,$errors) =               ($suppcount,$supptools,$errors) =
                 &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,$errors);                  &Apache::loncommon::recurse_supplemental($cnum,$cdom,$suppmap,$suppcount,
                                                            $supptools,$errors);
         }          }
         &do_cache_new('suppcount',$hashid,$suppcount,600);          &do_cache_new('suppcount',$hashid,$suppcount,600);
     }      }
Line 11691  sub add_prefix_and_part { Line 11783  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 11777  sub metadata { Line 11870  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 11874  sub metadata { Line 11969  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 11905  sub metadata { Line 12050  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 11920  sub metadata { Line 12080  sub metadata {
  $metaentry{':'.$meta}=$metaentry{':'.$meta};   $metaentry{':'.$meta}=$metaentry{':'.$meta};
  $metathesekeys{$meta}=1;   $metathesekeys{$meta}=1;
     }      }
   
                         }                          }
     } else {      } else {
 #  #
Line 12003  sub metadata { Line 12162  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 13362  sub get_dns { Line 13552  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 13378  sub get_dns { Line 13570  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 13450  sub fetch_dns_checksums { Line 13656  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 14745  only used internally for recursive metad Line 15024  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.1364  
changed lines
  Added in v.1.1387

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