[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.473 and 1.478

version 1.473, 2004/02/24 16:26:06 version 1.478, 2004/03/16 21:29:31
Line 1171  sub tokenwrapper { Line 1171  sub tokenwrapper {
     $uri=~s/^\///;      $uri=~s/^\///;
     $ENV{'user.environment'}=~/\/([^\/]+)\.id/;      $ENV{'user.environment'}=~/\/([^\/]+)\.id/;
     my $token=$1;      my $token=$1;
     if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {  #    if ($uri=~/^uploaded\/([^\/]+)\/([^\/]+)\/([^\/]+)(\?\.*)*$/) {
       if ($uri=~m|^uploaded/([^/]+)/([^/]+)/(.+)(\?\.*)*$|) {
  &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});   &appenv('userfile.'.$1.'/'.$2.'/'.$3 => $ENV{'request.course.id'});
         return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.          return 'http://'.$hostname{ &homeserver($2,$1)}.'/'.$uri.
                (($uri=~/\?/)?'&':'?').'token='.$token.                 (($uri=~/\?/)?'&':'?').'token='.$token.
Line 1180  sub tokenwrapper { Line 1181  sub tokenwrapper {
  return '/adm/notfound.html';   return '/adm/notfound.html';
     }      }
 }  }
       
   # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
   # input: action, courseID, current domain, home server for course, intended
   #        path to file, source of file.
   # output: ok if successful, diagnostic message otherwise
   #
   # Allows directory structure to be used within lonUsers/../userfiles/ for a 
   # course.
   #
   # action = propagate - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
   #          will be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles in
   #          course's home server.
   #
   # action = copy - /home/httpd/html/userfiles/$domain/1/2/3/$course/$file will
   #          be copied from $source (current location) to 
   #          /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
   #         and will then be copied to
   #          /home/httpd/lonUsers/$domain/1/2/3/$course/userfiles/$file in
   #         course's home server.
   
   sub process_coursefile {
       my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;
       my $fetchresult;
       if ($action eq 'propagate') {
           $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
                               ,$docuhome);
       } elsif ($action eq 'copy') {
           my $fetchresult = '';
           my $fpath = '';
           my $fname = $file;
           ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
           $fpath=$docudom.'/'.$docuname.'/'.$fpath;
           my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';
           unless ($fpath eq '') {
               my @parts=split('/',$fpath);
               foreach my $part (@parts) {
                   $filepath.= '/'.$part;
                   if ((-e $filepath)!=1) {
                       mkdir($filepath,0777);
                   }
               }
           }
           if ($source eq '') {
               $fetchresult = 'no source file';
           } else {
               my $destination = $filepath.'/'.$fname;
               print STDERR "Getting ready to rename $source to $destination\n";
               rename($source,$destination);
               $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                    $docuhome);
           }
       }
       unless ( ($fetchresult eq 'ok') || ($fetchresult eq 'no source file') ) {
           &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
                ' to host '.$docuhome.': '.$fetchresult);
       }
       return $fetchresult;
   }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  # --------------- Take an uploaded file and put it into the userfiles directory
 # input: name of form element, coursedoc=1 means this is for the course  # input: name of form element, coursedoc=1 means this is for the course
 # output: url of file in userspace  # output: url of file in userspace
Line 1236  sub finishuserfileupload { Line 1295  sub finishuserfileupload {
     }      }
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
       
     my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,      my $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$fname,
     $docuhome);      $docuhome);
     if ($fetchresult eq 'ok') {      if ($fetchresult eq 'ok') {
Line 4398  sub setup_random_from_rndseed { Line 4456  sub setup_random_from_rndseed {
     }      }
 }  }
   
   sub latest_receipt_algorithm_id {
       return 'receipt2';
   }
   
 sub ireceipt {  sub ireceipt {
     my ($funame,$fudom,$fucourseid,$fusymb)=@_;      my ($funame,$fudom,$fucourseid,$fusymb,$part)=@_;
     my $cuname=unpack("%32C*",$funame);      my $cuname=unpack("%32C*",$funame);
     my $cudom=unpack("%32C*",$fudom);      my $cudom=unpack("%32C*",$fudom);
     my $cucourseid=unpack("%32C*",$fucourseid);      my $cucourseid=unpack("%32C*",$fucourseid);
     my $cusymb=unpack("%32C*",$fusymb);      my $cusymb=unpack("%32C*",$fusymb);
     my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});      my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
     return unpack("%32C*",$perlvar{'lonHostID'}).'-'.      my $cpart=unpack("%32S*",$part);
            ($cunique%$cuname+      my $return =unpack("%32C*",$perlvar{'lonHostID'}).'-';
             $cunique%$cudom+      if ($ENV{"course.$fucourseid.receiptalg"} eq 'receipt2' ||
             $cusymb%$cuname+   $ENV{'request.state'} eq 'construct') {
             $cusymb%$cudom+   &Apache::lonxml::debug("doing receipt2  using parts $cpart, uname $cuname and udom $cudom gets  ".($cpart%$cuname).
             $cucourseid%$cuname+         " and ".($cpart%$cudom));
             $cucourseid%$cudom);         
    $return.= ($cunique%$cuname+
      $cunique%$cudom+
      $cusymb%$cuname+
      $cusymb%$cudom+
      $cucourseid%$cuname+
      $cucourseid%$cudom+
      $cpart%$cuname+
      $cpart%$cudom);
       } else {
    $return.= ($cunique%$cuname+
      $cunique%$cudom+
      $cusymb%$cuname+
      $cusymb%$cudom+
      $cucourseid%$cuname+
      $cucourseid%$cudom);
       }
       return $return;
 }  }
   
 sub receipt {  sub receipt {
   my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();      my ($part)=@_;
   return &ireceipt($name,$domain,$courseid,$symb);      my ($symb,$courseid,$domain,$name) = &Apache::lonxml::whichuser();
       return &ireceipt($name,$domain,$courseid,$symb,$part);
 }  }
   
 # ------------------------------------------------------------ Serves up a file  # ------------------------------------------------------------ Serves up a file
Line 4475  sub filelocation { Line 4555  sub filelocation {
   }    }
   $location=~s://+:/:g; # remove duplicate /    $location=~s://+:/:g; # remove duplicate /
   while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..    while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
     while ($location=~m:/\./:) {$location=~ s:/\./:/:g;} #remove /./
   return $location;    return $location;
 }  }
   
Removed from v.1.473  
changed lines
  Added in v.1.478

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