--- loncom/lonnet/perl/lonnet.pm 2005/06/11 13:38:47 1.637
+++ loncom/lonnet/perl/lonnet.pm 2005/08/09 16:33:03 1.650
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.637 2005/06/11 13:38:47 raeburn Exp $
+# $Id: lonnet.pm,v 1.650 2005/08/09 16:33:03 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -1132,7 +1132,7 @@ sub allowuploaded {
}
# --------- 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, 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.
@@ -1162,11 +1162,12 @@ sub allowuploaded {
#
sub process_coursefile {
- my ($action,$docuname,$docudom,$docuhome,$file,$source,$parser,$allfiles,$codebase)=@_;
+ 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 = '';
@@ -1182,7 +1183,7 @@ 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);
@@ -1195,19 +1196,19 @@ sub process_coursefile {
}
}
$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;
}
@@ -1228,7 +1229,7 @@ sub build_filepath {
}
sub store_edited_file {
- my ($primary_url,$content,$docudom,$docuname,$docuhome,$fetchresult) = @_;
+ my ($primary_url,$content,$docudom,$docuname,$fetchresult) = @_;
my $file = $primary_url;
$file =~ s#^/uploaded/$docudom/$docuname/##;
my $fpath = '';
@@ -1239,12 +1240,14 @@ sub store_edited_file {
open(my $fh,'>'.$filepath.'/'.$fname);
print $fh $content;
close($fh);
+ my $home=&homeserver($docuname,$docudom);
$$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);
+ &logthis('Failed to transfer '.$docudom.'/'.$docuname.'/'.$file.
+ ' to host '.$home.': '.$$fetchresult);
return '/adm/notfound.html';
}
}
@@ -1295,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'};
- if ($env{'form.folder'} =~ m/^default/) {
- return &finishuserfileupload($docuname,$docudom,$docuhome,$formname,$fname,$parser,$allfiles,$codebase);
+ my $docuname=$env{'course.'.$env{'request.course.id'}.'.num'};
+ my $docudom=$env{'course.'.$env{'request.course.id'}.'.domain'};
+ if ($env{'form.folder'} =~ m/^(default|supplemental)/) {
+ return &finishuserfileupload($docuname,$docudom,
+ $formname,$fname,$parser,$allfiles,
+ $codebase);
} else {
$fname=$env{'form.folder'}.'/'.$fname;
- return &process_coursefile('uploaddoc',$docuname,$docudom,$docuhome,$fname,$formname,$parser,$allfiles,$codebase);
+ 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,$parser,$allfiles,$codebase);
+ 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,$parser,$allfiles,$codebase) = @_;
+ my ($docuname,$docudom,$formname,$fname,$parser,$allfiles,$codebase) = @_;
my $path=$docudom.'/'.$docuname.'/';
my $filepath=$perlvar{'lonDocRoot'};
my ($fnamepath,$file);
@@ -1342,13 +1345,16 @@ sub finishuserfileupload {
close(FH);
}
if ($parser eq 'parse') {
- my $parse_result = &extract_embedded_items($filepath,$file,$allfiles,$codebase);
+ 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);
+ &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') {
#
@@ -1362,7 +1368,7 @@ sub finishuserfileupload {
}
sub extract_embedded_items {
- my ($filepath,$file,$allfiles,$codebase) = @_;
+ my ($filepath,$file,$allfiles,$codebase,$content) = @_;
my @state = ();
my %javafiles = (
codebase => '',
@@ -1373,118 +1379,99 @@ sub extract_embedded_items {
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));
- }
+ my $p;
+ if ($content) {
+ $p = HTML::LCParser->new($content);
+ } else {
+ $p = HTML::LCParser->new($filepath.'/'.$file);
+ }
+ while (my $t=$p->get_token()) {
+ if ($t->[0] eq 'S') {
+ my ($tagname, $attr) = ($t->[1],$t->[2]);
+ push (@state, $tagname);
+ if (lc($tagname) eq 'allow') {
+ &add_filetype($allfiles,$attr->{'src'},'src');
+ }
+ if (lc($tagname) eq 'img') {
+ &add_filetype($allfiles,$attr->{'src'},'src');
+ }
+ if (lc($tagname) eq 'script') {
+ if ($attr->{'archive'} =~ /\.jar$/i) {
+ &add_filetype($allfiles,$attr->{'archive'},'archive');
} else {
- @{$$allfiles{$$javafiles{'codebase'}.$$javafiles{$item}}} = (&escape($item));
- $$codebase{$$javafiles{'codebase'}.$$javafiles{$item}} = $$javafiles{'codebase'};
-
+ &add_filetype($allfiles,$attr->{'src'},'src');
}
}
- }
+ if (lc($tagname) eq 'link') {
+ if (lc($attr->{'rel'}) eq 'stylesheet') {
+ &add_filetype($allfiles,$attr->{'href'},'href');
+ }
+ }
+ if (lc($tagname) eq 'object' ||
+ (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')) {
+ foreach my $item (keys(%javafiles)) {
+ $javafiles{$item} = '';
+ }
+ }
+ if (lc($state[-2]) eq 'object' && lc($tagname) eq 'param') {
+ my $name = lc($attr->{'name'});
+ foreach my $item (keys(%javafiles)) {
+ if ($name eq $item) {
+ $javafiles{$item} = $attr->{'value'};
+ last;
+ }
+ }
+ foreach my $item (keys(%mediafiles)) {
+ if ($name eq $item) {
+ &add_filetype($allfiles, $attr->{'value'}, 'value');
+ last;
+ }
+ }
+ }
+ if (lc($tagname) eq 'embed' || lc($tagname) eq 'applet') {
+ foreach my $item (keys(%javafiles)) {
+ if ($attr->{$item}) {
+ $javafiles{$item} = $attr->{$item};
+ last;
+ }
+ }
+ foreach my $item (keys(%mediafiles)) {
+ if ($attr->{$item}) {
+ &add_filetype($allfiles,$attr->{$item},$item);
+ last;
+ }
+ }
+ }
+ } elsif ($t->[0] eq 'E') {
+ my ($tagname) = ($t->[1]);
+ if ($javafiles{'codebase'} ne '') {
+ $javafiles{'codebase'} .= '/';
+ }
+ if (lc($tagname) eq 'applet' ||
+ lc($tagname) eq 'object' ||
+ (lc($tagname) eq 'embed' && lc($state[-2]) ne 'object')
+ ) {
+ foreach my $item (keys(%javafiles)) {
+ if ($item ne 'codebase' && $javafiles{$item} ne '') {
+ my $file=$javafiles{'codebase'}.$javafiles{$item};
+ &add_filetype($allfiles,$file,$item);
+ }
+ }
+ }
+ pop @state;
+ }
+ }
+ return 'ok';
+}
+
+sub add_filetype {
+ my ($allfiles,$file,$type)=@_;
+ if (exists($allfiles->{$file})) {
+ unless (grep/^\Q$type\E$/, @{$allfiles->{$file}}) {
+ push(@{$allfiles->{$file}}, &escape($type));
+ }
+ } else {
+ @{$allfiles->{$file}} = (&escape($type));
}
}
@@ -2914,7 +2901,7 @@ sub allowed {
# Free bre access to user's own portfolio contents
my ($space,$domain,$name,$dir)=split('/',$uri);
- if (($space=~/^(uploaded|ediupload)$/) && ($env{'user.name'} eq $name) &&
+ if (($space=~/^(uploaded|editupload)$/) && ($env{'user.name'} eq $name) &&
($env{'user.domain'} eq $domain) && ('portfolio' eq $dir)) {
return 'F';
}
@@ -3001,7 +2988,16 @@ sub allowed {
# If this is generating or modifying users, exit with special codes
- if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:\Q$priv\E\:/) {
+ if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:caa:'=~/\:\Q$priv\E\:/) {
+ if (($priv eq 'cca') || ($priv eq 'caa')) {
+ my ($audom,$auname)=split('/',$uri);
+# no author name given, so this just checks on the general right to make a co-author in this domain
+ unless ($auname) { return $thisallowed; }
+# an author name is given, so we are about to actually make a co-author for a certain account
+ if (($auname ne $env{'user.name'} && $env{'request.role'} !~ /^dc\./) ||
+ (($audom ne $env{'user.domain'} && $env{'request.role'} !~ /^dc\./) &&
+ ($audom ne $env{'request.role.domain'}))) { return ''; }
+ }
return $thisallowed;
}
#
@@ -3875,7 +3871,7 @@ sub createcourse {
</map>
ENDINITMAP
$topurl=&declutter(
- &finishuserfileupload($uname,$udom,$uhome,'initmap','default.sequence')
+ &finishuserfileupload($uname,$udom,'initmap','default.sequence')
);
}
# ----------------------------------------------------------- Write preferences
@@ -4078,28 +4074,25 @@ sub unmark_as_readonly {
my ($tmp)=keys(%current_permissions);
if ($tmp=~/^error:/) { undef(%current_permissions); }
my @readonly_files = &get_marked_as_readonly($domain,$user,$what);
- foreach my $file(@readonly_files){
- my $current_locks = $current_permissions{$file};
+ foreach my $file (@readonly_files) {
+ if (defined($file_name) && ($file_name ne $file)) { next; }
+ my $current_locks = $current_permissions{$file};
my @new_locks;
my @del_keys;
if (ref($current_locks) eq "ARRAY"){
foreach my $locker (@{$current_locks}) {
my $compare=$locker;
if (ref($locker)) { $compare=join('',@{$locker}) };
- if ($compare eq $symb_crs) {
- if (defined($file_name) && ($file_name ne $file)) {
- push(@new_locks, $what);
- }
- } else {
- push(@new_locks, $what);
+ if ($compare ne $symb_crs) {
+ push(@new_locks, $locker);
}
}
- if (@new_locks > 0) {
+ if (scalar(@new_locks) > 0) {
$current_permissions{$file} = \@new_locks;
} else {
push(@del_keys, $file);
&del('file_permissions',\@del_keys, $domain, $user);
- delete $current_permissions{$file};
+ delete($current_permissions{$file});
}
}
}
@@ -4909,7 +4902,7 @@ sub metadata_generate_part0 {
'.type'};
my $olddis=$$metacache{':parameter_'.$allnames{$name}.'_'.$name.
'.display'};
- my $expr='\\[Part: '.$allnames{$name}.'\\]';
+ my $expr='[Part: '.$allnames{$name}.']';
$olddis=~s/\Q$expr\E/\[Part: 0\]/;
$$metacache{"$key.display"}=$olddis;
}
@@ -5014,7 +5007,7 @@ sub symbverify {
if ($ids) {
# ------------------------------------------------------------------- Has ID(s)
foreach (split(/\,/,$ids)) {
- my ($mapid,$resid)=split(/\./,$_);
+ my ($mapid,$resid)=split(/\./,$_);
if (
&symbclean(&declutter($bighash{'map_id_'.$mapid}).'___'.$resid.'___'.$thisfn)
eq $symb) {
@@ -5648,6 +5641,9 @@ sub filelocation {
if ($file=~m:^/~:) { # is a contruction space reference
$location = $file;
$location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
+ } elsif ($file=~m:^/home/[^/]*/public_html/:) {
+ # is a correct contruction space reference
+ $location = $file;
} elsif ($file=~/^\/*(uploaded|editupload)/) { # is an uploaded file
my ($udom,$uname,$filename)=
($file=~m -^/+(?:uploaded|editupload)/+([^/]+)/+([^/]+)/+(.*)$-);
@@ -6798,7 +6794,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