--- loncom/publisher/lonpublisher.pm 2008/07/26 19:05:27 1.241 +++ loncom/publisher/lonpublisher.pm 2021/06/03 13:59:44 1.298 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Publication Handler # -# $Id: lonpublisher.pm,v 1.241 2008/07/26 19:05:27 raeburn Exp $ +# $Id: lonpublisher.pm,v 1.298 2021/06/03 13:59:44 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(); @@ -129,13 +128,9 @@ use Apache::lonlocal; use Apache::loncfile; use LONCAPA::lonmetadata; use Apache::lonmsg; -use vars qw(%metadatafields %metadatakeys); +use vars qw(%metadatafields %metadatakeys %addid $readit); use LONCAPA qw(:DEFAULT :match); - -my %addid; -my %nokey; - my $docroot; my $cuname; @@ -148,6 +143,8 @@ my $lock; =pod +=over 4 + =item B Evaluates a string that contains metadata. This subroutine @@ -199,12 +196,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); @@ -264,8 +261,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 +272,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)) + .'

'; } ######################################### @@ -290,8 +289,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; } } @@ -315,8 +314,12 @@ string which presents the form field (fo =item B +=item B + =item B +=item B + =item B =back @@ -379,12 +382,12 @@ sub selectbox { } my $selout="\n".&Apache::lonhtmlcommon::row_title($title) .''.&Apache::lonhtmlcommon::row_closure(); return $selout; @@ -396,6 +399,59 @@ sub select_level_form { if (!defined($value)) { $env{'form.'.$name}=0; } return &Apache::loncommon::select_level_form($value,$name); } + +sub common_access { + my ($name,$text,$options)=@_; + return unless (ref($options) eq 'ARRAY'); + my $formname = 'pubdirpref'; + my $chkname = 'common'.$name; + my $chkid = 'LC_'.$chkname; + my $divid = $chkid.'div'; + my $customdivid = 'LC_customfile'; + my $selname = $chkname.'select'; + my $selid = $chkid.'select'; + my $selonchange; + if ($name eq 'dist') { + $selonchange = ' onchange="showHideCustom(this,'."'$customdivid'".');"'; + } + my %lt = &Apache::lonlocal::texthash( + 'default' => 'System wide - can be used for any courses system wide', + 'domain' => 'Domain only - use limited to courses in the domai', + 'custom' => 'Customized right of use ...', + 'public' => 'Public - no authentication or authorization required for use', + 'closed' => 'Closed - XML source is closed to everyone', + 'open' => 'Open - XML source is open to people who want to use it', + 'sel' => 'Select', + ); + my $output = <<"END"; +
+ + + +'; +} + ######################################### ######################################### @@ -465,7 +521,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 +533,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 +752,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 +779,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); } } } @@ -776,20 +840,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') { @@ -843,15 +992,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 +1017,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); @@ -887,17 +1039,21 @@ sub checkonthis { 'return_only_error_and_warning_counts' => 1)); my ($errorcount,$warningcount)=split(':',$result); if (($errorcount) || ($warningcount)) { - $r->print('
'.$uri.': '); - if ($errorcount) { - $r->print(''. - $errorcount.' '. - &mt('error(s)').' '); - } - if ($warningcount) { - $r->print(''. - $warningcount.' '. - &mt('warning(s)').''); - } + $r->print('

'.&mt('Warnings and Errors').'

'); + $r->print(''.$uri.':'); + $r->print('
    '); + if ($warningcount) { + $r->print('
  • ' + .&mt('[quant,_1,warning]',$warningcount) + .'
    • '); + } + if ($errorcount) { + $r->print('
  • ' + .&mt('[quant,_1,error]',$errorcount) + .' ' + .'
    • '); + } + $r->print('
'); } else { #$r->print(''.&mt('ok').''); } @@ -936,7 +1092,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 @@ -947,7 +1103,7 @@ I ######################################### sub publish { - my ($source,$target,$style,$batch)=@_; + my ($source,$target,$style,$batch,$nokeyref)=@_; my $logfile; my $scrout=''; my $allmeta=''; @@ -979,32 +1135,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); @@ -1015,6 +1176,12 @@ sub publish { } } } + $outdep.='

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

'.&mt('Dependencies').'

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

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

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

'; } @@ -1062,16 +1229,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|^\.\./||; } @@ -1083,9 +1250,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}; } } @@ -1094,23 +1261,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') { - $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}; } } @@ -1118,11 +1283,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.' '; @@ -1136,11 +1301,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.' '; @@ -1148,15 +1313,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 @@ -1168,17 +1334,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 ($nokeyref->{$_}) { + $keywords{$_}=1; + } + } + + + } foreach my $addkey (split(/[\"\'\,\;]/,$metadatafields{'keywords'})) { $addkey=~s/\s+/ /g; @@ -1199,19 +1370,19 @@ 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.= &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'}). @@ -1238,29 +1409,44 @@ 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) { - $keywordout.='