[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.601 and 1.612

version 1.601, 2005/03/01 00:22:59 version 1.612, 2005/03/17 21:18:12
Line 911  sub make_room { Line 911  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))));      #&logthis(sprintf("%-20s is %s",'%remembered',length(&freeze(\%remembered))));
     undef(%remembered);      undef(%remembered);
     undef(%accessed);      undef(%accessed);
 }  }
Line 994  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|editupload)/-) { 
  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 '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 '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 1025  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 'bad_request';
            }             }
            my $count;             my $count;
            for ($count=5;$count<$#parts;$count++) {             for ($count=5;$count<$#parts;$count++) {
Line 1042  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 '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 1054  sub repcopy { Line 1054  sub repcopy {
                   }                    }
        }         }
                rename($transname,$filename);                 rename($transname,$filename);
                return OK;                 return 'ok';
            }             }
        }         }
     }      }
Line 1063  sub repcopy { Line 1063  sub repcopy {
 # ------------------------------------------------ Get server side include body  # ------------------------------------------------ Get server side include body
 sub ssi_body {  sub ssi_body {
     my ($filelink,%form)=@_;      my ($filelink,%form)=@_;
       if (! exists($form{'LONCAPA_INTERNAL_no_discussion'})) {
           $form{'LONCAPA_INTERNAL_no_discussion'}='true';
       }
     my $output=($filelink=~/^http\:/?&externalssi($filelink):      my $output=($filelink=~/^http\:/?&externalssi($filelink):
                                      &ssi($filelink,%form));                                       &ssi($filelink,%form));
     $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs;      $output=~s|//(\s*<!--)? BEGIN LON-CAPA Internal.+// END LON-CAPA Internal\s*(-->)?\s||gs;
Line 1196  sub process_coursefile { Line 1199  sub process_coursefile {
     return $fetchresult;      return $fetchresult;
 }  }
   
 # --------------- Take an uploaded file and put it into the userfiles directory  
 # input: name of form element, coursedoc=1 means this is for the course  
 # output: url of file in userspace  
   
 sub clean_filename {  sub clean_filename {
     my ($fname)=@_;      my ($fname)=@_;
 # Replace Windows backslashes by forward slashes  # Replace Windows backslashes by forward slashes
Line 1216  sub clean_filename { Line 1215  sub clean_filename {
     return $fname;      return $fname;
 }  }
   
   # --------------- Take an uploaded file and put it into the userfiles directory
   # input: name of form element, coursedoc=1 means this is for the course
   # output: url of file in userspace
   
   
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc,$subdir)=@_;      my ($formname,$coursedoc,$subdir)=@_;
     if (!defined($subdir)) { $subdir='unknown'; }      if (!defined($subdir)) { $subdir='unknown'; }
Line 2703  sub allowed { Line 2707  sub allowed {
   
 # Free bre access to user's own portfolio contents  # Free bre access to user's own portfolio contents
     my ($space,$domain,$name,$dir)=split('/',$uri);      my ($space,$domain,$name,$dir)=split('/',$uri);
     if (('uploaded' eq $space) && ($ENV{'user.name'} eq $name) &&       if (($space=~/^(uploaded|ediupload)$/) && ($ENV{'user.name'} eq $name) && 
  ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {   ($ENV{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
         return 'F';          return 'F';
     }      }
Line 2772  sub allowed { Line 2776  sub allowed {
     }      }
   
 # URI is an uploaded document for this course  # URI is an uploaded document for this course
   # not allowing 'edit' access (editupload) to uploaded course docs
     if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {      if (($priv eq 'bre') && ($uri=~m|^uploaded/|)) {
  my $refuri=$ENV{'httpref.'.$orguri};   my $refuri=$ENV{'httpref.'.$orguri};
  if ($refuri) {   if ($refuri) {
Line 3895  sub dirlist { Line 3899  sub dirlist {
   
     if($udom) {      if($udom) {
         if($uname) {          if($uname) {
             my $listing=reply('ls:'.$dirRoot.'/'.$uri,              my $listing=reply('ls2:'.$dirRoot.'/'.$uri,
                               homeserver($uname,$udom));                                homeserver($uname,$udom));
             return split(/:/,$listing);              my @listing_results;
               if ($listing eq 'unknown_cmd') {
                   $listing=reply('ls:'.$dirRoot.'/'.$uri,
                                  homeserver($uname,$udom));
                   @listing_results = split(/:/,$listing);
               } else {
                   @listing_results = map { &unescape($_); } split(/:/,$listing);
               }
               return @listing_results;
         } elsif(!defined($alternateDirectoryRoot)) {          } elsif(!defined($alternateDirectoryRoot)) {
             my $tryserver;              my $tryserver;
             my %allusers=();              my %allusers=();
             foreach $tryserver (keys %libserv) {              foreach $tryserver (keys %libserv) {
                 if($hostdom{$tryserver} eq $udom) {                  if($hostdom{$tryserver} eq $udom) {
                     my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.                      my $listing=reply('ls2:'.$perlvar{'lonDocRoot'}.'/res/'.
                                       $udom, $tryserver);                                        $udom, $tryserver);
                     if (($listing ne 'no_such_dir') && ($listing ne 'empty')                      my @listing_results;
                         && ($listing ne 'con_lost')) {                      if ($listing eq 'unknown_cmd') {
                         foreach (split(/:/,$listing)) {                          $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.
                                          $udom, $tryserver);
                           @listing_results = split(/:/,$listing);
                       } else {
                           @listing_results =
                               map { &unescape($_); } split(/:/,$listing);
                       }
                       if ($listing_results[0] ne 'no_such_dir' && 
                           $listing_results[0] ne 'empty'       &&
                           $listing_results[0] ne 'con_lost') {
                           foreach (@listing_results) {
                             my ($entry,@stat)=split(/&/,$_);                              my ($entry,@stat)=split(/&/,$_);
                             $allusers{$entry}=1;                              $allusers{$entry}=1;
                         }                          }
Line 4424  sub metadata { Line 4446  sub metadata {
         my %metathesekeys=();          my %metathesekeys=();
         unless ($filename=~/\.meta$/) { $filename.='.meta'; }          unless ($filename=~/\.meta$/) { $filename.='.meta'; }
  my $metastring;   my $metastring;
  if ($uri !~ m|^uploaded/|) {   if ($uri !~ m -^(uploaded|editupload)/-) {
     my $file=&filelocation('',&clutter($filename));      my $file=&filelocation('',&clutter($filename));
     #push(@{$metaentry{$uri.'.file'}},$file);      #push(@{$metaentry{$uri.'.file'}},$file);
     $metastring=&getfile($file);      $metastring=&getfile($file);
Line 4767  sub decode_symb { Line 4789  sub decode_symb {
   
 sub fixversion {  sub fixversion {
     my $fn=shift;      my $fn=shift;
     if ($fn=~/^(adm|uploaded|public)/) { return $fn; }      if ($fn=~/^(adm|uploaded|editupload|public)/) { return $fn; }
     my %bighash;      my %bighash;
     my $uri=&clutter($fn);      my $uri=&clutter($fn);
     my $key=$ENV{'request.course.id'}.'_'.$uri;      my $key=$ENV{'request.course.id'}.'_'.$uri;
Line 4821  sub symbread { Line 4843  sub symbread {
     my $syval='';      my $syval='';
     if (($ENV{'request.course.fn'}) && ($thisfn)) {      if (($ENV{'request.course.fn'}) && ($thisfn)) {
         my $targetfn = $thisfn;          my $targetfn = $thisfn;
         if ( ($thisfn =~ m/^uploaded\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {          if ( ($thisfn =~ m/^(uploaded|editupload)\//) && ($thisfn !~ m/\.(page|sequence)$/) ) {
             $targetfn = 'adm/wrapper/'.$thisfn;              $targetfn = 'adm/wrapper/'.$thisfn;
         }          }
         if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',          if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
Line 5229  sub receipt { Line 5251  sub receipt {
   
 sub getfile {  sub getfile {
     my ($file) = @_;      my ($file) = @_;
       if ($file =~ m -^/*(uploaded|editupload)/-) { $file=&filelocation("",$file); }
     if ($file =~ m|^/*uploaded/|) { $file=&filelocation("",$file); }  
     &repcopy($file);      &repcopy($file);
     return &readfile($file);      return &readfile($file);
 }  }
   
 sub repcopy_userfile {  sub repcopy_userfile {
     my ($file)=@_;      my ($file)=@_;
       if ($file =~ m -^/*(uploaded|editupload)/-) { $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 5263  sub repcopy_userfile { Line 5282  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 5297  sub repcopy_userfile { Line 5316  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 5354  sub filelocation { Line 5373  sub filelocation {
     if ($file=~m:^/~:) { # is a contruction space reference      if ($file=~m:^/~:) { # is a contruction space reference
         $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|editupload)/) { # is an uploaded file
         my ($udom,$uname,$filename)=          my ($udom,$uname,$filename)=
      ($file=~m|^/+uploaded/+([^/]+)/+([^/]+)/+(.*)$|);       ($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);
         my $home=&homeserver($uname,$udom);          my $home=&homeserver($uname,$udom);
         my $is_me=0;          my $is_me=0;
         my @ids=&current_machine_ids();          my @ids=&current_machine_ids();
Line 5368  sub filelocation { Line 5387  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 5441  sub declutter { Line 5457  sub declutter {
   
 sub clutter {  sub clutter {
     my $thisfn='/'.&declutter(shift);      my $thisfn='/'.&declutter(shift);
     unless ($thisfn=~/^\/(uploaded|adm|userfiles|ext|raw|priv|public)\//) {       unless ($thisfn=~/^\/(uploaded|editupload|adm|userfiles|ext|raw|priv|public)\//) { 
        $thisfn='/res'.$thisfn;          $thisfn='/res'.$thisfn; 
     }      }
     return $thisfn;      return $thisfn;
Line 6117  subscribe($fname) : subscribe to a resou Line 6133  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  'unavailable', 'not_found', 'forbidden', 'ok', or
 HTTP_BAD_REQUEST, also attempts to grab the metadata for the  '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/....)
   
Line 6460  declutter() : declutters URLs (remove do Line 6476  declutter() : declutters URLs (remove do
   
 =back  =back
   
   =head2 Usererfile file routines (/uploaded*)
   
   =over 4
   
   =item *
   
   userfileupload(): main rotine for putting a file in a user or course's
                     filespace, arguments are,
   
    formname - required - this is the name of the element in $ENV where the
              filename, and the contents of the file to create/modifed exist
              the filename is in $ENV{'form.'.$formname.'.filename'} and the
              contents of the file is located in $ENV{'form.'.$formname}
    coursedoc - if true, store the file in the course of the active role
                of the current user
    subdir - required - subdirectory to put the file in under ../userfiles/
            if undefined, it will be placed in "unknown"
   
    (This routine calls clean_filename() to remove any dangerous
    characters from the filename, and then calls finuserfileupload() to
    complete the transaction)
   
    returns either the url of the uploaded file (/uploaded/....) if successful
    and /adm/notfound.html if unsuccessful
   
   =item *
   
   clean_filename(): routine for cleaing a filename up for storage in
                    userfile space, argument is:
   
    filename - proposed filename
   
   returns: the new clean filename
   
   =item *
   
   finishuserfileupload(): routine that creaes and sends the file to
   userspace, probably shouldn't be called directly
   
     docuname: username or courseid of destination for the file
     docudom: domain of user/course of destination for the file
     docuhome: loncapa id of the library server that is getting the file
     formname: same as for userfileupload()
     fname: filename (inculding subdirectories) for the file
   
    returns either the url of the uploaded file (/uploaded/....) if successful
    and /adm/notfound.html if unsuccessful
   
   =item *
   
   renameuserfile(): renames an existing userfile to a new name
   
     Args:
      docuname: username or courseid of destination for the file
      docudom: domain of user/course of destination for the file
      old: current file name (including any subdirs under userfiles)
      new: desired file name (including any subdirs under userfiles)
   
   =item *
   
   mkdiruserfile(): creates a directory is a userfiles dir
   
     Args:
      docuname: username or courseid of destination for the file
      docudom: domain of user/course of destination for the file
      dir: dir to create (including any subdirs under userfiles)
   
   =item *
   
   removeuserfile(): removes a file that exists in userfiles
   
     Args:
      docuname: username or courseid of destination for the file
      docudom: domain of user/course of destination for the file
      fname: filname to delete (including any subdirs under userfiles)
   
   =item *
   
   removeuploadedurl(): convience function for removeuserfile()
   
     Args:
      url:  a full /uploaded/... url to delete
   
   =back
   
 =head2 HTTP Helper Routines  =head2 HTTP Helper Routines
   
 =over 4  =over 4
Removed from v.1.601  
changed lines
  Added in v.1.612

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