--- loncom/publisher/lonpublisher.pm 2011/10/30 20:49:33 1.274 +++ loncom/publisher/lonpublisher.pm 2014/12/12 18:27:34 1.294 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Publication Handler # -# $Id: lonpublisher.pm,v 1.274 2011/10/30 20:49:33 raeburn Exp $ +# $Id: lonpublisher.pm,v 1.294 2014/12/12 18:27:34 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -102,8 +102,6 @@ to publication space. Many of the undocumented subroutines implement various magical parsing shortcuts. -=over 4 - =cut ###################################################################### @@ -121,7 +119,6 @@ use HTML::LCParser; use HTML::Entities; use Encode::Encoder; use Apache::lonxml; -use Apache::loncacc; use DBI; use Apache::lonnet; use Apache::loncommon(); @@ -150,6 +147,8 @@ my $lock; =pod +=over 4 + =item B Evaluates a string that contains metadata. This subroutine @@ -201,12 +200,12 @@ sub metaeval { if (defined($token->[2]->{'name'})) { $unikey.="\0".$token->[2]->{'name'}; } - foreach (@{$token->[3]}) { - $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; + foreach my $item (@{$token->[3]}) { + $metadatafields{$unikey.'.'.$item}=$token->[2]->{$item}; if ($metadatakeys{$unikey}) { - $metadatakeys{$unikey}.=','.$_; + $metadatakeys{$unikey}.=','.$item; } else { - $metadatakeys{$unikey}=$_; + $metadatakeys{$unikey}=$item; } } my $newentry=$parser->get_text('/'.$entry); @@ -294,8 +293,8 @@ sub coursedependencies { my %evaldata=&Apache::lonnet::dump('nohist_resevaldata',$adomain, $aauthor,$regexp); my %courses=(); - foreach (keys %evaldata) { - if ($_=~/^([a-zA-Z0-9]+_[a-zA-Z0-9]+)___.+___course$/) { + foreach my $item (keys(%evaldata)) { + if ($item=~/^([a-zA-Z0-9]+_[a-zA-Z0-9]+)___.+___course$/) { $courses{$1}=1; } } @@ -383,12 +382,12 @@ sub selectbox { } my $selout="\n".&Apache::lonhtmlcommon::row_title($title) .''.&Apache::lonhtmlcommon::row_closure(); return $selout; @@ -469,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"; @@ -481,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; @@ -722,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); } } } @@ -781,20 +787,105 @@ sub fix_ids_and_indices { } my $newparmstring=''; my $endtag=''; - foreach (keys %parms) { - if ($_ eq '/') { + foreach my $parkey (keys(%parms)) { + if ($parkey eq '/') { $endtag=' /'; } else { - my $quote=($parms{$_}=~/\"/?"'":'"'); - $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote; + my $quote=($parms{$parkey}=~/\"/?"'":'"'); + $newparmstring.=' '.$parkey.'='.$quote.$parms{$parkey}.$quote; } } 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; + +# +# Camtasia 8.4: skins/express_show/spritesheet.min.css 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 $spritecss = $1.'express_show/spritesheet.min.css'; + $allow{&absoluteurl($spritecss,$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 =~ m{\.addMediaSrc\((["'])((?!\1).+)\1\);}) { + my $src = $2; + if ($src) { + my $url = &urlfixup($src); + unless ($url=~m{^(?:http|https|ftp)://}) { + $allow{&absoluteurl($url,$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; + } + } + } + } + if ($script =~ m{loadScript\(\s*(['"])((?:(?!\1).)+\.js)\1,\s*function}is) { + my $src = $2; + if ($src) { + my $url = &urlfixup($src); + 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') { @@ -1017,6 +1108,11 @@ sub publish { $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); @@ -1101,9 +1197,9 @@ sub publish { # ------------------- Clear out parameters and stores (there should not be any) - foreach (keys %metadatafields) { - if (($_=~/^parameter/) || ($_=~/^stores/)) { - delete $metadatafields{$_}; + foreach my $field (keys(%metadatafields)) { + if (($field=~/^parameter/) || ($field=~/^stores/)) { + delete $metadatafields{$field}; } } @@ -1112,23 +1208,21 @@ sub publish { $scrout.=&metaread($logfile,$source.'.meta'); - foreach (keys %metadatafields) { - if (($_=~/^parameter/) || ($_=~/^stores/)) { - $oldparmstores{$_}=1; - delete $metadatafields{$_}; + foreach my $field (keys(%metadatafields)) { + if (($field=~/^parameter/) || ($field=~/^stores/)) { + $oldparmstores{$field}=1; + delete $metadatafields{$field}; } } # ------------------------------------------------------------- Save some stuff my %savemeta=(); - foreach ('title') { - if ($metadatafields{$_}) { $savemeta{$_}=$metadatafields{$_}; } - } + if ($metadatafields{'title'}) { $savemeta{'title'}=$metadatafields{'title'}; } # ------------------------------------------ See if anything new in file itself $allmeta=&parseformeta($source,$style); # ----------------------------------------------------------- Restore the stuff - foreach (keys %savemeta) { - $metadatafields{$_}=$savemeta{$_}; + foreach my $item (keys(%savemeta)) { + $metadatafields{$item}=$savemeta{$item}; } } @@ -1136,11 +1230,11 @@ sub publish { # ---------------- Find and document discrepancies in the parameters and stores my $chparms=''; - foreach (sort keys %metadatafields) { - if (($_=~/^parameter/) || ($_=~/^stores/)) { - unless ($_=~/\.\w+$/) { - unless ($oldparmstores{$_}) { - my $disp_key = $_; + foreach my $field (sort(keys(%metadatafields))) { + if (($field=~/^parameter/) || ($field=~/^stores/)) { + unless ($field=~/\.\w+$/) { + unless ($oldparmstores{$field}) { + my $disp_key = $field; $disp_key =~ tr/\0/_/; print $logfile ('New: '.$disp_key."\n"); $chparms .= $disp_key.' '; @@ -1154,11 +1248,11 @@ sub publish { } $chparms=''; - foreach (sort keys %oldparmstores) { - if (($_=~/^parameter/) || ($_=~/^stores/)) { - unless (($metadatafields{$_.'.name'}) || - ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { - my $disp_key = $_; + foreach my $olditem (sort(keys(%oldparmstores))) { + if (($olditem=~/^parameter/) || ($olditem=~/^stores/)) { + unless (($metadatafields{$olditem.'.name'}) || + ($metadatafields{$olditem.'.package'}) || ($olditem=~/\.\w+$/)) { + my $disp_key = $olditem; $disp_key =~ tr/\0/_/; print $logfile ('Obsolete: '.$disp_key."\n"); $chparms.=$disp_key.' '; @@ -1235,7 +1329,7 @@ sub publish { &hiddenfield('phase','two'). &hiddenfield('filename',$env{'form.filename'}). &hiddenfield('allmeta',&escape($allmeta)). - &hiddenfield('dependencies',join(',',keys %allow)); + &hiddenfield('dependencies',join(',',keys(%allow))); unless ($env{'form.makeobsolete'}) { $intr_scrout.= &textfield('Title','title',$metadatafields{'title'}). @@ -1480,6 +1574,8 @@ Returns: 0: fail 1: success +=back + =cut #'stupid emacs @@ -1594,17 +1690,17 @@ sub phasetwo { ''); return 0; } - foreach (sort keys %metadatafields) { - unless ($_=~/\./) { - my $unikey=$_; + foreach my $field (sort(keys(%metadatafields))) { + unless ($field=~/\./) { + my $unikey=$field; $unikey=~/^([A-Za-z]+)/; my $tag=$1; $tag=~tr/A-Z/a-z/; print $mfh "\n\<$tag"; - foreach (split(/\,/,$metadatakeys{$unikey})) { - my $value=$metadatafields{$unikey.'.'.$_}; + foreach my $item (split(/\,/,$metadatakeys{$unikey})) { + my $value=$metadatafields{$unikey.'.'.$item}; $value=~s/\"/\'\'/g; - print $mfh ' '.$_.'="'.$value.'"'; + print $mfh ' '.$item.'="'.$value.'"'; } print $mfh '>'. &HTML::Entities::encode($metadatafields{$unikey},'<>&"') @@ -1770,21 +1866,17 @@ sub phasetwo { my $thissrcdir=$thissrc; $thissrcdir=~s/\/[^\/]+$/\//; - $r->print(&Apache::loncommon::head_subbox( - &Apache::lonhtmlcommon::start_funclist(). - &Apache::lonhtmlcommon::add_item_funclist( + $r->print( + &Apache::lonhtmlcommon::actionbox([ ''. &mt('View Published Version'). - ''). - &Apache::lonhtmlcommon::add_item_funclist( + '', ''. &mt('Back to Source'). - ''). - &Apache::lonhtmlcommon::add_item_funclist( + '', ''. &mt('Back to Source Directory'). - ''). - &Apache::lonhtmlcommon::end_funclist()) + '']) ); } return 1; @@ -1814,9 +1906,9 @@ sub notify { # --------------------------------------------------- Notify subscribed courses my %courses=&coursedependencies($target); my $now=time; - foreach (keys %courses) { - print $logfile "\nNotifying course ".$_.':'; - my ($cdom,$cname)=split(/\_/,$_); + foreach my $course (keys(%courses)) { + print $logfile "\nNotifying course ".$course.':'; + my ($cdom,$cname)=split(/\_/,$course); my $reply=&Apache::lonnet::cput ('versionupdate',{$target => $now},$cdom,$cname); print $logfile $reply; @@ -1880,8 +1972,9 @@ sub publishdirectory { $thisdisfn=~s/\/+/\//g; my $thisdisresdir=$thisdisfn; $thisdisresdir=~s/^\/priv\//\/res\//; - my $resdir='/home/httpd/html'.$thisdisresdir; - $r->print(&Apache::lonhtmlcommon::start_pick_box() + my $resdir = $r->dir_config('lonDocRoot').$thisdisresdir; + $r->print('
' + .&Apache::lonhtmlcommon::start_pick_box() .&Apache::lonhtmlcommon::row_title(&mt('Directory')) .''.$thisdisfn.'' .&Apache::lonhtmlcommon::row_closure() @@ -1895,16 +1988,16 @@ sub publishdirectory { $r->print(&Apache::lonhtmlcommon::row_closure() .&Apache::lonhtmlcommon::row_title(&mt('Options')) ); - $r->print(''. - &hiddenfield('phase','two'). + $r->print(&hiddenfield('phase','two'). &hiddenfield('filename',$env{'form.filename'}). &checkbox('pubrec','include subdirectories'). &checkbox('forcerepub','force republication of previously published files'). &checkbox('obsolete','make file(s) obsolete'). - &checkbox('forceoverride','force directory level metadata over existing'). - '
'); + &checkbox('forceoverride','force directory level metadata over existing') + ); $r->print(&Apache::lonhtmlcommon::row_closure(1) .&Apache::lonhtmlcommon::end_pick_box() + .'
' ); $lock=0; } else { @@ -1925,7 +2018,7 @@ sub publishdirectory { if ($filename=~/\.(\w+)$/) { $extension=$1; } if ($cmode&$dirptr) { if (($filename!~/^\./) && ($env{'form.pubrec'})) { - &publishdirectory($r,$docroot.$fn.'/'.$filename,$thisdisfn.'/'.$filename); + &publishdirectory($r,$fn.'/'.$filename,$thisdisfn.'/'.$filename); } } elsif ((&Apache::loncommon::fileembstyle($extension) ne 'hdn') && ($filename!~/^[\#\.]/) && ($filename!~/\~$/)) { @@ -2014,7 +2107,7 @@ sub defaultmetapublish { $r->print($reply.'


