[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.827 and 1.831

version 1.827, 2007/01/18 18:21:10 version 1.831, 2007/01/29 21:16:55
Line 367  sub transfer_profile_to_env { Line 367  sub transfer_profile_to_env {
     }      }
 }  }
   
   sub timed_flock {
       my ($file,$lock_type) = @_;
       my $failed=0;
       eval {
    local $SIG{__DIE__}='DEFAULT';
    local $SIG{ALRM}=sub {
       $failed=1;
       die("failed lock");
    };
    alarm(13);
    flock($file,$lock_type);
    alarm(0);
       };
       if ($failed) {
    return undef;
       } else {
    return 1;
       }
   }
   
 # ---------------------------------------------------------- Append Environment  # ---------------------------------------------------------- Append Environment
   
 sub appenv {  sub appenv {
Line 381  sub appenv { Line 401  sub appenv {
             $env{$key}=$newenv{$key};              $env{$key}=$newenv{$key};
         }          }
     }      }
     if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),      open(my $env_file,$env{'user.environment'});
     0640)) {      if (&timed_flock($env_file,LOCK_EX)
    &&
    tie(my %disk_env,'GDBM_File',$env{'user.environment'},
       (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  while (my ($key,$value) = each(%newenv)) {   while (my ($key,$value) = each(%newenv)) {
     $disk_env{$key} = $value;      $disk_env{$key} = $value;
  }   }
Line 399  sub delenv { Line 422  sub delenv {
                 "Attempt to delete from environment ".$delthis);                  "Attempt to delete from environment ".$delthis);
         return 'error';          return 'error';
     }      }
     if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),      open(my $env_file,$env{'user.environment'});
     0640)) {      if (&timed_flock($env_file,LOCK_EX)
    &&
    tie(my %disk_env,'GDBM_File',$env{'user.environment'},
       (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
  foreach my $key (keys(%disk_env)) {   foreach my $key (keys(%disk_env)) {
     if ($key=~/^$delthis/) {       if ($key=~/^$delthis/) { 
                 delete($env{$key});                  delete($env{$key});
Line 1176  sub repcopy { Line 1202  sub repcopy {
     }      }
     $filename=~s/[\n\r]//g;      $filename=~s/[\n\r]//g;
     my $transname="$filename.in.transfer";      my $transname="$filename.in.transfer";
   # FIXME: this should flock
     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/) {
Line 1424  sub store_edited_file { Line 1451  sub store_edited_file {
 }  }
   
 sub clean_filename {  sub clean_filename {
     my ($fname)=@_;      my ($fname,$args)=@_;
 # Replace Windows backslashes by forward slashes  # Replace Windows backslashes by forward slashes
     $fname=~s/\\/\//g;      $fname=~s/\\/\//g;
 # Get rid of everything but the actual filename      if (!$args->{'keep_path'}) {
     $fname=~s/^.*\/([^\/]+)$/$1/;          # Get rid of everything but the actual filename
    $fname=~s/^.*\/([^\/]+)$/$1/;
       }
 # Replace spaces by underscores  # Replace spaces by underscores
     $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  # Replace all .\d. sequences with _\d. so they no longer look like version
 # numbers  # numbers
     $fname=~s/\.(\d+)(?=\.)/_$1/g;      $fname=~s/\.(\d+)(?=\.)/_$1/g;
Line 7158  sub repcopy_userfile { Line 7187  sub repcopy_userfile {
     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/+($match_domain)/+($match_name)/+(.*)|);   ($file=~m|^\Q$perlvar{'lonDocRoot'}\E/+userfiles/+($match_domain)/+($match_name)/+(.*)|);
     my ($info,$rtncode);  
     my $uri="/uploaded/$cdom/$cnum/$filename";      my $uri="/uploaded/$cdom/$cnum/$filename";
     if (-e "$file") {      if (-e "$file") {
   # we already have a local copy, check it out
  my @fileinfo = stat($file);   my @fileinfo = stat($file);
    my $rtncode;
    my $info;
  my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);   my $lwpresp = &getuploaded('HEAD',$uri,$cdom,$cnum,\$info,\$rtncode);
  if ($lwpresp ne 'ok') {   if ($lwpresp ne 'ok') {
   # there is no such file anymore, even though we had a local copy
     if ($rtncode eq '404') {      if ($rtncode eq '404') {
  unlink($file);   unlink($file);
     }      }
     #my $ua=new LWP::UserAgent;  
     #my $request=new HTTP::Request('GET',&tokenwrapper($uri));  
     #my $response=$ua->request($request);  
     #if ($response->is_success()) {  
  # return $response->content;  
  #    } else {  
  # return -1;  
  #    }  
     return -1;      return -1;
  }   }
  if ($info < $fileinfo[9]) {   if ($info < $fileinfo[9]) {
   # nice, the file we have is up-to-date, just say okay
     return 'ok';      return 'ok';
    } else {
   # the file is outdated, get rid of it
       unlink($file);
  }   }
  $info = '';      }
  $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);  # one way or the other, at this point, we don't have the file
  if ($lwpresp ne 'ok') {  # construct the correct path for the file
     return -1;      my @parts = ($cdom,$cnum); 
  }      if ($filename =~ m|^(.+)/[^/]+$|) {
     } else {   push @parts, split(/\//,$1);
  my $lwpresp = &getuploaded('GET',$uri,$cdom,$cnum,\$info,\$rtncode);      }
  if ($lwpresp ne 'ok') {      my $path = $perlvar{'lonDocRoot'}.'/userfiles';
     my $ua=new LWP::UserAgent;      foreach my $part (@parts) {
     my $request=new HTTP::Request('GET',&tokenwrapper($uri));   $path .= '/'.$part;
     # FIXME, right reads everything into memory then writes it out   if (!-e $path) {
     # doing something like      mkdir($path,0770);
     #    my $response=$ua->request($request,$file);  
     # would make this write directly to disk  
     my $response=$ua->request($request);  
     if ($response->is_success()) {  
  $info=$response->content;  
     } else {  
  return -1;  
     }  
  }  
  my @parts = ($cdom,$cnum);   
  if ($filename =~ m|^(.+)/[^/]+$|) {  
     push @parts, split(/\//,$1);  
  }  
  my $path = $perlvar{'lonDocRoot'}.'/userfiles';  
  foreach my $part (@parts) {  
     $path .= '/'.$part;  
     if (!-e $path) {  
  mkdir($path,0770);  
     }  
  }   }
     }      }
     open(FILE,">$file");  # now the path exists for sure
     print FILE $info;  # get a user agent
     close(FILE);      my $ua=new LWP::UserAgent;
       my $transferfile=$file.'.in.transfer';
   # FIXME: this should flock
       if (-e $transferfile) { return 'ok'; }
       my $request;
       $uri=~s/^\///;
       $request=new HTTP::Request('GET','http://'.$hostname{&homeserver($cnum,$cdom)}.'/raw/'.$uri);
       my $response=$ua->request($request,$transferfile);
   # did it work?
       if ($response->is_error()) {
    unlink($transferfile);
    &logthis("Userfile repcopy failed for $uri");
    return -1;
       }
   # worked, rename the transfer file
       rename($transferfile,$file);
     return 'ok';      return 'ok';
 }  }
   
Line 7237  sub tokenwrapper { Line 7261  sub tokenwrapper {
     }      }
 }  }
   
   # call with reqtype HEAD: get last modification time
   # call with reqtype GET: get the file contents
   # Do not call this with reqtype GET for large files! It loads everything into memory
   #
 sub getuploaded {  sub getuploaded {
     my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;      my ($reqtype,$uri,$cdom,$cnum,$info,$rtncode) = @_;
     $uri=~s/^\///;      $uri=~s/^\///;
Removed from v.1.827  
changed lines
  Added in v.1.831

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