--- loncom/lonnet/perl/lonnet.pm	2005/05/25 21:33:35	1.636
+++ loncom/lonnet/perl/lonnet.pm	2005/06/11 13:38:47	1.637
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.636 2005/05/25 21:33:35 albertel Exp $
+# $Id: lonnet.pm,v 1.637 2005/06/11 13:38:47 raeburn Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -47,6 +47,7 @@ use IO::Socket;
 use GDBM_File;
 use Apache::Constants qw(:common :http);
 use HTML::LCParser;
+use HTML::Parser;
 use Fcntl qw(:flock);
 use Apache::lonlocal;
 use Storable qw(lock_store lock_nstore lock_retrieve freeze thaw nfreeze);
@@ -1132,7 +1133,10 @@ sub allowuploaded {
 
 # --------- 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.
+#        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), 
 #         ok if successful, or diagnostic message otherwise (if action was propagate or copy)
 #
@@ -1155,10 +1159,10 @@ sub allowuploaded {
 #         /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
 #         in course's home server.
-
+#
 
 sub process_coursefile {
-    my ($action,$docuname,$docudom,$docuhome,$file,$source)=@_;
+    my ($action,$docuname,$docudom,$docuhome,$file,$source,$parser,$allfiles,$codebase)=@_;
     my $fetchresult;
     if ($action eq 'propagate') {
         $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
@@ -1169,16 +1173,7 @@ sub process_coursefile {
         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);
-                }
-            }
-        }
+        my $filepath = &build_filepath($fpath);
         if ($action eq 'copy') {
             if ($source eq '') {
                 $fetchresult = 'no source file';
@@ -1193,6 +1188,12 @@ sub process_coursefile {
             open(my $fh,'>'.$filepath.'/'.$fname);
             print $fh $env{'form.'.$source};
             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,
                                  $docuhome);
             if ($fetchresult eq 'ok') {
@@ -1211,6 +1212,43 @@ sub process_coursefile {
     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 {
     my ($fname)=@_;
 # Replace Windows backslashes by forward slashes
@@ -1233,7 +1271,7 @@ sub clean_filename {
 
 
 sub userfileupload {
-    my ($formname,$coursedoc,$subdir)=@_;
+    my ($formname,$coursedoc,$subdir,$parser,$allfiles,$codebase)=@_;
     if (!defined($subdir)) { $subdir='unknown'; }
     my $fname=$env{'form.'.$formname.'.filename'};
     $fname=&clean_filename($fname);
@@ -1266,21 +1304,21 @@ sub userfileupload {
 	$docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
 	$docuhome=$env{'course.'.$env{'request.course.id'}.'.home'};
         if ($env{'form.folder'} =~ m/^default/) {
-            return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
+            return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase);
         } else {
             $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 {
         $docuname=$env{'user.name'};
         $docudom=$env{'user.domain'};
         $docuhome=$env{'user.home'};
-        return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
+        return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase);
     }
 }
 
 sub finishuserfileupload {
-    my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
+    my ($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase) = @_;
     my $path=$docudom.'/'.$docuname.'/';
     my $filepath=$perlvar{'lonDocRoot'};
     my ($fnamepath,$file);
@@ -1303,6 +1341,12 @@ sub finishuserfileupload {
 	print FH $env{'form.'.$formname};
 	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
 #
     my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
@@ -1317,6 +1361,133 @@ 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 {
     my ($url)=@_;
     my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);