--- loncom/lonnet/perl/lonnet.pm 2005/04/15 20:46:04 1.623 +++ 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.623 2005/04/15 20:46:04 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); @@ -827,8 +828,11 @@ sub getsection { } sub save_cache { + my ($r)=@_; + if (! $r->is_initial_req()) { return DECLINED; } &purge_remembered(); undef(%env); + return OK; } my $to_remember=-1; @@ -1129,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) # @@ -1152,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 @@ -1166,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'; @@ -1190,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') { @@ -1208,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 @@ -1230,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); @@ -1263,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); @@ -1300,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); @@ -1314,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); @@ -2561,10 +2735,16 @@ sub convert_dump_to_currentdump{ return \%returnhash; } +# ------------------------------------------------------ critical inc interface + +sub cinc { + return &inc(@_,'critical'); +} + # --------------------------------------------------------------- inc interface sub inc { - my ($namespace,$store,$udomain,$uname) = @_; + my ($namespace,$store,$udomain,$uname,$critical) = @_; if (!$udomain) { $udomain=$env{'user.domain'}; } if (!$uname) { $uname=$env{'user.name'}; } my $uhome=&homeserver($uname,$udomain); @@ -2582,7 +2762,11 @@ sub inc { } } $items=~s/\&$//; - return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); + if ($critical) { + return &critical("inc:$udomain:$uname:$namespace:$items",$uhome); + } else { + return &reply("inc:$udomain:$uname:$namespace:$items",$uhome); + } } # --------------------------------------------------------------- put interface @@ -2600,8 +2784,23 @@ sub put { return &reply("put:$udomain:$uname:$namespace:$items",$uhome); } -# ---------------------------------------------------------- putstore interface - +# ------------------------------------------------------------ newput interface + +sub newput { + my ($namespace,$storehash,$udomain,$uname)=@_; + if (!$udomain) { $udomain=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $uhome=&homeserver($uname,$udomain); + my $items=''; + foreach my $key (keys(%$storehash)) { + $items.=&escape($key).'='.&freeze_escape($$storehash{$key}).'&'; + } + $items=~s/\&$//; + return &reply("newput:$udomain:$uname:$namespace:$items",$uhome); +} + +# --------------------------------------------------------- putstore interface + sub putstore { my ($namespace,$storehash,$udomain,$uname)=@_; if (!$udomain) { $udomain=$env{'user.domain'}; } @@ -3743,7 +3942,6 @@ sub mark_as_readonly { my %current_permissions = &dump('file_permissions',$domain,$user); my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } - foreach my $file (@{$files}) { push(@{$current_permissions{$file}},$what); } @@ -3822,17 +4020,21 @@ sub files_not_in_path { #--------------------------------------------------------------Get Marked as Read Only + sub get_marked_as_readonly { my ($domain,$user,$what) = @_; my %current_permissions = &dump('file_permissions',$domain,$user); my ($tmp)=keys(%current_permissions); if ($tmp=~/^error:/) { undef(%current_permissions); } - my @readonly_files; + my $cmp1=$what; + if (ref($what)) { $cmp1=join('',@{$what}) }; while (my ($file_name,$value) = each(%current_permissions)) { if (ref($value) eq "ARRAY"){ foreach my $stored_what (@{$value}) { - if ($stored_what eq $what) { + my $cmp2=$stored_what; + if (ref($stored_what)) { $cmp2=join('',@{$stored_what}) }; + if ($cmp1 eq $cmp2) { push(@readonly_files, $file_name); } elsif (!defined($what)) { push(@readonly_files, $file_name); @@ -3867,13 +4069,14 @@ sub get_marked_as_readonly_hash { # ------------------------------------------------------------ Unmark as Read Only sub unmark_as_readonly { - # unmarks all files locked by $what - # for portfolio submissions, $what contains $crsid and $symb - my ($domain,$user,$what) = @_; + # 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 = $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); } - my @readonly_files = &get_marked_as_readonly($domain,$user,$what); foreach my $file(@readonly_files){ my $current_locks = $current_permissions{$file}; @@ -3881,7 +4084,13 @@ sub unmark_as_readonly { my @del_keys; if (ref($current_locks) eq "ARRAY"){ foreach my $locker (@{$current_locks}) { - unless ($locker eq $what) { + 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); } } @@ -4085,13 +4294,14 @@ sub devalidatecourseresdata { # --------------------------------------------------- Course Resourcedata Query -sub courseresdata { - my ($coursenum,$coursedomain,@which)=@_; +sub get_courseresdata { + my ($coursenum,$coursedomain)=@_; my $coursehom=&homeserver($coursenum,$coursedomain); my $hashid=$coursenum.':'.$coursedomain; my ($result,$cached)=&is_cached_new('courseres',$hashid); + my %dumpreply; unless (defined($cached)) { - my %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); + %dumpreply=&dump('resourcedata',$coursedomain,$coursenum); $result=\%dumpreply; my ($tmp) = keys(%dumpreply); if ($tmp !~ /^(con_lost|error|no_such_host)/i) { @@ -4103,6 +4313,54 @@ sub courseresdata { &do_cache_new('courseres',$hashid,$result,600); } } + 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 + if (&EXT_cache_status($udom,$uname)) { return undef; } + + my $hashid="$udom:$uname"; + my ($result,$cached)=&is_cached_new('userres',$hashid); + if (!defined($cached)) { + my %resourcedata=&dump('resourcedata',$udom,$uname); + $result=\%resourcedata; + &do_cache_new('userres',$hashid,$result,600); + } + my ($tmp)=keys(%$result); + if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { + return $result; + } + #error 2 occurs when the .db doesn't exist + if ($tmp!~/error: 2 /) { + &logthis("WARNING:". + " Trying to get resource data for ". + $uname." at ".$udom.": ". + $tmp.""); + } elsif ($tmp=~/error: 2 /) { + #&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; +} + +sub resdata { + my ($name,$domain,$type,@which)=@_; + my $result; + if ($type eq 'course') { + $result=&get_courseresdata($name,$domain); + } elsif ($type eq 'user') { + $result=&get_userresdata($name,$domain); + } + if (!ref($result)) { return $result; } foreach my $item (@which) { if (defined($result->{$item})) { return $result->{$item}; @@ -4133,7 +4391,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 @@ -4288,44 +4546,20 @@ sub EXT { $courselevelm=$courseid.'.'.$mapparm; # ----------------------------------------------------------- first, check user - #most student don\'t have any data set, check if there is some data - if (! &EXT_cache_status($udom,$uname)) { - my $hashid="$udom:$uname"; - my ($result,$cached)=&is_cached_new('userres',$hashid); - if (!defined($cached)) { - my %resourcedata=&dump('resourcedata',$udom,$uname); - $result=\%resourcedata; - &do_cache_new('userres',$hashid,$result,600); - } - my ($tmp)=keys(%$result); - if (($tmp!~/^error\:/) && ($tmp!~/^con_lost/)) { - if ($$result{$courselevelr}) { - return $$result{$courselevelr}; } - if ($$result{$courselevelm}) { - return $$result{$courselevelm}; } - if ($$result{$courselevel}) { - return $$result{$courselevel}; } - } else { - #error 2 occurs when the .db doesn't exist - if ($tmp!~/error: 2 /) { - &logthis("WARNING:". - " Trying to get resource data for ". - $uname." at ".$udom.": ". - $tmp.""); - } elsif ($tmp=~/error: 2 /) { - &EXT_cache_set($udom,$uname); - } elsif ($tmp =~ /^(con_lost|no_such_host)/) { - return $tmp; - } - } - } + + my $userreply=&resdata($uname,$udom,'user', + ($courselevelr,$courselevelm, + $courselevel)); + + if (defined($userreply)) { return $userreply; } # ------------------------------------------------ second, check some of course - my $coursereply=&courseresdata($env{'course.'.$courseid.'.num'}, - $env{'course.'.$courseid.'.domain'}, - ($seclevelr,$seclevelm,$seclevel, - $courselevelr)); + my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course', + ($seclevelr,$seclevelm,$seclevel, + $courselevelr)); if (defined($coursereply)) { return $coursereply; } # ------------------------------------------------------ third, check map parms @@ -4357,9 +4591,10 @@ sub EXT { # ---------------------------------------------- fourth, look in rest pf course if ($symbparm && defined($courseid) && $courseid eq $env{'request.course.id'}) { - my $coursereply=&courseresdata($env{'course.'.$courseid.'.num'}, - $env{'course.'.$courseid.'.domain'}, - ($courselevelm,$courselevel)); + my $coursereply=&resdata($env{'course.'.$courseid.'.num'}, + $env{'course.'.$courseid.'.domain'}, + 'course', + ($courselevelm,$courselevel)); if (defined($coursereply)) { return $coursereply; } } # ------------------------------------------------------------------ Cascade up @@ -4587,7 +4822,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, @@ -4919,7 +5153,8 @@ sub symbread { if ($#possibilities==0) { # ----------------------------------------------- There is only one possibility my ($mapid,$resid)=split(/\./,$ids); - $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid; + $syval=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$thisfn); } elsif (!$donotrecurse) { # ------------------------------------------ There is more than one possibility my $realpossible=0; @@ -4929,8 +5164,8 @@ sub symbread { my ($mapid,$resid)=split(/\./,$_); if ($bighash{'map_type_'.$mapid} ne 'page') { $realpossible++; - $syval=declutter($bighash{'map_id_'.$mapid}). - '___'.$resid; + $syval=&encode_symb($bighash{'map_id_'.$mapid}, + $resid,$thisfn); } } } @@ -4944,7 +5179,6 @@ sub symbread { } if ($syval) { return $env{$cache_str}=$syval; - #return $env{$cache_str}=&symbclean($syval.'___'.$thisfn); } } &appenv('request.ambiguous' => $thisfn); @@ -6139,13 +6373,17 @@ revokecustomrole($udom,$uname,$url,$role =item * -coursedescription($courseid) : course description +coursedescription($courseid) : returns a hash of information about the +specified course id, including all environment settings for the +course, the description of the course will be in the hash under the +key 'description' =item * -courseresdata($coursenum,$coursedomain,@which) : request for current -parameter setting for a specific course, @what should be a list of -parameters to ask about. This routine caches answers for 5 minutes. +resdata($name,$domain,$type,@which) : request for current parameter +setting for a specific $type, where $type is either 'course' or 'user', +@what should be a list of parameters to ask about. This routine caches +answers for 5 minutes. =back