[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.532 and 1.546

version 1.532, 2004/08/25 16:03:17 version 1.546, 2004/09/22 20:43:20
Line 50  use Fcntl qw(:flock); Line 50  use Fcntl qw(:flock);
 use Apache::loncoursedata;  use Apache::loncoursedata;
 use Apache::lonlocal;  use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw);
 use Time::HiRes();  use Time::HiRes qw( gettimeofday tv_interval );
 my $readit;  my $readit;
   
 =pod  =pod
Line 821  sub getsection { Line 821  sub getsection {
 }  }
   
   
 my $disk_caching_disabled=1;  my $disk_caching_disabled=0;
   
 sub devalidate_cache {  sub devalidate_cache {
     my ($cache,$id,$name) = @_;      my ($cache,$id,$name) = @_;
     delete $$cache{$id.'.time'};      delete $$cache{$id.'.time'};
       delete $$cache{$id.'.file'};
     delete $$cache{$id};      delete $$cache{$id};
     if ($disk_caching_disabled) { return; }      if (1 || $disk_caching_disabled) { return; }
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     open(DB,"$filename.lock");      if (!-e $filename) { return; }
       open(DB,">$filename.lock");
     flock(DB,LOCK_EX);      flock(DB,LOCK_EX);
     my %hash;      my %hash;
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {      if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
Line 856  sub is_cached { Line 858  sub is_cached {
     my ($cache,$id,$name,$time) = @_;      my ($cache,$id,$name,$time) = @_;
     if (!$time) { $time=300; }      if (!$time) { $time=300; }
     if (!exists($$cache{$id.'.time'})) {      if (!exists($$cache{$id.'.time'})) {
  &load_cache_item($cache,$name,$id);   &load_cache_item($cache,$name,$id,$time);
     }      }
     if (!exists($$cache{$id.'.time'})) {      if (!exists($$cache{$id.'.time'})) {
 # &logthis("Didn't find $id");  # &logthis("Didn't find $id");
  return (undef,undef);   return (undef,undef);
     } else {      } else {
  if (time-($$cache{$id.'.time'})>$time) {   if (time-($$cache{$id.'.time'})>$time) {
 #    &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));      if (exists($$cache{$id.'.file'})) {
     &devalidate_cache($cache,$id,$name);   foreach my $filename (@{ $$cache{$id.'.file'} }) {
     return (undef,undef);      my $mtime=(stat($filename))[9];
       #+1 is to take care of edge effects
       if ($mtime && (($mtime+1) < ($$cache{$id.'.time'}))) {
   # &logthis("Upping $mtime - ".$$cache{$id.'.time'}.
   # "$id because of $filename");
       } else {
    &logthis("Devalidating $filename $id - ".(time-($$cache{$id.'.time'})));
    &devalidate_cache($cache,$id,$name);
    return (undef,undef);
       }
    }
    $$cache{$id.'.time'}=time;
       } else {
   # &logthis("Devalidating $id - ".time-($$cache{$id.'.time'}));
    &devalidate_cache($cache,$id,$name);
    return (undef,undef);
       }
  }   }
     }      }
     return ($$cache{$id},1);      return ($$cache{$id},1);
Line 881  sub do_cache { Line 899  sub do_cache {
     $$cache{$id};      $$cache{$id};
 }  }
   
   my %do_save_item;
   my %do_save;
 sub save_cache_item {  sub save_cache_item {
     my ($cache,$name,$id)=@_;      my ($cache,$name,$id)=@_;
     if ($disk_caching_disabled) { return; }      if ($disk_caching_disabled) { return; }
     my $starttime=&Time::HiRes::time();      $do_save{$name}=$cache;
 #    &logthis("Saving :$name:$id");      if (!exists($do_save_item{$name})) { $do_save_item{$name}={} }
     my %hash;      $do_save_item{$name}->{$id}=1;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      return;
     open(DB,"$filename.lock");  }
     flock(DB,LOCK_EX);  
     if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {  sub save_cache {
  eval <<'EVALBLOCK';      if ($disk_caching_disabled) { return; }
     $hash{$id.'.time'}=$$cache{$id.'.time'};      my ($cache,$name,$id);
     $hash{$id}=freeze({'item'=>$$cache{$id}});      foreach $name (keys(%do_save)) {
    $cache=$do_save{$name};
   
    my $starttime=&Time::HiRes::time();
    &logthis("Saving :$name:");
    my %hash;
    my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
    open(DB,">$filename.lock");
    flock(DB,LOCK_EX);
    if (tie(%hash,'GDBM_File',$filename,&GDBM_WRCREAT(),0640)) {
       foreach $id (keys(%{ $do_save_item{$name} })) {
    eval <<'EVALBLOCK';
    $hash{$id.'.time'}=$$cache{$id.'.time'};
    $hash{$id}=freeze({'item'=>$$cache{$id}});
    if (exists($$cache{$id.'.file'})) {
       $hash{$id.'.file'}=freeze({'item'=>$$cache{$id.'.file'}});
    }
 EVALBLOCK  EVALBLOCK
         if ($@) {                  if ($@) {
     &logthis("<font color='red'>save_cache blew up :$@:$name</font>");      &logthis("<font color='red'>save_cache blew up :$@:$name</font>");
     unlink($filename);      unlink($filename);
  }      last;
     } else {   }
  if (-e $filename) {      }
     &logthis("Unable to tie hash (save cache item): $name ($!)");   } else {
     unlink($filename);      if (-e $filename) {
    &logthis("Unable to tie hash (save cache): $name ($!)");
    unlink($filename);
       }
  }   }
    untie(%hash);
    flock(DB,LOCK_UN);
    close(DB);
    &logthis("save_cache $name took ".(&Time::HiRes::time()-$starttime));
     }      }
     untie(%hash);      undef(%do_save);
     flock(DB,LOCK_UN);      undef(%do_save_item);
     close(DB);  
 #    &logthis("save_cache_item $name took ".(&Time::HiRes::time()-$starttime));  
 }  }
   
 sub load_cache_item {  sub load_cache_item {
     my ($cache,$name,$id)=@_;      my ($cache,$name,$id,$time)=@_;
     if ($disk_caching_disabled) { return; }      if ($disk_caching_disabled) { return; }
     my $starttime=&Time::HiRes::time();      my $starttime=&Time::HiRes::time();
 #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));  #    &logthis("Before Loading $name  for $id size is ".scalar(%$cache));
     my %hash;      my %hash;
     my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";      my $filename=$perlvar{'lonDaemons'}.'/tmp/lonnet_internal_cache_'.$name.".db";
     open(DB,"$filename.lock");      if (!-e $filename) { return; }
       open(DB,">$filename.lock");
     flock(DB,LOCK_SH);      flock(DB,LOCK_SH);
     if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {      if (tie(%hash,'GDBM_File',$filename,&GDBM_READER(),0640)) {
  eval <<'EVALBLOCK';   eval <<'EVALBLOCK';
Line 935  sub load_cache_item { Line 978  sub load_cache_item {
  }   }
 #    &logthis("Initial load: $count");  #    &logthis("Initial load: $count");
     } else {      } else {
  my $hashref=thaw($hash{$id});   if (($$cache{$id.'.time'}+$time) < time) {
  $$cache{$id}=$hashref->{'item'};      $$cache{$id.'.time'}=$hash{$id.'.time'};
  $$cache{$id.'.time'}=$hash{$id.'.time'};      {
    my $hashref=thaw($hash{$id});
    $$cache{$id}=$hashref->{'item'};
       }
       if (exists($hash{$id.'.file'})) {
    my $hashref=thaw($hash{$id.'.file'});
    $$cache{$id.'.file'}=$hashref->{'item'};
       }
    }
     }      }
 EVALBLOCK  EVALBLOCK
         if ($@) {          if ($@) {
Line 1067  sub subscribe { Line 1118  sub subscribe {
 sub repcopy {  sub repcopy {
     my $filename=shift;      my $filename=shift;
     $filename=~s/\/+/\//g;      $filename=~s/\/+/\//g;
     if ($filename=~/^\/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/userfiles/| or
    $filename=~m|^/*uploaded/|) { 
    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; }
Line 1279  sub clean_filename { Line 1335  sub clean_filename {
     $fname=~s/\s+/\_/g;      $fname=~s/\s+/\_/g;
 # Replace all other weird characters by nothing  # Replace all other weird characters by nothing
     $fname=~s/[^\w\.\-]//g;      $fname=~s/[^\w\.\-]//g;
   # Replace all .\d. sequences with _\d. so they no longer look like version
   # numbers
       $fname=~s/\.(\d+)(?=\.)/_$1/g;
     return $fname;      return $fname;
 }  }
   
Line 2715  sub allowed { Line 2774  sub allowed {
     $uri=&deversion($uri);      $uri=&deversion($uri);
     my $orguri=$uri;      my $orguri=$uri;
     $uri=&declutter($uri);      $uri=&declutter($uri);
       
       
       
     if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }      if (defined($ENV{'allowed.'.$priv})) { return $ENV{'allowed.'.$priv}; }
 # Free bre access to adm and meta resources  # Free bre access to adm and meta resources
     if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|))       if (((($uri=~/^adm\//) && ($uri !~ m|/bulletinboard$|)) 
Line 2723  sub allowed { Line 2784  sub allowed {
  return 'F';   return 'F';
     }      }
   
   # Free bre access to user's own portfolio contents
       my ($space,$domain,$name,$dir)=split('/',$uri);
       if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) && 
    ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
           return 'F';
       }
   
 # Free bre to public access  # Free bre to public access
   
     if ($priv eq 'bre') {      if ($priv eq 'bre') {
Line 3679  sub revokecustomrole { Line 3747  sub revokecustomrole {
            $deleteflag);             $deleteflag);
 }  }
   
   # ------------------------------------------------------------ Disk usage
 # ------------------------------------------------------------ Portfolio Director Lister  sub diskusage {
 # returns listing of contents of user's /userfiles/portfolio/ directory      my ($udom,$uname,$directoryRoot)=@_;
 #       $directoryRoot =~ s/\/$//;
       my $listing=&reply('du:'.$directoryRoot,homeserver($uname,$udom));
 sub portfoliolist {  
     my ($currentPath, $currentFile) = @_;  
     my ($udom, $uname, $portfolioRoot);  
     $uname=$ENV{'user.name'};  
     $udom=$ENV{'user.domain'};  
     # really should interrogate the system for home directory information, but . . .  
     $portfolioRoot = '/home/httpd/lonUsers/'.$udom.'/';  
     $uname =~ /^(.?)(.?)(.?)/;  
     $portfolioRoot = $portfolioRoot.$1.'/'.$2.'/'.$3.'/'.$uname.'/userfiles/portfolio';  
     my $listing = &reply('ls:'.$portfolioRoot.$currentPath, &homeserver($uname,$udom));  
     return $listing;  
 }  
   
 sub portfoliomanage {  
   
 #FIXME please user the existing remove userfile function instead and  
 #add a userfilerename functions.  
 #FIXME uhome should never be an argument to any lonnet functions  
   
     # handles deleting and renaming files in user's userfiles/portfolio/ directory  
     #   
     my ($filename, $fileaction, $filenewname) = @_;  
     my ($udom, $uname, $uhome);  
     $uname=$ENV{'user.name'};  
     $udom=$ENV{'user.domain'};  
     $uhome=$ENV{'user.home'};  
     my $listing = reply('portfoliomanage:'.$uname.':'.$udom.':'.$filename.':'.$fileaction.':'.$filenewname, $uhome);  
     return $listing;      return $listing;
 }  }
   
Line 4048  sub EXT { Line 4089  sub EXT {
   
  my $section;   my $section;
  if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {   if (defined($courseid) && $courseid eq $ENV{'request.course.id'}) {
       if (!$symbparm) { $symbparm=&symbread(); }
    }
    if ($symbparm && defined($courseid) && 
       $courseid eq $ENV{'request.course.id'}) {
   
     #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;      #print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
   
 # ----------------------------------------------------- Cascading lookup scheme  # ----------------------------------------------------- Cascading lookup scheme
     if (!$symbparm) { $symbparm=&symbread(); }  
     my $symbp=$symbparm;      my $symbp=$symbparm;
     my $mapp=(&decode_symb($symbp))[0];      my $mapp=(&decode_symb($symbp))[0];
   
Line 4063  sub EXT { Line 4107  sub EXT {
  ($ENV{'user.domain'} eq $udom)) {   ($ENV{'user.domain'} eq $udom)) {
  $section=$ENV{'request.course.sec'};   $section=$ENV{'request.course.sec'};
     } else {      } else {
                 if (! defined($usection)) {   if (! defined($usection)) {
                     $section=&usection($udom,$uname,$courseid);      $section=&usection($udom,$uname,$courseid);
                 } else {   } else {
                     $section = $usection;      $section = $usection;
                 }   }
     }      }
   
     my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;      my $seclevel=$courseid.'.['.$section.'].'.$spacequalifierrest;
Line 4105  sub EXT { Line 4149  sub EXT {
  $uname." at ".$udom.": ".   $uname." at ".$udom.": ".
  $tmp."</font>");   $tmp."</font>");
     } elsif ($tmp=~/error: 2 /) {      } elsif ($tmp=~/error: 2 /) {
                         &EXT_cache_set($udom,$uname);   &EXT_cache_set($udom,$uname);
     } elsif ($tmp =~ /^(con_lost|no_such_host)/) {      } elsif ($tmp =~ /^(con_lost|no_such_host)/) {
  return $tmp;   return $tmp;
     }      }
Line 4115  sub EXT { Line 4159  sub EXT {
 # -------------------------------------------------------- second, check course  # -------------------------------------------------------- second, check course
   
     my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},      my $coursereply=&courseresdata($ENV{'course.'.$courseid.'.num'},
   $ENV{'course.'.$courseid.'.domain'},     $ENV{'course.'.$courseid.'.domain'},
   ($seclevelr,$seclevelm,$seclevel,     ($seclevelr,$seclevelm,$seclevel,
    $courselevelr,$courselevelm,      $courselevelr,$courselevelm,
    $courselevel));      $courselevel));
     if (defined($coursereply)) { return $coursereply; }      if (defined($coursereply)) { return $coursereply; }
   
 # ------------------------------------------------------ third, check map parms  # ------------------------------------------------------ third, check map parms
Line 4253  sub metadata { Line 4297  sub metadata {
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m|^uploaded/|) {   if ($uri !~ m|^uploaded/|) {
     $metastring=&getfile(&filelocation('',&clutter($filename)));      my $file=&filelocation('',&clutter($filename));
       push(@{$metacache{$uri.'.file'}},$file);
       $metastring=&getfile($file);
  }   }
         my $parser=HTML::LCParser->new(\$metastring);          my $parser=HTML::LCParser->new(\$metastring);
         my $token;          my $token;
Line 4466  sub metadata_generate_part0 { Line 4512  sub metadata_generate_part0 {
 sub gettitle {  sub gettitle {
     my $urlsymb=shift;      my $urlsymb=shift;
     my $symb=&symbread($urlsymb);      my $symb=&symbread($urlsymb);
     unless ($symb) {      if ($symb) {
  unless ($urlsymb) { $urlsymb=$ENV{'request.filename'}; }   my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);
         return &metadata($urlsymb,'title');    if (defined($cached)) { return $result; }
     }   my ($map,$resid,$url)=&decode_symb($symb);
     my ($result,$cached)=&is_cached(\%titlecache,$symb,'title',600);   my $title='';
     if (defined($cached)) { return $result; }   my %bighash;
     my ($map,$resid,$url)=&decode_symb($symb);   if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
     my $title='';   &GDBM_READER(),0640)) {
     my %bighash;      my $mapid=$bighash{'map_pc_'.&clutter($map)};
     if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',      $title=$bighash{'title_'.$mapid.'.'.$resid};
                             &GDBM_READER(),0640)) {      untie %bighash;
         my $mapid=$bighash{'map_pc_'.&clutter($map)};   }
         $title=$bighash{'title_'.$mapid.'.'.$resid};   $title=~s/\&colon\;/\:/gs;
         untie %bighash;   if ($title) {
     }      return &do_cache(\%titlecache,$symb,$title,'title');
     $title=~s/\&colon\;/\:/gs;   }
     if ($title) {   $urlsymb=$url;
         return &do_cache(\%titlecache,$symb,$title,'title');      }
     } else {      my $title=&metadata($urlsymb,'title');
  return &metadata($urlsymb,'title');      if (!$title) { $title=(split('/',$urlsymb))[-1]; }    
     }      return $title;
 }  }
           
 # ------------------------------------------------- Update symbolic store links  # ------------------------------------------------- Update symbolic store links
Line 4618  sub deversion { Line 4664  sub deversion {
   
 sub symbread {  sub symbread {
     my ($thisfn,$donotrecurse)=@_;      my ($thisfn,$donotrecurse)=@_;
       my $cache_str='request.symbread.cached.'.$thisfn;
       if (defined($ENV{$cache_str})) { return $ENV{$cache_str}; }
 # no filename provided? try from environment  # no filename provided? try from environment
     unless ($thisfn) {      unless ($thisfn) {
         if ($ENV{'request.symb'}) { return &symbclean($ENV{'request.symb'}); }          if ($ENV{'request.symb'}) {
       return $ENV{$cache_str}=&symbclean($ENV{'request.symb'});
    }
  $thisfn=$ENV{'request.filename'};   $thisfn=$ENV{'request.filename'};
     }      }
 # is that filename actually a symb? Verify, clean, and return  # is that filename actually a symb? Verify, clean, and return
     if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {      if ($thisfn=~/\_\_\_\d+\_\_\_(.*)$/) {
  if (&symbverify($thisfn,$1)) { return &symbclean($thisfn); }   if (&symbverify($thisfn,$1)) {
       return $ENV{$cache_str}=&symbclean($thisfn);
    }
     }      }
     $thisfn=declutter($thisfn);      $thisfn=declutter($thisfn);
     my %hash;      my %hash;
Line 4646  sub symbread { Line 4698  sub symbread {
            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 '';    return $ENV{$cache_str}='';
                }                     }    
                $syval.=$1;                 $syval.=$1;
    }     }
Line 4693  sub symbread { Line 4745  sub symbread {
            }             }
         }          }
         if ($syval) {          if ($syval) {
            return &symbclean($syval.'___'.$thisfn);       return $ENV{$cache_str}=&symbclean($syval.'___'.$thisfn);
         }          }
     }      }
     &appenv('request.ambiguous' => $thisfn);      &appenv('request.ambiguous' => $thisfn);
     return '';      return $ENV{$cache_str}='';
 }  }
   
 # ---------------------------------------------------------- Return random seed  # ---------------------------------------------------------- Return random seed
Line 4958  sub receipt { Line 5010  sub receipt {
 # the local server.     # the local server.   
   
 sub getfile {  sub getfile {
     my ($file,$caller) = @_;      my ($file) = @_;
   
     if ($file !~ m|^/*uploaded/(\w+)/(\w+)/(.+)$|) {      if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }
  # normal file from res space      &repcopy($file);
  &repcopy($file);      return &readfile($file);
         return &readfile($file);  }
     }  
   sub repcopy_userfile {
     my $info;      my ($file)=@_;
     my $cdom = $1;  
     my $cnum = $2;      if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }
     my $filename = $3;      if ($file =~ m|^/home/httpd/html/lonUsers/|) { return OK; }
     my $path = $Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles';  
     my ($lwpresp,$rtncode);      my ($cdom,$cnum,$filename) = 
     my $localfile = $path.'/'.$cdom.'/'.$cnum.'/'.$filename;   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+([^/]+)/+([^/]+)/+(.*)|);
     if (-e "$localfile") {      my ($info,$rtncode);
  my @fileinfo = stat($localfile);      my $uri="/uploaded/$cdom/$cnum/$filename";
  $lwpresp = &getuploaded('HEAD',$file,$cdom,$cnum,\$info,\$rtncode);      if (-e "$file") {
    my @fileinfo = stat($file);
    my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     if ($rtncode eq '404') {      if ($rtncode eq '404') {
  unlink($localfile);   unlink($file);
     }      }
     #my $ua=new LWP::UserAgent;      #my $ua=new LWP::UserAgent;
     #my $request=new HTTP::Request('GET',&tokenwrapper($file));      #my $request=new HTTP::Request('GET',&tokenwrapper($uri));
     #my $response=$ua->request($request);      #my $response=$ua->request($request);
     #if ($response->is_success()) {      #if ($response->is_success()) {
  # return $response->content;   # return $response->content;
Line 4991  sub getfile { Line 5045  sub getfile {
     return -1;      return -1;
  }   }
  if ($info < $fileinfo[9]) {   if ($info < $fileinfo[9]) {
     return &readfile($localfile);      return OK;
  }   }
  $info = '';   $info = '';
  $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);   $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     return -1;      return -1;
  }   }
     } else {      } else {
  $lwpresp = &getuploaded('GET',$file,$cdom,$cnum,\$info,\$rtncode);   my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
     my $ua=new LWP::UserAgent;      my $ua=new LWP::UserAgent;
     my $request=new HTTP::Request('GET',&tokenwrapper($file));      my $request=new HTTP::Request('GET',&tokenwrapper($uri));
     my $response=$ua->request($request);      my $response=$ua->request($request);
     if ($response->is_success()) {      if ($response->is_success()) {
  return $response->content;   $info=$response->content;
     } else {      } else {
  return -1;   return -1;
     }      }
Line 5014  sub getfile { Line 5068  sub getfile {
  if ($filename =~ m|^(.+)/[^/]+$|) {   if ($filename =~ m|^(.+)/[^/]+$|) {
     push @parts, split(/\//,$1);      push @parts, split(/\//,$1);
  }   }
    my $path = $perlvar{'lonDocRoot'}.'/userfiles';
  foreach my $part (@parts) {   foreach my $part (@parts) {
     $path .= '/'.$part;      $path .= '/'.$part;
     if (!-e $path) {      if (!-e $path) {
Line 5021  sub getfile { Line 5076  sub getfile {
     }      }
  }   }
     }      }
     open (FILE,">$localfile");      open(FILE,">$file");
     print FILE $info;      print FILE $info;
     close(FILE);      close(FILE);
     if ($caller eq 'uploadrep') {      return OK;
  return 'ok';  
     }  
     return $info;  
 }  }
   
 sub tokenwrapper {  sub tokenwrapper {
Line 5083  sub filelocation { Line 5135  sub filelocation {
     $location = $file;      $location = $file;
     $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;      $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
   } elsif ($file=~/^\/*uploaded/) { # is an uploaded file    } elsif ($file=~/^\/*uploaded/) { # is an uploaded file
       if ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/(\/)?simplepage\/([^\/]+)$/) {        my ($udom,$uname,$filename)=
   $location=&Apache::loncommon::propath($1,$2).'/userfiles/simplepage/'.$4;    ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|);
   if (not -e $location) {        my $home=&homeserver($uname,$udom);
       $file=~/^\/uploaded\/(.*)$/;        my $is_me=0;
       $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1;        my @ids=&current_machine_ids();
   }        foreach my $id (@ids) { if ($id eq $home) { $is_me=1; } }
       } elsif ($file=~/^\/uploaded\/([^\/]+)\/([^\/]+)\/aboutme\/([^\/]+)$/) {        if ($is_me) {
   $location=&Apache::loncommon::propath($1,$2).'/userfiles/aboutme/'.$3;    $location=&Apache::loncommon::propath($udom,$uname).
          if (not -e $location) {        '/userfiles/'.$filename;
      $file=~/^\/uploaded\/(.*)$/;  
      $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.$1;  
          }  
       } else {        } else {
   $location=$file;    $location=$Apache::lonnet::perlvar{'lonDocRoot'}.'/userfiles/'.
         $udom.'/'.$uname.'/'.$filename;
       }        }
   } else {    } else {
     $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;      $file=~s/^\Q$perlvar{'lonDocRoot'}\E//;
Line 5293  BEGIN { Line 5343  BEGIN {
  $hostip{$id}=$ip;   $hostip{$id}=$ip;
  $iphost{$ip}=$id;   $iphost{$ip}=$id;
  if ($role eq 'library') { $libserv{$id}=$name; }   if ($role eq 'library') { $libserv{$id}=$name; }
        } else {  
  if ($configline) {  
    &logthis("Skipping hosts.tab line -$configline-");  
  }  
        }         }
     }      }
     close($config);      close($config);
Removed from v.1.532  
changed lines
  Added in v.1.546

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