--- loncom/publisher/lonpublisher.pm 2008/08/01 18:09:38 1.243 +++ loncom/publisher/lonpublisher.pm 2014/08/03 13:52:59 1.292 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Publication Handler # -# $Id: lonpublisher.pm,v 1.243 2008/08/01 18:09:38 bisitz Exp $ +# $Id: lonpublisher.pm,v 1.292 2014/08/03 13:52:59 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -66,10 +66,10 @@ invocation by F: =head1 OVERVIEW -Authors can only write-access the C space. They can -copy resources into the resource area through the publication step, -and move them back through a recover step. Authors do not have direct -write-access to their resource space. +Authors can only write-access the C space. +They can copy resources into the resource area through the +publication step, and move them back through a recover step. +Authors do not have direct write-access to their resource space. During the publication step, several events will be triggered. Metadata is gathered, where a wizard manages default @@ -102,8 +102,6 @@ to publication space. Many of the undocumented subroutines implement various magical parsing shortcuts. -=over 4 - =cut ###################################################################### @@ -118,8 +116,9 @@ use Apache::File; use File::Copy; use Apache::Constants qw(:common :http :methods); use HTML::LCParser; +use HTML::Entities; +use Encode::Encoder; use Apache::lonxml; -use Apache::loncacc; use DBI; use Apache::lonnet; use Apache::loncommon(); @@ -148,6 +147,8 @@ my $lock; =pod +=over 4 + =item B Evaluates a string that contains metadata. This subroutine @@ -264,8 +265,9 @@ sub metaread { my ($logfile,$fn,$prefix)=@_; unless (-e $fn) { print($logfile 'No file '.$fn."\n"); - return '
'.&mt('No file').': '. - &Apache::loncfile::display($fn).''; + return '

' + .&mt('No file: [_1]',&Apache::loncfile::display($fn)) + .'

'; } print($logfile 'Processing '.$fn."\n"); my $metastring; @@ -274,8 +276,9 @@ sub metaread { $metastring=join('',<$metafh>); } &metaeval($metastring,$prefix); - return '
'.&mt('Processed file').': '. - &Apache::loncfile::display($fn).'
'; + return '

' + .&mt('Processed file: [_1]',&Apache::loncfile::display($fn)) + .'

