[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.1352 and 1.1357

version 1.1352, 2017/08/27 02:36:58 version 1.1357, 2017/10/16 16:33:54
Line 650  sub transfer_profile_to_env { Line 650  sub transfer_profile_to_env {
   
 # ---------------------------------------------------- Check for valid session   # ---------------------------------------------------- Check for valid session 
 sub check_for_valid_session {  sub check_for_valid_session {
     my ($r,$name,$userhashref) = @_;      my ($r,$name,$userhashref,$domref) = @_;
     my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));      my %cookies=CGI::Cookie->parse($r->header_in('Cookie'));
     my ($linkname,$pubname);      my ($linkname,$pubname);
     if ($name eq '') {      if ($name eq '') {
Line 678  sub check_for_valid_session { Line 678  sub check_for_valid_session {
     } else {      } else {
         $lonidsdir=$r->dir_config('lonIDsDir');          $lonidsdir=$r->dir_config('lonIDsDir');
     }      }
     return undef if (!-e "$lonidsdir/$handle.id");      if (!-e "$lonidsdir/$handle.id") {
           if ((ref($domref)) && ($name eq 'lonID') && 
               ($handle =~ /^($match_username)\_\d+\_($match_domain)\_(.+)$/)) {
               my ($possuname,$possudom,$possuhome) = ($1,$2,$3);
               if ((&domain($possudom) ne '') && (&homeserver($possuname,$possudom) eq $possuhome)) {
                   $$domref = $possudom;
               }
           }
           return undef;
       }
   
     my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");      my $opened = open(my $idf,'+<',"$lonidsdir/$handle.id");
     return undef if (!$opened);      return undef if (!$opened);
Line 2085  sub inst_directory_query { Line 2094  sub inst_directory_query {
     my $homeserver = &domain($udom,'primary');      my $homeserver = &domain($udom,'primary');
     my $outcome;      my $outcome;
     if ($homeserver ne '') {      if ($homeserver ne '') {
           unless ($homeserver eq $perlvar{'lonHostID'}) {
               if ($srch->{'srchby'} eq 'email') {
                   my $lcrev = &get_server_loncaparev(undef,$homeserver);
                   my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
                   if (($major eq '' && $minor eq '') || ($major < 2) ||
                       (($major == 2) && ($minor < 12))) {
                       return;
                   }
               }
           }
  my $queryid=&reply("querysend:instdirsearch:".   my $queryid=&reply("querysend:instdirsearch:".
    &escape($srch->{'srchby'}).':'.     &escape($srch->{'srchby'}).':'.
    &escape($srch->{'srchterm'}).':'.     &escape($srch->{'srchterm'}).':'.
Line 2126  sub usersearch { Line 2145  sub usersearch {
     my $query = 'usersearch';      my $query = 'usersearch';
     foreach my $tryserver (keys(%libserv)) {      foreach my $tryserver (keys(%libserv)) {
         if (&host_domain($tryserver) eq $dom) {          if (&host_domain($tryserver) eq $dom) {
               unless ($tryserver eq $perlvar{'lonHostID'}) {
                   if ($srch->{'srchby'} eq 'email') {
                       my $lcrev = &get_server_loncaparev(undef,$tryserver);
                       my ($major,$minor) = ($lcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/);
                       next if (($major eq '' && $minor eq '') || ($major < 2) ||
                                (($major == 2) && ($minor < 12)));
                   }
               }
             my $host=&hostname($tryserver);              my $host=&hostname($tryserver);
             my $queryid=              my $queryid=
                 &reply("querysend:".&escape($query).':'.                  &reply("querysend:".&escape($query).':'.
Line 2444  sub get_domain_defaults { Line 2471  sub get_domain_defaults {
         } elsif ($domconfig{'coursedefaults'}{'canclone'}) {          } elsif ($domconfig{'coursedefaults'}{'canclone'}) {
             $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};              $domdefaults{'canclone'}=$domconfig{'coursedefaults'}{'canclone'};
         }          }
           if ($domconfig{'coursedefaults'}{'texengine'}) {
               $domdefaults{'texengine'} = $domconfig{'coursedefaults'}{'texengine'};
           } 
     }      }
     if (ref($domconfig{'usersessions'}) eq 'HASH') {      if (ref($domconfig{'usersessions'}) eq 'HASH') {
         if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {          if (ref($domconfig{'usersessions'}{'remote'}) eq 'HASH') {
Line 3171  sub externalssi { Line 3201  sub externalssi {
     }      }
 }  }
   
   
   # If the local copy of a replicated resource is outdated, trigger a  
   # connection from the homeserver to flush the delayed queue. If no update 
   # happens, remove local copies of outdated resource (and corresponding
   # metadata file).
   
 sub remove_stale_resfile {  sub remove_stale_resfile {
     my ($url) = @_;      my ($url) = @_;
     my $stale;      my $removed;
     if ($url=~m{^/res/($match_domain)/($match_username)/}) {      if ($url=~m{^/res/($match_domain)/($match_username)/}) {
         my $audom = $1;          my $audom = $1;
         my $auname = $2;          my $auname = $2;
         unless (($url =~ /\.\d+\.\w+$/) || ($url !~ m{^/res/lib/templates/})) {          unless (($url =~ /\.\d+\.\w+$/) || ($url =~ m{^/res/lib/templates/})) {
             my $homeserver = &homeserver($auname,$audom);              my $homeserver = &homeserver($auname,$audom);
             unless (($homeserver eq 'no_host') ||              unless (($homeserver eq 'no_host') ||
                     (grep { $_ eq $homeserver } &current_machine_ids())) {                      (grep { $_ eq $homeserver } &current_machine_ids())) {
Line 3194  sub remove_stale_resfile { Line 3230  sub remove_stale_resfile {
                             my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );                              my $remmodtime = &HTTP::Date::str2time( $response->header('Last-modified') );
                             my $locmodtime = (stat($fname))[9];                              my $locmodtime = (stat($fname))[9];
                             if ($locmodtime < $remmodtime) {                              if ($locmodtime < $remmodtime) {
                                 unlink($fname);                                  my $stale;
                                 if ($uri!~/\.meta$/) {                                  my $answer = &reply('pong',$homeserver);
                                     unlink($fname.'.meta');                                  if ($answer eq $homeserver.':'.$perlvar{'lonHostID'}) {
                                       sleep(0.2);
                                       $locmodtime = (stat($fname))[9];
                                       if ($locmodtime < $remmodtime) {
                                           my $posstransfer = $fname.'.in.transfer';
                                           if ((-e $posstransfer) && ($remmodtime < (stat($posstransfer))[9])) {
                                               $removed = 1;
                                           } else {
                                               $stale = 1;
                                           }
                                       } else {
                                           $removed = 1;
                                       }
                                   } else {
                                       $stale = 1;
                                   }
                                   if ($stale) {
                                       unlink($fname);
                                       if ($uri!~/\.meta$/) {
                                           unlink($fname.'.meta');
                                       }
                                       &reply("unsub:$fname",$homeserver);
                                       $removed = 1;
                                 }                                  }
                                 &reply("unsub:$fname",$homeserver);  
                                 $stale = 1;  
                             }                              }
                         }                          }
                     }                      }
Line 3207  sub remove_stale_resfile { Line 3263  sub remove_stale_resfile {
             }              }
         }          }
     }      }
     return $stale;      return $removed;
 }  }
   
 # -------------------------------- Allow a /uploaded/ URI to be vouched for  # -------------------------------- Allow a /uploaded/ URI to be vouched for
Removed from v.1.1352  
changed lines
  Added in v.1.1357

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