--- loncom/lonnet/perl/lonnet.pm	2005/06/11 13:38:47	1.637
+++ loncom/lonnet/perl/lonnet.pm	2005/08/31 08:25:16	1.651
@@ -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.651 2005/08/31 08:25:16 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});
             }
         }
     }
@@ -4427,8 +4420,10 @@ sub EXT {
     if ($realm eq 'user') {
 # --------------------------------------------------------------- user.resource
 	if ($space eq 'resource') {
-	    if (defined($Apache::lonhomework::parsing_a_problem) ||
-		defined($Apache::lonhomework::parsing_a_task)) {
+	    if ( (defined($Apache::lonhomework::parsing_a_problem)
+		  || defined($Apache::lonhomework::parsing_a_task))
+		 &&
+		 ($symbparm eq &symbread()) ) {
 		return $Apache::lonhomework::history{$qualifierrest};
 	    } else {
 		my %restored;
@@ -4909,7 +4904,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 +5009,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 +5643,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 +6796,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