'; } ######################################### @@ -380,11 +383,11 @@ sub selectbox { my $selout="\n".&Apache::lonhtmlcommon::row_title($title) .''.&Apache::lonhtmlcommon::row_closure(); return $selout; @@ -465,7 +468,7 @@ Currently undocumented ######################################### ######################################### sub set_allow { - my ($allow,$logfile,$target,$tag,$oldurl)=@_; + my ($allow,$logfile,$target,$tag,$oldurl,$type)=@_; my $newurl=&urlfixup($oldurl,$target); my $return_url=$oldurl; print $logfile 'GUYURL: '.$tag.':'.$oldurl.' - '.$newurl."\n"; @@ -477,6 +480,11 @@ sub set_allow { ($newurl !~ /^mailto:/i) && ($newurl !~ /^(?:http|https|ftp):/i) && ($newurl !~ /^\#/)) { + if (($type eq 'src') || ($type eq 'href')) { + if ($newurl =~ /^([^?]+)\?[^?]*$/) { + $newurl = $1; + } + } $$allow{&absoluteurl($newurl,$target)}=1; } return $return_url; @@ -691,6 +699,7 @@ sub fix_ids_and_indices { $responsecounter=0; } if ($lctag=~/response$/) { $responsecounter++; } + if ($lctag eq 'import') { $responsecounter++; } my %parms=%{$token->[2]}; $counter=$addid{$tag}; if (!$counter) { $counter=$addid{$lctag}; } @@ -717,9 +726,11 @@ sub fix_ids_and_indices { foreach my $type ('src','href','background','bgimg') { foreach my $key (keys(%parms)) { if ($key =~ /^$type$/i) { + next if (($lctag eq 'img') && ($type eq 'src') && + ($parms{$key} =~ m{^data\:image/gif;base64,})); $parms{$key}=&set_allow(\%allow,$logfile, $target,$tag, - $parms{$key}); + $parms{$key},$type); } } } @@ -786,10 +797,69 @@ sub fix_ids_and_indices { } if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; } $outstring.='<'.$tag.$newparmstring.$endtag.'>'; - if ($lctag eq 'm' || $lctag eq 'script' || $lctag eq 'answer' - || $lctag eq 'display' || $lctag eq 'tex') { + if ($lctag eq 'm' || $lctag eq 'answer' || $lctag eq 'display' || + $lctag eq 'tex') { $outstring.=&get_all_text_unbalanced('/'.$lctag,\@parser); - } + } elsif ($lctag eq 'script') { + if ($parms{'type'} eq 'loncapa/perl') { + $outstring.=&get_all_text_unbalanced('/'.$lctag,\@parser); + } else { + my $script = &get_all_text_unbalanced('/'.$lctag,\@parser); + if ($script =~ m{\.set\w+(Src|Swf)\(["']}i) { + my @srcs = split(/\.set/i,$script); + if (scalar(@srcs) > 1) { + foreach my $item (@srcs) { + if ($item =~ m{^(FlashPlayerSwf|MediaSrc|XMPSrc|ConfigurationSrc|PosterImageSrc)\((['"])(?:(?!\2).)+\2\)}is) { + my $srctype = $1; + my $quote = $2; + my ($url) = ($item =~ m{^\Q$srctype($quote\E([^$quote]+)\Q$quote)\E}); + $url = &urlfixup($url); + unless ($url=~m{^(?:http|https|ftp)://}) { + $allow{&absoluteurl($url,$target)}=1; + if ($srctype eq 'ConfigurationSrc') { + if ($url =~ m{^(.+/)configuration_express\.xml$}) { +# +# Camtasia 8.1: express_show/spritesheet.png needed, and included in zip archive. +# Not referenced directly in
.html or
_player.html files, +# so add this file to %allow (where
is name user gave to file/archive). +# + my $spritesheet = $1.'express_show/spritesheet.png'; + $allow{&absoluteurl($spritesheet,$target)}=1; + } + } elsif ($srctype eq 'PosterImageSrc') { + if ($url =~ m{^(.+)_First_Frame\.png$}) { + my $prefix = $1; +# +# Camtasia 8.1:
_Thumbnails.png needed, and included in zip archive. +# Not referenced directly in
.html or
_player.html files, +# so add this file to %allow (where
is name user gave to file/archive). +# + my $thumbnail = $prefix.'_Thumbnails.png'; + $allow{&absoluteurl($thumbnail,$target)}=1; + } + } + } + } + } + } + } + if ($script =~ /\(document,\s*(['"])script\1,\s*\[([^\]]+)\]\);/s) { + my $scriptslist = $2; + my @srcs = split(/\s*,\s*/,$scriptslist); + foreach my $src (@srcs) { + if ($src =~ /(["'])(?:(?!\1).)+\.js\1/) { + my $quote = $1; + my ($url) = ($src =~ m/\Q$quote\E([^$quote]+)\Q$quote\E/); + $url = &urlfixup($url); + unless ($url=~m{^(?:http|https|ftp)://}) { + $allow{&absoluteurl($url,$target)}=1; + } + } + } + } + $outstring .= $script; + } + } } elsif ($token->[0] eq 'E') { if ($token->[2]) { unless ($token->[1] eq 'allow') { @@ -843,15 +913,17 @@ sub store_metadata { # Determine if the table exists my $status = &Apache::lonmysql::check_table('metadata'); if (! defined($status)) { - $error='WARNING: Cannot connect to '. - 'database!'; + $error='' + .&mt('WARNING: Cannot connect to database!') + .''; &Apache::lonnet::logthis($error); return ($error,undef); } if ($status == 0) { # It would be nice to actually create the table.... - $error ='WARNING: The metadata table does not '. - 'exist in the LON-CAPA database.'; + $error ='' + .&mt('WARNING: The metadata table does not exist in the LON-CAPA database!') + .''; &Apache::lonnet::logthis($error); return ($error,undef); } @@ -866,8 +938,9 @@ sub store_metadata { \%metadata); } if (defined($status) && $status ne '') { - $error='Error occured saving new values in '. - 'metadata table in LON-CAPA database'; + $error='' + .&mt('Error occurred saving new values in metadata table in LON-CAPA database!') + .''; &Apache::lonnet::logthis($error); &Apache::lonnet::logthis($status); return ($error,undef); @@ -940,7 +1013,7 @@ backup copies, performs any automatic pr especially for rat and ssi files), Returns a 2 element array, the first is the string to be shown to the -user, the second is an error code, either 1 (an error occured) or 0 +user, the second is an error code, either 1 (an error occurred) or 0 (no error occurred) I @@ -983,32 +1056,37 @@ sub publish { if ($error) { return ($outstring,$error); } # ------------------------------------------------------------ Construct Allows - $scrout.='

'.&mt('Dependencies').'

'; + my $outdep=''; # Collect dependencies output data my $allowstr=''; foreach my $thisdep (sort(keys(%allow))) { if ($thisdep !~ /[^\s]/) { next; } if ($thisdep =~/\$/) { - $scrout.='
' + $outdep.='
' .&mt('The resource depends on another resource with variable filename, i.e., [_1].',''.$thisdep.'').'
' .&mt('You likely need to explicitly allow access to all possible dependencies using the [_1]-tag.','<allow>') - .'
'; + ."
\n"; } unless ($style eq 'rat') { $allowstr.="\n".''; } - $scrout.='
'; + $outdep.='
'; if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) { - $scrout.=''; + $outdep.=''; } - $scrout.=''.$thisdep.''; + $outdep.=''.$thisdep.''; if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) { - $scrout.=''; + $outdep.=''; if ( &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'. $thisdep.'.meta') eq '-1') { - $scrout.= ' - '.&mt('Currently not available'). + $outdep.= ' - '.&mt('Currently not available'). ''; } else { +# +# Store the fact that the dependency has been used by the target file +# Unfortunately, usage is erroneously named sequsage in lonmeta.pm +# The translation happens in lonmetadata.pm +# my %temphash=(&Apache::lonnet::declutter($target).'___'. &Apache::lonnet::declutter($thisdep).'___usage' => time); @@ -1019,6 +1097,12 @@ sub publish { } } } + $outdep.='

'; + } + + if ($outdep) { + $scrout.='

'.&mt('Dependencies').'

' + .$outdep } $outstring=~s/\n*(\<\/[^\>]+\>[^<]*)$/$allowstr\n$1\n/s; @@ -1048,7 +1132,7 @@ sub publish { my %oldparmstores=(); unless ($batch) { - $scrout.='

'.&mt('Metadata Information').' ' . + $scrout.='

'.&mt('Metadata').' ' . &Apache::loncommon::help_open_topic("Metadata_Description") . '

'; } @@ -1066,16 +1150,16 @@ sub publish { # ------------------------------------------------ Check out directory hierachy my $thisdisfn=$source; - $thisdisfn=~s/^\/home\/\Q$cuname\E\///; - my @urlparts=split(/\//,$thisdisfn); + $thisdisfn=~s/^\Q$docroot\E\/priv\/\Q$cudom\E\/\Q$cuname\E\///; + my @urlparts=('.',split(/\//,$thisdisfn)); $#urlparts--; - my $currentpath='/home/'.$cuname.'/'; + my $currentpath=$docroot.'/priv/'.$cudom.'/'.$cuname.'/'; my $prefix='../'x($#urlparts); - foreach (@urlparts) { - $currentpath.=$_.'/'; + foreach my $subdir (@urlparts) { + $currentpath.=$subdir.'/'; $scrout.=&metaread($logfile,$currentpath.'default.meta',$prefix); $prefix=~s|^\.\./||; } @@ -1107,7 +1191,7 @@ sub publish { # ------------------------------------------------------------- Save some stuff my %savemeta=(); foreach ('title') { - $savemeta{$_}=$metadatafields{$_}; + if ($metadatafields{$_}) { $savemeta{$_}=$metadatafields{$_}; } } # ------------------------------------------ See if anything new in file itself @@ -1152,15 +1236,16 @@ sub publish { } } if ($chparms) { - $scrout.='

'.&mt('Obsolete parameters or saved values').': '. - $chparms.'

'.&mt('Warning!'). - '

'. - &mt('If this resource is in active use, student performance data from the previous version may become inaccessible.').'

'; + $scrout.='

'.&mt('Obsolete parameters or saved values').': ' + .$chparms.'

' + .'

'.&mt('Warning!').'
' + .&mt('If this resource is in active use, student performance data from the previous version may become inaccessible.') + .'

'; } if ($metadatafields{'copyright'} eq 'priv') { - $scrout.='

'.&mt('Warning!'). - '

'. - &mt('Copyright/distribution option "Private" is no longer supported. Select another option from below. Consider "Custom Rights" for maximum control over the usage of your resource.').'

'; + $scrout.='

'.&mt('Warning!').'
' + .&mt('Copyright/distribution option "Private" is no longer supported. Select another option from below. Consider "Custom Rights" for maximum control over the usage of your resource.') + .'

'; } # ------------------------------------------------------- Now have all metadata @@ -1172,17 +1257,22 @@ sub publish { $textonly=~s/\//g; $textonly=~s/\[^\<]+\<\/m\>//g; $textonly=~s/\<[^\>]*\>//g; - $textonly=~tr/A-Z/a-z/; - $textonly=~s/[\$\&][a-z]\w*//g; - $textonly=~s/[^a-z\s]//g; - - foreach ($textonly=~m/(\w+)/g) { - unless ($nokey{$_}) { - $keywords{$_}=1; - } - } - } + #this is a work simplification for german authors for present + $textonly=HTML::Entities::decode($textonly); #decode HTML-character + $textonly=Encode::Encoder::encode('utf8', $textonly); #encode to perl internal unicode + $textonly=~tr/A-ZÜÄÖ/a-züäö/; #add lowercase rule for german "Umlaute" + $textonly=~s/[\$\&][a-z]\w*//g; + $textonly=~s/[^a-z^ü^ä^ö^ß\s]//g; #dont delete german "Umlaute" + + foreach ($textonly=~m/[^\s]+/g) { #match all but whitespaces + unless ($nokey{$_}) { + $keywords{$_}=1; + } + } + + + } foreach my $addkey (split(/[\"\'\,\;]/,$metadatafields{'keywords'})) { $addkey=~s/\s+/ /g; @@ -1203,12 +1293,12 @@ sub publish { my $intr_scrout.='
' .'
'; unless ($env{'form.makeobsolete'}) { - $intr_scrout.='

' + $intr_scrout.='

' .&mt('Searching for your resource will be based on the following metadata. Please provide as much data as possible.') .'

' .'

'; + .'" /> '.&mt('Cancel').'

'; } $intr_scrout.=&Apache::lonhtmlcommon::start_pick_box(); $intr_scrout.= @@ -1242,36 +1332,42 @@ END .'' .'' .'


' - .&Apache::loncommon::start_data_table() - .&Apache::loncommon::start_data_table_row(); - + .&Apache::loncommon::start_data_table(); + my $cols_per_row = 10; my $colcount=0; + my $wordcount=0; + my $numkeywords = scalar(keys(%keywords)); - foreach (sort keys %keywords) { - $colcount++; - $keywordout.='