--- loncom/lonnet/perl/lonnet.pm 2005/05/03 19:22:22 1.632
+++ loncom/lonnet/perl/lonnet.pm 2005/06/13 20:23:54 1.638
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.632 2005/05/03 19:22:22 albertel Exp $
+# $Id: lonnet.pm,v 1.638 2005/06/13 20:23:54 albertel 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);
@@ -258,7 +259,6 @@ sub critical {
sub transfer_profile_to_env {
my ($lonidsdir,$handle)=@_;
- undef(%env);
my @profile;
{
open(my $idf,"$lonidsdir/$handle.id");
@@ -1132,8 +1132,11 @@ 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.
+# input: action, courseID, current domain, intended
+# 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)
#
@@ -1156,30 +1159,22 @@ 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,$file,$source,$parser,$allfiles,$codebase)=@_;
my $fetchresult;
+ my $home=&homeserver($docuname,$docudom);
if ($action eq 'propagate') {
- $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file
- ,$docuhome);
+ $fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
+ $home);
} else {
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);
- }
- }
- }
+ my $filepath = &build_filepath($fpath);
if ($action eq 'copy') {
if ($source eq '') {
$fetchresult = 'no source file';
@@ -1188,30 +1183,75 @@ sub process_coursefile {
my $destination = $filepath.'/'.$fname;
rename($source,$destination);
$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
- $docuhome);
+ $home);
}
} elsif ($action eq 'uploaddoc') {
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);
+ $home);
if ($fetchresult eq 'ok') {
return '/uploaded/'.$fpath.'/'.$fname;
} else {
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
- ' to host '.$docuhome.': '.$fetchresult);
+ ' to host '.$home.': '.$fetchresult);
return '/adm/notfound.html';
}
}
}
unless ( $fetchresult eq 'ok') {
&logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
- ' to host '.$docuhome.': '.$fetchresult);
+ ' to host '.$home.': '.$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,$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);
+ my $home=&homeserver($docuname,$docudom);
+ $$fetchresult= &reply('fetchuserfile:'.$docudom.'/'.$docuname.'/'.$file,
+ $home);
+ if ($$fetchresult eq 'ok') {
+ return '/uploaded/'.$fpath.'/'.$fname;
+ } else {
+ &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
+ ' to host '.$home.': '.$$fetchresult);
+ return '/adm/notfound.html';
+ }
+}
+
sub clean_filename {
my ($fname)=@_;
# Replace Windows backslashes by forward slashes
@@ -1234,7 +1274,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);
@@ -1258,30 +1298,30 @@ sub userfileupload {
return $fullpath.'/'.$fname;
}
# Create the directory if not present
- my $docuname='';
- my $docudom='';
- my $docuhome='';
$fname="$subdir/$fname";
if ($coursedoc) {
- $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
- $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
- $docuhome=$env{'course.'.$env{'request.course.id'}.'.home'};
+ my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
+ my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
if ($env{'form.folder'} =~ m/^default/) {
- return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname);
+ return &finishuserfileupload($docuname,$docudom,
+ $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,
+ $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);
+ my $docuname=$env{'user.name'};
+ my $docudom=$env{'user.domain'};
+ return &finishuserfileupload($docuname,$docudom,$formname,
+ $fname,$parser,$allfiles,$codebase);
}
}
sub finishuserfileupload {
- my ($docuname,$docudom,$docuhome,$formname,$fname)=@_;
+ my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
my ($fnamepath,$file);
@@ -1304,8 +1344,17 @@ 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 $docuhome=&homeserver($docuname,$docudom);
my $fetchresult= &reply('fetchuserfile:'.$path.$file,$docuhome);
if ($fetchresult eq 'ok') {
#
@@ -1318,6 +1367,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})) {
+ if ($item ne 'codebase') {
+ if ($$javafiles{$item} ne '') {
+ my $file=$javafiles->{'codebase'}.$javafiles->{$item};
+ if (exists($allfiles->{$file})) {
+ unless (scalar(grep(/^$item$/, @{$allfiles->{$file}}))) {
+ push(@{$allfiles->{$file}}, &escape($item));
+ }
+ } else {
+ @{$allfiles->{$file}} = (&escape($item));
+ $codebase->{$file} = $javafiles->{'codebase'};
+ }
+ }
+ }
+ }
+}
+
sub removeuploadedurl {
my ($url)=@_;
my (undef,undef,$udom,$uname,$fname)=split('/',$url,5);
@@ -3705,7 +3881,7 @@ sub createcourse {
</map>
ENDINITMAP
$topurl=&declutter(
- &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence')
+ &finishuserfileupload($uname,$udom,'initmap','default.sequence')
);
}
# ----------------------------------------------------------- Write preferences
@@ -3902,7 +4078,8 @@ sub unmark_as_readonly {
# unmarks $file_name (if $file_name is defined), or all files locked by $what
# for portfolio submissions, $what contains [$symb,$crsid]
my ($domain,$user,$what,$file_name) = @_;
- my $symb_crs = join('',@$what);
+ my $symb_crs = $what;
+ if (ref($what)) { $symb_crs=join('',@$what); }
my %current_permissions = &dump('file_permissions',$domain,$user);
my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }
@@ -4145,6 +4322,12 @@ sub get_courseresdata {
return $result;
}
+sub devalidateuserresdata {
+ my ($uname,$udom)=@_;
+ my $hashid="$udom:$uname";
+ &devalidate_cache_new('userres',$hashid);
+}
+
sub get_userresdata {
my ($uname,$udom)=@_;
#most student don\'t have any data set, check if there is some data
@@ -4168,7 +4351,9 @@ sub get_userresdata {
$uname." at ".$udom.": ".
$tmp."</font>");
} elsif ($tmp=~/error: 2 /) {
- &EXT_cache_set($udom,$uname);
+ #&EXT_cache_set($udom,$uname);
+ &do_cache_new('userres',$hashid,undef,600);
+ undef($tmp); # not really an error so don't send it back
}
return $tmp;
}
@@ -4212,7 +4397,7 @@ sub EXT_cache_status {
sub EXT_cache_set {
my ($target_domain,$target_user) = @_;
my $cachename = 'cache.EXT.'.$target_user.'.'.$target_domain;
- &appenv($cachename => time);
+ #&appenv($cachename => time);
}
# --------------------------------------------------------- Value of a Variable
@@ -4643,7 +4828,6 @@ sub metadata {
}
my ($extension) = ($uri =~ /\.(\w+)$/);
foreach my $key (sort(keys(%packagetab))) {
- #&logthis("extsion1 $extension $key !!");
#no specific packages #how's our extension
if ($key!~/^extension_\Q$extension\E&/) { next; }
&metadata_create_package_def($uri,$key,'extension_'.$extension,
@@ -6620,7 +6804,6 @@ userspace, probably shouldn't be called
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