[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.598.2.2 and 1.603

version 1.598.2.2, 2005/02/15 17:13:54 version 1.603, 2005/03/03 05:45:50
Line 559  sub authenticate { Line 559  sub authenticate {
   
 # ---------------------- Find the homebase for a user from domain's lib servers  # ---------------------- Find the homebase for a user from domain's lib servers
   
   my %homecache;
 sub homeserver {  sub homeserver {
     my ($uname,$udom,$ignoreBadCache)=@_;      my ($uname,$udom,$ignoreBadCache)=@_;
     my $index="$uname:$udom";      my $index="$uname:$udom";
   
     my ($result,$cached)=&is_cached_new('home',$index);      if (exists($homecache{$index})) { return $homecache{$index}; }
     if (defined($cached)) { return $result; }  
     my $tryserver;      my $tryserver;
     foreach $tryserver (keys %libserv) {      foreach $tryserver (keys %libserv) {
         next if ($ignoreBadCache ne 'true' &&           next if ($ignoreBadCache ne 'true' && 
Line 572  sub homeserver { Line 572  sub homeserver {
  if ($hostdom{$tryserver} eq $udom) {   if ($hostdom{$tryserver} eq $udom) {
            my $answer=reply("home:$udom:$uname",$tryserver);             my $answer=reply("home:$udom:$uname",$tryserver);
            if ($answer eq 'found') {              if ($answer eq 'found') { 
        return &do_cache_new('home',$index,$tryserver,86400);         return $homecache{$index}=$tryserver;
            } elsif ($answer eq 'no_host') {             } elsif ($answer eq 'no_host') {
        $badServerCache{$tryserver}=1;         $badServerCache{$tryserver}=1;
            }             }
Line 838  sub save_cache { Line 838  sub save_cache {
     &purge_remembered();      &purge_remembered();
 }  }
   
 my $to_remember=20;  my $to_remember=-1;
 my %remembered;  my %remembered;
 my %accessed;  my %accessed;
 my $kicks=0;  my $kicks=0;
Line 883  sub do_cache_new { Line 883  sub do_cache_new {
  $setvalue='__undef__';   $setvalue='__undef__';
     }      }
     if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }      if ($debug) { &Apache::lonnet::logthis("Setting $id to $value"); }
     $memcache->set($id,$setvalue,300);      $memcache->set($id,$setvalue,$time);
     &make_room($id,$value,$debug);      # need to make a copy of $value
       #&make_room($id,$value,$debug);
     return $value;      return $value;
 }  }
   
 sub make_room {  sub make_room {
     my ($id,$value,$debug)=@_;      my ($id,$value,$debug)=@_;
     $remembered{$id}=$value;      $remembered{$id}=$value;
       if ($to_remember<0) { return; }
     $accessed{$id}=[&gettimeofday()];      $accessed{$id}=[&gettimeofday()];
     if (scalar(keys(%remembered)) <= $to_remember) { return; }      if (scalar(keys(%remembered)) <= $to_remember) { return; }
     my $to_kick;      my $to_kick;
Line 910  sub make_room { Line 912  sub make_room {
   
 sub purge_remembered {  sub purge_remembered {
     &logthis("Tossing ".scalar(keys(%remembered)));      &logthis("Tossing ".scalar(keys(%remembered)));
       &logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
     undef(%remembered);      undef(%remembered);
     undef(%accessed);      undef(%accessed);
 }  }
Line 991  sub subscribe { Line 994  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~m|^/home/httpd/html/adm/|) { return OK; }      if ($filename=~m|^/home/httpd/html/adm/|) { return 'OK'; }
     if ($filename=~m|^/home/httpd/html/lonUsers/|) { return OK; }      if ($filename=~m|^/home/httpd/html/lonUsers/|) { return 'OK'; }
     if ($filename=~m|^/home/httpd/html/userfiles/| or      if ($filename=~m|^/home/httpd/html/userfiles/| or
  $filename=~m|^/*uploaded/|) {    $filename=~m|^/*uploaded/|) { 
  return &repcopy_userfile($filename);   return &repcopy_userfile($filename);
     }      }
     $filename=~s/[\n\r]//g;      $filename=~s/[\n\r]//g;
     my $transname="$filename.in.transfer";      my $transname="$filename.in.transfer";
     if ((-e $filename) || (-e $transname)) { return OK; }      if ((-e $filename) || (-e $transname)) { return 'OK'; }
     my $remoteurl=subscribe($filename);      my $remoteurl=subscribe($filename);
     if ($remoteurl =~ /^con_lost by/) {      if ($remoteurl =~ /^con_lost by/) {
    &logthis("Subscribe returned $remoteurl: $filename");     &logthis("Subscribe returned $remoteurl: $filename");
            return HTTP_SERVICE_UNAVAILABLE;             return 'HTTP_SERVICE_UNAVAILABLE';
     } elsif ($remoteurl eq 'not_found') {      } elsif ($remoteurl eq 'not_found') {
    #&logthis("Subscribe returned not_found: $filename");     #&logthis("Subscribe returned not_found: $filename");
    return HTTP_NOT_FOUND;     return 'HTTP_NOT_FOUND';
     } elsif ($remoteurl =~ /^rejected by/) {      } elsif ($remoteurl =~ /^rejected by/) {
    &logthis("Subscribe returned $remoteurl: $filename");     &logthis("Subscribe returned $remoteurl: $filename");
            return FORBIDDEN;             return 'FORBIDDEN';
     } elsif ($remoteurl eq 'directory') {      } elsif ($remoteurl eq 'directory') {
            return OK;             return 'OK';
     } else {      } else {
         my $author=$filename;          my $author=$filename;
         $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;          $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
Line 1022  sub repcopy { Line 1025  sub repcopy {
            my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";             my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
            if ($path ne "$perlvar{'lonDocRoot'}/res") {             if ($path ne "$perlvar{'lonDocRoot'}/res") {
                &logthis("Malconfiguration for replication: $filename");                 &logthis("Malconfiguration for replication: $filename");
        return HTTP_BAD_REQUEST;         return 'HTTP_BAD_REQUEST';
            }             }
            my $count;             my $count;
            for ($count=5;$count<$#parts;$count++) {             for ($count=5;$count<$#parts;$count++) {
Line 1039  sub repcopy { Line 1042  sub repcopy {
                my $message=$response->status_line;                 my $message=$response->status_line;
                &logthis("<font color=blue>WARNING:"                 &logthis("<font color=blue>WARNING:"
                        ." LWP get: $message: $filename</font>");                         ." LWP get: $message: $filename</font>");
                return HTTP_SERVICE_UNAVAILABLE;                 return 'HTTP_SERVICE_UNAVAILABLE';
            } else {             } else {
        if ($remoteurl!~/\.meta$/) {         if ($remoteurl!~/\.meta$/) {
                   my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');                    my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
Line 1051  sub repcopy { Line 1054  sub repcopy {
                   }                    }
        }         }
                rename($transname,$filename);                 rename($transname,$filename);
                return OK;                 return 'OK';
            }             }
        }         }
     }      }
Line 4673  sub symblist { Line 4676  sub symblist {
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
                       &GDBM_WRCREAT(),0640)) {                        &GDBM_WRCREAT(),0640)) {
     foreach (keys %newhash) {      foreach (keys %newhash) {
                 $hash{declutter($_)}=$mapname.'___'.&deversion($newhash{$_});                  $hash{declutter($_)}=&encode_symb($mapname,$newhash{$_}->[1],
     $newhash{$_}->[0]);
             }              }
             if (untie(%hash)) {              if (untie(%hash)) {
  return 'ok';   return 'ok';
Line 4827  sub symbread { Line 4831  sub symbread {
         }          }
 # ---------------------------------------------------------- There was an entry  # ---------------------------------------------------------- There was an entry
         if ($syval) {          if ($syval) {
            unless ($syval=~/\_\d+$/) {      #unless ($syval=~/\_\d+$/) {
        unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {   #unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
                   &appenv('request.ambiguous' => $thisfn);      #&appenv('request.ambiguous' => $thisfn);
   return $ENV{$cache_str}='';      #return $ENV{$cache_str}='';
                }       #}    
                $syval.=$1;   #$syval.=$1;
    }      #}
         } else {          } else {
 # ------------------------------------------------------- Was not in symb table  # ------------------------------------------------------- Was not in symb table
            if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',             if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
Line 4877  sub symbread { Line 4881  sub symbread {
            }             }
         }          }
         if ($syval) {          if ($syval) {
     return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);      return $ENV{$cache_str}=$syval;
       #return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
Line 5232  sub getfile { Line 5237  sub getfile {
   
 sub repcopy_userfile {  sub repcopy_userfile {
     my ($file)=@_;      my ($file)=@_;
   
     if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }      if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }
     if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; }      if ($file =~ m|^/home/httpd/html/lonUsers/|) { return 'OK'; }
   
     my ($cdom,$cnum,$filename) =       my ($cdom,$cnum,$filename) = 
  ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);
     my ($info,$rtncode);      my ($info,$rtncode);
Line 5258  sub repcopy_userfile { Line 5261  sub repcopy_userfile {
     return -1;      return -1;
  }   }
  if ($info < $fileinfo[9]) {   if ($info < $fileinfo[9]) {
     return OK;      return 'OK';
  }   }
  $info = '';   $info = '';
  $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);   $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
Line 5292  sub repcopy_userfile { Line 5295  sub repcopy_userfile {
     open(FILE,">$file");      open(FILE,">$file");
     print FILE $info;      print FILE $info;
     close(FILE);      close(FILE);
     return OK;      return 'OK';
 }  }
   
 sub tokenwrapper {  sub tokenwrapper {
Line 5363  sub filelocation { Line 5366  sub filelocation {
    $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.     $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
        $udom.'/'.$uname.'/'.$filename;         $udom.'/'.$uname.'/'.$filename;
         }          }
     } elsif ($file =~ /^\/adm\/portfolio\//) {  
         $file =~ s:^/adm/portfolio/::;  
         $location = $location=&Apache::loncommon::propath($ENV{'user.domain'},$ENV{'user.name'}).'/userfiles/portfolio/'.$file;  
     } else {      } else {
         $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;          $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
         $file=~s:^/res/:/:;          $file=~s:^/res/:/:;
Line 5497  sub goodbye { Line 5497  sub goodbye {
    &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));     &logthis(sprintf("%-20s is %s",'%badServerCache',length(&freeze(\%badServerCache))));
 #converted  #converted
 #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));  #   &logthis(sprintf("%-20s is %s",'%metacache',scalar(%metacache)));
 #   &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));     &logthis(sprintf("%-20s is %s",'%homecache',length(&freeze(\%homecache))));
 #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));  #   &logthis(sprintf("%-20s is %s",'%titlecache',length(&freeze(\%titlecache))));
 #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));  #   &logthis(sprintf("%-20s is %s",'%courseresdatacache',length(&freeze(\%courseresdatacache))));
 #1.1 only  #1.1 only
Line 6112  subscribe($fname) : subscribe to a resou Line 6112  subscribe($fname) : subscribe to a resou
   
 repcopy($filename) : subscribes to the requested file, and attempts to  repcopy($filename) : subscribes to the requested file, and attempts to
 replicate from the owning library server, Might return  replicate from the owning library server, Might return
 HTTP_SERVICE_UNAVAILABLE, HTTP_NOT_FOUND, FORBIDDEN, OK, or  'HTTP_SERVICE_UNAVAILABLE', 'HTTP_NOT_FOUND', 'FORBIDDEN', 'OK', or
 HTTP_BAD_REQUEST, also attempts to grab the metadata for the  'HTTP_BAD_REQUEST', also attempts to grab the metadata for the
 resource. Expects the local filesystem pathname  resource. Expects the local filesystem pathname
 (/home/httpd/html/res/....)  (/home/httpd/html/res/....)
   
Removed from v.1.598.2.2  
changed lines
  Added in v.1.603

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