[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.636 and 1.637

version 1.636, 2005/05/25 21:33:35 version 1.637, 2005/06/11 13:38:47
Line 47  use IO::Socket; Line 47  use IO::Socket;
 use GDBM_File;  use GDBM_File;
 use Apache::Constants qw(:common :http);  use Apache::Constants qw(:common :http);
 use HTML::LCParser;  use HTML::LCParser;
   use HTML::Parser;
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use Apache::lonlocal;  use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);  use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
Line 1132  sub allowuploaded { Line 1133  sub allowuploaded {
   
 # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course  # --------- File operations in /home/httpd/html/userfiles/$domain/1/2/3/$course
 # input: action, courseID, current domain, home server for course, intended  # input: action, courseID, current domain, home server for course, intended
 #        path to file, source of file.  #        path to file, source of file, instruction to parse file for objects,
   #        ref to hash for embedded objects,
   #        ref to hash for codebase of java objects.
   #
 # output: url to file (if action was uploaddoc),   # output: url to file (if action was uploaddoc), 
 #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)  #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
 #  #
Line 1155  sub allowuploaded { Line 1159  sub allowuploaded {
 #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file  #         /home/httpd/html/userfiles/$domain/1/2/3/$course/$file
 #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file  #         and will then be copied to /home/httpd/lonUsers/1/2/3/$course/userfiles/$file
 #         in course's home server.  #         in course's home server.
   #
   
 sub process_coursefile {  sub process_coursefile {
     my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;      my ($action,$docuname,$docudom,$docuhome,$file,$source,$parser,$allfiles,$codebase)=@_;
     my $fetchresult;      my $fetchresult;
     if ($action eq 'propagate') {      if ($action eq 'propagate') {
         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file          $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
Line 1169  sub process_coursefile { Line 1173  sub process_coursefile {
         my $fname = $file;          my $fname = $file;
         ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);          ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
         $fpath=$docudom.'/'.$docuname.'/'.$fpath;          $fpath=$docudom.'/'.$docuname.'/'.$fpath;
         my $filepath=$perlvar{'lonDocRoot'}.'/userfiles';          my $filepath = &build_filepath($fpath);
         unless ($fpath eq '') {  
             my @parts=split('/',$fpath);  
             foreach my $part (@parts) {  
                 $filepath.= '/'.$part;  
                 if ((-e $filepath)!=1) {  
                     mkdir($filepath,0777);  
                 }  
             }  
         }  
         if ($action eq 'copy') {          if ($action eq 'copy') {
             if ($source eq '') {              if ($source eq '') {
                 $fetchresult = 'no source file';                  $fetchresult = 'no source file';
Line 1193  sub process_coursefile { Line 1188  sub process_coursefile {
             open(my $fh,'>'.$filepath.'/'.$fname);              open(my $fh,'>'.$filepath.'/'.$fname);
             print $fh $env{'form.'.$source};              print $fh $env{'form.'.$source};
             close($fh);              close($fh);
               if ($parser eq 'parse') {
                   my $parse_result = &extract_embedded_items($filepath,$fname,$allfiles,$codebase);
                   unless ($parse_result eq 'ok') {
                       &logthis('Failed to parse '.$filepath.'/'.$fname.' for embedded media: '.$parse_result);
                   }
               }
             $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,              $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                  $docuhome);                                   $docuhome);
             if ($fetchresult eq 'ok') {              if ($fetchresult eq 'ok') {
Line 1211  sub process_coursefile { Line 1212  sub process_coursefile {
     return $fetchresult;      return $fetchresult;
 }  }
   
   sub build_filepath {
       my ($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);
               }
           }
       }
       return $filepath;
   }
   
   sub store_edited_file {
       my ($primary_url,$content,$docudom,$docuname,$docuhome,$fetchresult) = @_;
       my $file = $primary_url;
       $file =~ s#^/uploaded/$docudom/$docuname/##;
       my $fpath = '';
       my $fname = $file;
       ($fpath,$fname) = ($file =~ m|^(.*)/([^/]+)$|);
       $fpath=$docudom.'/'.$docuname.'/'.$fpath;
       my $filepath = &build_filepath($fpath);
       open(my $fh,'>'.$filepath.'/'.$fname);
       print $fh $content;
       close($fh);
       $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
                                    $docuhome);
       if ($$fetchresult eq 'ok') {
           return '/uploaded/'.$fpath.'/'.$fname;
       } else {
           &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.                        ' to host '.$docuhome.': '.$$fetchresult);
           return '/adm/notfound.html';
       }
   }
   
 sub clean_filename {  sub clean_filename {
     my ($fname)=@_;      my ($fname)=@_;
 # Replace Windows backslashes by forward slashes  # Replace Windows backslashes by forward slashes
Line 1233  sub clean_filename { Line 1271  sub clean_filename {
   
   
 sub userfileupload {  sub userfileupload {
     my ($formname,$coursedoc,$subdir)=@_;      my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_;
     if (!defined($subdir)) { $subdir='unknown'; }      if (!defined($subdir)) { $subdir='unknown'; }
     my $fname=$env{'form.'.$formname.'.filename'};      my $fname=$env{'form.'.$formname.'.filename'};
     $fname=&clean_filename($fname);      $fname=&clean_filename($fname);
Line 1266  sub userfileupload { Line 1304  sub userfileupload {
  $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};   $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
  $docuhome=$env{'course.'.$env{'request.course.id'}.'.home'};   $docuhome=$env{'course.'.$env{'request.course.id'}.'.home'};
         if ($env{'form.folder'} =~ m/^default/) {          if ($env{'form.folder'} =~ m/^default/) {
             return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);              return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase);
         } else {          } else {
             $fname=$env{'form.folder'}.'/'.$fname;              $fname=$env{'form.folder'}.'/'.$fname;
             return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname);              return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname,$parser,$allfiles,$codebase);
         }          }
     } else {      } else {
         $docuname=$env{'user.name'};          $docuname=$env{'user.name'};
         $docudom=$env{'user.domain'};          $docudom=$env{'user.domain'};
         $docuhome=$env{'user.home'};          $docuhome=$env{'user.home'};
         return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);          return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase);
     }      }
 }  }
   
 sub finishuserfileupload {  sub finishuserfileupload {
     my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;      my ($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase) = @_;
     my $path=$docudom.'/'.$docuname.'/';      my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};      my $filepath=$perlvar{'lonDocRoot'};
     my ($fnamepath,$file);      my ($fnamepath,$file);
Line 1303  sub finishuserfileupload { Line 1341  sub finishuserfileupload {
  print FH $env{'form.'.$formname};   print FH $env{'form.'.$formname};
  close(FH);   close(FH);
     }      }
       if ($parser eq 'parse') {
           my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,$codebase);
           unless ($parse_result eq 'ok') {
               &logthis('Failed to parse '.$filepath.$file.' for embedded media: '.$parse_result); 
           }
       }
 # Notify homeserver to grep it  # Notify homeserver to grep it
 #  #
     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);      my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
Line 1317  sub finishuserfileupload { Line 1361  sub finishuserfileupload {
     }          }    
 }  }
   
   sub extract_embedded_items {
       my ($filepath,$file,$allfiles,$codebase) = @_;
       my @state = ();
       my %javafiles = (
                         codebase => '',
                         code => '',
                         archive => ''
                       );
       my %mediafiles = (
                         src => '',
                         movie => '',
                        );
       my $p = HTML::Parser->new
       (
           xml_mode => 1,
           start_h =>
               [sub {
                    my ($tagname, $attr) = @_;
                    push (@state, $tagname);
                    if (lc($tagname) eq 'img') {
                        if (exists($$allfiles{$attr->{'src'}})) {
                            unless (grep/^src$/,@{$$allfiles{$attr->{'src'}}}) {
                                push (@{$$allfiles{$attr->{'src'}}},&escape('src'));
                            }
                        } else {
                            @{$$allfiles{$attr->{'src'}}} = (&escape('src'));
                        }
                    }
                    if (lc($tagname) eq 'object') {
                        foreach my $item (keys (%javafiles)) {
                            $javafiles{$item} = '';
                        }
                    }
                    if (lc($state[-2]) eq 'object') {
                        if (lc($tagname) eq 'param') {
                            my $name = lc($attr->{'name'});
                            foreach my $item (keys (%mediafiles)) {
                                if ($name eq $item) {
                                    if (exists($$allfiles{$attr->{'value'}})) {
                                        unless(grep/^value$/,@{$$allfiles{$attr->{'value'}}}) {
                                            push(@{$$allfiles{$attr->{'value'}}},&escape('value'));
                                        }
                                    } else {
                                        @{$$allfiles{$attr->{'value'}}} = (&escape('value'));
                                    }
                                    last;
                                }
                            }
                            foreach my $item (keys (%javafiles)) {
                                if ($name eq $item) {
                                    $javafiles{$item} = $attr->{'value'};
                                    last;
                                }
                            }
                        }
                    }
                    if (lc($tagname) eq 'embed') {
                        unless (lc($state[-2]) eq 'object') {
                            foreach my $item (keys (%javafiles)) {
                                $javafiles{$item} = '';
                            }
                        }
                        foreach my $item (keys (%javafiles)) {
                            if ($attr->{$item}) {
                                $javafiles{$item} = $attr->{$item};
                                last;
                            }
                        }
                        foreach my $item (keys (%mediafiles)) {
                            if ($attr->{$item}) {
                                if (exists($$allfiles{$attr->{$item}})) {
                                    unless (grep/^$item$/,@{$$allfiles{$item}}) {
                                        push(@{$$allfiles{$attr->{$item}}},&escape($item));
                                    }
                                } else {
                                    @{$$allfiles{$attr->{$item}}} = (&escape($item));
                                }
                                last;
                            }
                        }
                    }
               }, "tagname, attr"],
           text_h =>
                [sub {
                    my ($text) = @_;
           }, "dtext"],
           end_h =>
                  [sub {
                      my ($tagname) = @_;
                      unless ($javafiles{'codebase'} eq '') {
                          $javafiles{'codebase'} .= '/';
                      }  
                      if (lc($tagname) eq 'object') {
                          &extract_java_items(\%javafiles,$allfiles,$codebase);
                      } 
                      if (lc($tagname) eq 'embed') {
                          unless (lc($state[-2]) eq 'object') {
                              &extract_java_items(\%javafiles,$allfiles,$codebase);
                          }
                      }
                      pop @state;
                   }, "tagname"],
       );
       $p->parse_file($filepath.'/'.$file);
       $p->eof;
       return 'ok';
   }
   
   sub extract_java_items {
       my ($javafiles,$allfiles,$codebase) = @_;
       foreach my $item (keys (%{$javafiles})) {
           unless ($item eq 'codebase') {
               if ($$javafiles{$item} ne '') {
                   if (exists($$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}})) {
                       unless (grep/^$item$/,@{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}}) {
                           push(@{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}},&escape($item));
                       }
                   } else {
                       @{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}} = (&escape($item));
                       $$codebase{$$javafiles{'codebase'}.$$javafiles{$item}} = $$javafiles{'codebase'};
                                                                                   
                   }
               }
           }
       }
   }
   
 sub removeuploadedurl {  sub removeuploadedurl {
     my ($url)=@_;      my ($url)=@_;
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);      my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
Removed from v.1.636  
changed lines
  Added in v.1.637

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