');$r->rflush; } # ------------------------------------------------------------------- Link back - $r->print("".&mt('Back to Metadata').''); + $r->print("".&mt('Back to Metadata').''); $r->print(&Apache::loncommon::end_page()); return OK; } @@ -2078,7 +2171,7 @@ sub handler { # -------------------------------------------------------------- Check filename my $fn=&unescape($env{'form.filename'}); - ($cuname,$cudom)=&Apache::loncacc::constructaccess($fn); + ($cuname,$cudom)=&Apache::lonnet::constructaccess($fn); # ----------------------------------------------------- Do we have permissions? unless (($cuname) && ($cudom)) { $r->log_reason($env{'user.name'}.' at '.$env{'user.domain'}. @@ -2143,8 +2236,8 @@ sub handler { # Breadcrumbs &Apache::lonhtmlcommon::clear_breadcrumbs(); &Apache::lonhtmlcommon::add_breadcrumb({ - 'text' => 'Construction Space', - 'href' => &Apache::loncommon::authorspace(), + 'text' => 'Authoring Space', + 'href' => &Apache::loncommon::authorspace($fn), }); &Apache::lonhtmlcommon::add_breadcrumb({ 'text' => 'Resource Publication', @@ -2157,7 +2250,7 @@ sub handler { $r->print(&Apache::loncommon::start_page('Resource Publication',$js) .&Apache::lonhtmlcommon::breadcrumbs() .&Apache::loncommon::head_subbox( - &Apache::loncommon::CSTR_pageheader()) # FIXME crumbs broken? + &Apache::loncommon::CSTR_pageheader($docroot.$fn)) ); my $thisdisfn=&HTML::Entities::encode($fn,'<>&"'); @@ -2168,7 +2261,10 @@ sub handler { if ($fn=~/\/$/) { # -------------------------------------------------------- This is a directory &publishdirectory($r,$docroot.$fn,$thisdisfn); - $r->print('
'.&mt('Return to Directory').''); + $r->print( + '

'. + &Apache::lonhtmlcommon::actionbox([ + ''.&mt('Return to Directory').''])); } else { # ---------------------- Evaluate individual file, and then output information. $fn=~/\.(\w+)$/; @@ -2218,7 +2314,7 @@ ENDCAPTION $r->print(&Apache::lonhtmlcommon::row_closure() .&Apache::lonhtmlcommon::row_title(&mt('Diffs'))); $r->print(< + ENDDIFF $r->print(&mt('Diffs with Current Version').''); } @@ -2260,7 +2356,5 @@ __END__ =back -=back - =cut