--- loncom/publisher/lonpublisher.pm 2002/01/16 19:09:31 1.70 +++ 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.70 2002/01/16 19:09:31 harris41 Exp $ +# $Id: lonpublisher.pm,v 1.292 2014/08/03 13:52:59 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -25,25 +25,6 @@ # # http://www.lon-capa.org/ # -# -# (TeX Content Handler -# -# 05/29/00,05/30,10/11 Gerd Kortemeyer) -# -# 11/28,11/29,11/30,12/01,12/02,12/04,12/23 Gerd Kortemeyer -# 03/23 Guy Albertelli -# 03/24,03/29,04/03 Gerd Kortemeyer -# 04/16/2001 Scott Harrison -# 05/03,05/05,05/07 Gerd Kortemeyer -# 05/28/2001 Scott Harrison -# 06/23,08/07,08/11,8/13,8/17,8/18,8/24,9/26,10/16 Gerd Kortemeyer -# 12/04,12/05 Guy Albertelli -# 12/05 Gerd Kortemeyer -# 12/05 Guy Albertelli -# 12/06,12/07 Gerd Kortemeyer -# 12/15,12/16 Scott Harrison -# 12/25 Gerd Kortemeyer -# ### ############################################################################### @@ -58,6 +39,75 @@ ## ## ############################################################################### + +###################################################################### +###################################################################### + +=pod + +=head1 NAME + +lonpublisher - LON-CAPA publishing handler + +=head1 SYNOPSIS + +B is used by B inside B. This is the +invocation by F: + + + PerlAccessHandler Apache::lonacc + SetHandler perl-script + PerlHandler Apache::lonpublisher + ErrorDocument 403 /adm/login + ErrorDocument 404 /adm/notfound.html + ErrorDocument 406 /adm/unauthorized.html + ErrorDocument 500 /adm/errorhandler + + +=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. + +During the publication step, several events will be +triggered. Metadata is gathered, where a wizard manages default +entries on a hierarchical per-directory base: The wizard imports the +metadata (including access privileges and royalty information) from +the most recent published resource in the current directory, and if +that is not available, from the next directory above, etc. The Network +keeps all previous versions of a resource and makes them available by +an explicit version number, which is inserted between the file name +and extension, for example C, while the most recent +version does not carry a version number (C). Servers +subscribing to a changed resource are notified that a new version is +available. + +=head1 DESCRIPTION + +B takes the proper steps to add resources to the LON-CAPA +digital library. This includes updating the metadata table in the +LON-CAPA database. + +B is many things to many people. + +This module publishes a file. This involves gathering metadata, +versioning the file, copying file from construction space to +publication space, and copying metadata from construction space +to publication space. + +=head2 SUBROUTINES + +Many of the undocumented subroutines implement various magical +parsing shortcuts. + +=cut + +###################################################################### +###################################################################### + + package Apache::lonpublisher; # ------------------------------------------------- modules used by this module @@ -65,124 +115,303 @@ use strict; use Apache::File; use File::Copy; use Apache::Constants qw(:common :http :methods); -use HTML::TokeParser; +use HTML::LCParser; +use HTML::Entities; +use Encode::Encoder; use Apache::lonxml; -use Apache::lonhomework; -use Apache::loncacc; use DBI; -use Apache::lonnet(); +use Apache::lonnet; use Apache::loncommon(); +use Apache::lonhtmlcommon; +use Apache::lonmysql; +use Apache::lonlocal; +use Apache::loncfile; +use LONCAPA::lonmetadata; +use Apache::lonmsg; +use vars qw(%metadatafields %metadatakeys); +use LONCAPA qw(:DEFAULT :match); + my %addid; my %nokey; -my %metadatafields; -my %metadatakeys; - my $docroot; my $cuname; my $cudom; -# ----------------------------------------------- Evaluate string with metadata +my $registered_cleanup; +my $modified_urls; + +my $lock; + +=pod + +=over 4 + +=item B + +Evaluates a string that contains metadata. This subroutine +stores values inside I<%metadatafields> and I<%metadatakeys>. +The hash key is a I<$unikey> corresponding to a unique id +that is descriptive of the parser location inside the XML tree. + +Parameters: + +=over 4 + +=item I<$metastring> + +A string that contains metadata. + +=back + +Returns: + +nothing + +=cut + +######################################### +######################################### +# +# Modifies global %metadatafields %metadatakeys +# + sub metaeval { - my $metastring=shift; + my ($metastring,$prefix)=@_; - my $parser=HTML::TokeParser->new(\$metastring); - my $token; - while ($token=$parser->get_token) { - if ($token->[0] eq 'S') { - my $entry=$token->[1]; - my $unikey=$entry; - if (defined($token->[2]->{'package'})) { - $unikey.='_package_'.$token->[2]->{'package'}; - } - if (defined($token->[2]->{'part'})) { - $unikey.='_'.$token->[2]->{'part'}; - } - if (defined($token->[2]->{'id'})) { - $unikey.='_'.$token->[2]->{'id'}; - } - if (defined($token->[2]->{'name'})) { - $unikey.='_'.$token->[2]->{'name'}; - } - foreach (@{$token->[3]}) { - $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; - if ($metadatakeys{$unikey}) { - $metadatakeys{$unikey}.=','.$_; - } else { - $metadatakeys{$unikey}=$_; - } - } - if ($metadatafields{$unikey}) { - my $newentry=$parser->get_text('/'.$entry); - unless (($metadatafields{$unikey}=~/$newentry/) || - ($newentry eq '')) { - $metadatafields{$unikey}.=', '.$newentry; - } - } else { - $metadatafields{$unikey}=$parser->get_text('/'.$entry); - } - } - } + my $parser=HTML::LCParser->new(\$metastring); + my $token; + while ($token=$parser->get_token) { + if ($token->[0] eq 'S') { + my $entry=$token->[1]; + my $unikey=$entry; + next if ($entry =~ m/^(?:parameter|stores)_/); + if (defined($token->[2]->{'package'})) { + $unikey.="\0package\0".$token->[2]->{'package'}; + } + if (defined($token->[2]->{'part'})) { + $unikey.="\0".$token->[2]->{'part'}; + } + if (defined($token->[2]->{'id'})) { + $unikey.="\0".$token->[2]->{'id'}; + } + if (defined($token->[2]->{'name'})) { + $unikey.="\0".$token->[2]->{'name'}; + } + foreach (@{$token->[3]}) { + $metadatafields{$unikey.'.'.$_}=$token->[2]->{$_}; + if ($metadatakeys{$unikey}) { + $metadatakeys{$unikey}.=','.$_; + } else { + $metadatakeys{$unikey}=$_; + } + } + my $newentry=$parser->get_text('/'.$entry); + if (($entry eq 'customdistributionfile') || + ($entry eq 'sourcerights')) { + $newentry=~s/^\s*//; + if ($newentry !~m|^/res|) { $newentry=$prefix.$newentry; } + } +# actually store + if ( $entry eq 'rule' && exists($metadatafields{$unikey})) { + $metadatafields{$unikey}.=','.$newentry; + } else { + $metadatafields{$unikey}=$newentry; + } + } + } } -# -------------------------------------------------------- Read a metadata file +######################################### +######################################### + +=pod + +=item B + +Read a metadata file + +Parameters: + +=over + +=item I<$logfile> + +File output stream to output errors and warnings to. + +=item I<$fn> + +File name (including path). + +=back + +Returns: + +=over 4 + +=item Scalar string (if successful) + +XHTML text that indicates successful reading of the metadata. + +=back + +=cut + +######################################### +######################################### sub metaread { - my ($logfile,$fn)=@_; + my ($logfile,$fn,$prefix)=@_; unless (-e $fn) { - print $logfile 'No file '.$fn."\n"; - return '
No file: '.$fn.''; + print($logfile 'No file '.$fn."\n"); + return '

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

'; } - print $logfile 'Processing '.$fn."\n"; + print($logfile 'Processing '.$fn."\n"); my $metastring; { - my $metafh=Apache::File->new($fn); - $metastring=join('',<$metafh>); + my $metafh=Apache::File->new($fn); + $metastring=join('',<$metafh>); } - &metaeval($metastring); - return '
Processed file: '.$fn.''; + &metaeval($metastring,$prefix); + return '

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

'; } -# ---------------------------- convert 'time' format into a datetime sql format -sub sqltime { - my $timef=shift @_; - my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = - localtime($timef); - $mon++; $year+=1900; - return "$year-$mon-$mday $hour:$min:$sec"; +######################################### +######################################### + +sub coursedependencies { + my $url=&Apache::lonnet::declutter(shift); + $url=~s/\.meta$//; + my ($adomain,$aauthor)=($url=~ m{^($match_domain)/($match_username)/}); + my $regexp=quotemeta($url); + $regexp='___'.$regexp.'___course'; + 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$/) { + $courses{$1}=1; + } + } + return %courses; } +######################################### +######################################### + + +=pod -# --------------------------------------------------------- Various form fields +=item Form-field-generating subroutines. +For input parameters, these subroutines take in values +such as I<$name>, I<$value> and other form field metadata. +The output (scalar string that is returned) is an XHTML +string which presents the form field (foreseeably inside +
tags). + +=over 4 + +=item B + +=item B + +=item B + +=back + +=cut + +######################################### +######################################### sub textfield { - my ($title,$name,$value)=@_; - return "\n

$title:
". - ''; + my ($title,$name,$value,$noline)=@_; + $value=~s/^\s+//gs; + $value=~s/\s+$//gs; + $value=~s/\s+/ /gs; + $title=&mt($title); + $env{'form.'.$name}=$value; + return "\n".&Apache::lonhtmlcommon::row_title($title) + .'' + .&Apache::lonhtmlcommon::row_closure($noline); +} + +sub text_with_browse_field { + my ($title,$name,$value,$restriction,$noline)=@_; + $value=~s/^\s+//gs; + $value=~s/\s+$//gs; + $value=~s/\s+/ /gs; + $title=&mt($title); + $env{'form.'.$name}=$value; + return "\n".&Apache::lonhtmlcommon::row_title($title) + .'' + .'
' + .'' + .&mt('Select') + .' ' + .'' + .&mt('Search') + .'' + .&Apache::lonhtmlcommon::row_closure($noline); } sub hiddenfield { my ($name,$value)=@_; - return "\n".''; + $env{'form.'.$name}=$value; + return "\n".''; +} + +sub checkbox { + my ($name,$text)=@_; + return "\n
"; } sub selectbox { my ($title,$name,$value,$functionref,@idlist)=@_; - my $uctitle=uc($title); - my $selout="\n

$uctitle:". - "
".''; foreach (@idlist) { - $selout.='';} + $selout.=' selected="selected"'; + } + $selout.='>'.&{$functionref}($_).''; } - return $selout.''; + $selout.=''.&Apache::lonhtmlcommon::row_closure(); + return $selout; +} + +sub select_level_form { + my ($value,$name)=@_; + $env{'form.'.$name}=$value; + if (!defined($value)) { $env{'form.'.$name}=0; } + return &Apache::loncommon::select_level_form($value,$name); } +######################################### +######################################### -# -------------------------------------------------------- Publication Step One +=pod +=item B + +Fix up a url? First step of publication + +=cut + +######################################### +######################################### sub urlfixup { my ($url,$target)=@_; unless ($url) { return ''; } @@ -191,15 +420,33 @@ sub urlfixup { if ($url =~ /^mailto:/i) { return $url; } #internal document links need no fixing if ($url =~ /^\#/) { return $url; } - my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/); - foreach (values %Apache::lonnet::hostname) { - if ($_ eq $host) { - $url=~s/^http\:\/\///; - $url=~s/^$host//; - } + my ($host)=($url=~m{(?:(?:http|https|ftp)://)*([^/]+)}); + my @lonids = &Apache::lonnet::machine_ids($host); + if (@lonids) { + $url=~s{^(?:http|https|ftp)://}{}; + $url=~s/^\Q$host\E//; } - if ($url=~/^http\:\/\//) { return $url; } - $url=~s/\~$cuname/res\/$cudom\/$cuname/; + if ($url=~m{^(?:http|https|ftp)://}) { return $url; } + $url=~s{\Q~$cuname\E}{res/$cudom/$cuname}; + return $url; +} + +######################################### +######################################### + +=pod + +=item B + +Currently undocumented. + +=cut + +######################################### +######################################### +sub absoluteurl { + my ($url,$target)=@_; + unless ($url) { return ''; } if ($target) { $target=~s/\/[^\/]+$//; $url=&Apache::lonnet::hreflocation($target,$url); @@ -207,24 +454,590 @@ sub urlfixup { return $url; } +######################################### +######################################### + +=pod + +=item B + +Currently undocumented + +=cut + +######################################### +######################################### +sub set_allow { + my ($allow,$logfile,$target,$tag,$oldurl,$type)=@_; + my $newurl=&urlfixup($oldurl,$target); + my $return_url=$oldurl; + print $logfile 'GUYURL: '.$tag.':'.$oldurl.' - '.$newurl."\n"; + if ($newurl ne $oldurl) { + $return_url=$newurl; + print $logfile 'URL: '.$tag.':'.$oldurl.' - '.$newurl."\n"; + } + if (($newurl !~ /^javascript:/i) && + ($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; +} + +######################################### +######################################### + +=pod + +=item B + +Currently undocumented + +=cut + +######################################### +######################################### +sub get_subscribed_hosts { + my ($target)=@_; + my @subscribed; + my $filename; + $target=~/(.*)\/([^\/]+)$/; + my $srcf=$2; + opendir(DIR,$1); + # cycle through listed files, subscriptions used to exist + # as "filename.lonid" + while ($filename=readdir(DIR)) { + if ($filename=~/\Q$srcf\E\.($match_lonid)$/) { + my $subhost=$1; + if (($subhost ne 'meta' + && $subhost ne 'subscription' + && $subhost ne 'meta.subscription' + && $subhost ne 'tmp') && + ($subhost ne $Apache::lonnet::perlvar{'lonHostID'})) { + push(@subscribed,$subhost); + } + } + } + closedir(DIR); + my $sh; + if ( $sh=Apache::File->new("$target.subscription") ) { + while (my $subline=<$sh>) { + if ($subline =~ /^($match_lonid):/) { + if ($1 ne $Apache::lonnet::perlvar{'lonHostID'}) { + push(@subscribed,$1); + } + } + } + } + return @subscribed; +} + + +######################################### +######################################### + +=pod + +=item B + +Currently undocumented + +=cut + +######################################### +######################################### +sub get_max_ids_indices { + my ($content)=@_; + my $maxindex=10; + my $maxid=10; + my $needsfixup=0; + my $duplicateids=0; + + my %allids; + my %duplicatedids; + + my $parser=HTML::LCParser->new($content); + $parser->xml_mode(1); + my $token; + while ($token=$parser->get_token) { + if ($token->[0] eq 'S') { + my $counter; + if ($counter=$addid{$token->[1]}) { + if ($counter eq 'id') { + if (defined($token->[2]->{'id'}) && + $token->[2]->{'id'} !~ /^\s*$/) { + $maxid=($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid; + if (exists($allids{$token->[2]->{'id'}})) { + $duplicateids=1; + $duplicatedids{$token->[2]->{'id'}}=1; + } else { + $allids{$token->[2]->{'id'}}=1; + } + } else { + $needsfixup=1; + } + } else { + if (defined($token->[2]->{'index'}) && + $token->[2]->{'index'} !~ /^\s*$/) { + $maxindex=($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex; + } else { + $needsfixup=1; + } + } + } + } + } + return ($needsfixup,$maxid,$maxindex,$duplicateids, + (keys(%duplicatedids))); +} + +######################################### +######################################### + +=pod + +=item B + +Currently undocumented + +=cut + +######################################### +######################################### +sub get_all_text_unbalanced { + #there is a copy of this in lonxml.pm + my($tag,$pars)= @_; + my $token; + my $result=''; + $tag='<'.$tag.'>'; + while ($token = $$pars[-1]->get_token) { + if (($token->[0] eq 'T')||($token->[0] eq 'C')||($token->[0] eq 'D')) { + $result.=$token->[1]; + } elsif ($token->[0] eq 'PI') { + $result.=$token->[2]; + } elsif ($token->[0] eq 'S') { + $result.=$token->[4]; + } elsif ($token->[0] eq 'E') { + $result.=$token->[2]; + } + if ($result =~ /\Q$tag\E/s) { + ($result,my $redo)=$result =~ /(.*)\Q$tag\E(.*)/is; + #&Apache::lonnet::logthis('Got a winner with leftovers ::'.$2); + #&Apache::lonnet::logthis('Result is :'.$1); + $redo=$tag.$redo; + push (@$pars,HTML::LCParser->new(\$redo)); + $$pars[-1]->xml_mode('1'); + last; + } + } + return $result +} + +######################################### +######################################### + +=pod + +=item B + +Currently undocumented + +=cut + +######################################### +######################################### +#Arguably this should all be done as a lonnet::ssi instead +sub fix_ids_and_indices { + my ($logfile,$source,$target)=@_; + + my %allow; + my $content; + { + my $org=Apache::File->new($source); + $content=join('',<$org>); + } + + my ($needsfixup,$maxid,$maxindex,$duplicateids,@duplicatedids)= + &get_max_ids_indices(\$content); + + print $logfile ("Got $needsfixup,$maxid,$maxindex,$duplicateids--". + join(', ',@duplicatedids)); + if ($duplicateids) { + print $logfile "Duplicate ID(s) exist, ".join(', ',@duplicatedids)."\n"; + my $outstring=''.&mt('Unable to publish file, it contains duplicated ID(s), ID(s) need to be unique. The duplicated ID(s) are').': '.join(', ',@duplicatedids).''; + return ($outstring,1); + } + if ($needsfixup) { + print $logfile "Needs ID and/or index fixup\n". + "Max ID : $maxid (min 10)\n". + "Max Index: $maxindex (min 10)\n"; + } + my $outstring=''; + my $responsecounter=1; + my @parser; + $parser[0]=HTML::LCParser->new(\$content); + $parser[-1]->xml_mode(1); + my $token; + while (@parser) { + while ($token=$parser[-1]->get_token) { + if ($token->[0] eq 'S') { + my $counter; + my $tag=$token->[1]; + my $lctag=lc($tag); + if ($lctag eq 'allow') { + $allow{$token->[2]->{'src'}}=1; + next; + } + if ($lctag eq 'base') { next; } + if (($lctag eq 'part') || ($lctag eq 'problem')) { + $responsecounter=0; + } + if ($lctag=~/response$/) { $responsecounter++; } + if ($lctag eq 'import') { $responsecounter++; } + my %parms=%{$token->[2]}; + $counter=$addid{$tag}; + if (!$counter) { $counter=$addid{$lctag}; } + if ($counter) { + if ($counter eq 'id') { + unless (defined($parms{'id'}) && + $parms{'id'}!~/^\s*$/) { + $maxid++; + $parms{'id'}=$maxid; + print $logfile 'ID(new) : '.$tag.':'.$maxid."\n"; + } else { + print $logfile 'ID(kept): '.$tag.':'.$parms{'id'}."\n"; + } + } elsif ($counter eq 'index') { + unless (defined($parms{'index'}) && + $parms{'index'}!~/^\s*$/) { + $maxindex++; + $parms{'index'}=$maxindex; + print $logfile 'Index: '.$tag.':'.$maxindex."\n"; + } + } + } + unless ($parms{'type'} eq 'zombie') { + 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},$type); + } + } + } + } + # probably a image type

.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') { + $outstring.='[1].'>'; + } + } + if ((($token->[1] eq 'part') || ($token->[1] eq 'problem')) + && (!$responsecounter)) { + my $outstring=''.&mt('Found [_1] without responses. This resource cannot be published.',$token->[1]).''; + return ($outstring,1); + } + } else { + $outstring.=$token->[1]; + } + } + pop(@parser); + } + + if ($needsfixup) { + print $logfile "End of ID and/or index fixup\n". + "Max ID : $maxid (min 10)\n". + "Max Index: $maxindex (min 10)\n"; + } else { + print $logfile "Does not need ID and/or index fixup\n"; + } + + return ($outstring,0,%allow); +} + +######################################### +######################################### + +=pod + +=item B + +Store the metadata in the metadata table in the loncapa database. +Uses lonmysql to access the database. + +Inputs: \%metadata + +Returns: (error,status). error is undef on success, status is undef on error. + +=cut + +######################################### +######################################### +sub store_metadata { + my %metadata = @_; + my $error; + # Determine if the table exists + my $status = &Apache::lonmysql::check_table('metadata'); + if (! defined($status)) { + $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 ='' + .&mt('WARNING: The metadata table does not exist in the LON-CAPA database!') + .''; + &Apache::lonnet::logthis($error); + return ($error,undef); + } + my $dbh = &Apache::lonmysql::get_dbh(); + if (($metadata{'obsolete'}) || ($metadata{'copyright'} eq 'priv')) { + # remove this entry + my $delitem = 'url = '.$dbh->quote($metadata{'url'}); + $status = &LONCAPA::lonmetadata::delete_metadata($dbh,undef,$delitem); + + } else { + $status = &LONCAPA::lonmetadata::update_metadata($dbh,undef,undef, + \%metadata); + } + if (defined($status) && $status ne '') { + $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); + } + return (undef,'success'); +} + + +# ========================================== Parse file for errors and warnings + +sub checkonthis { + my ($r,$source)=@_; + my $uri=&Apache::lonnet::hreflocation($source); + $uri=~s/\/$//; + my $result=&Apache::lonnet::ssi_body($uri, + ('grade_target'=>'web', + 'return_only_error_and_warning_counts' => 1)); + my ($errorcount,$warningcount)=split(':',$result); + if (($errorcount) || ($warningcount)) { + $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').''); + } + $r->rflush(); + return ($warningcount,$errorcount); +} + +# ============================================== Parse file itself for metadata +# +# parses a file with target meta, sets global %metadatafields %metadatakeys + +sub parseformeta { + my ($source,$style)=@_; + my $allmeta=''; + if (($style eq 'ssi') || ($style eq 'prv')) { + my $dir=$source; + $dir=~s-/[^/]*$--; + my $file=$source; + $file=(split('/',$file))[-1]; + $source=&Apache::lonnet::hreflocation($dir,$file); + $allmeta=&Apache::lonnet::ssi_body($source,('grade_target' => 'meta')); + &metaeval($allmeta); + } + return $allmeta; +} + +######################################### +######################################### + +=pod + +=item B + +This is the workhorse function of this module. This subroutine generates +backup copies, performs any automatic processing (prior to publication, +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 occurred) or 0 +(no error occurred) + +I + +=cut + +######################################### +######################################### sub publish { - my ($source,$target,$style)=@_; + my ($source,$target,$style,$batch)=@_; my $logfile; my $scrout=''; my $allmeta=''; my $content=''; my %allow=(); - undef %allow; unless ($logfile=Apache::File->new('>>'.$source.'.log')) { - return - 'No write permission to user directory, FAIL'; + return (''.&mt('No write permission to user directory, FAIL').'',1); } print $logfile -"\n\n================= Publish ".localtime()." Phase One ================\n"; +"\n\n================= Publish ".localtime()." Phase One ================\n".$env{'user.name'}.':'.$env{'user.domain'}."\n"; - if (($style eq 'ssi') || ($style eq 'rat')) { + if (($style eq 'ssi') || ($style eq 'rat') || ($style eq 'prv')) { # ------------------------------------------------------- This needs processing # ----------------------------------------------------------------- Backup Copy @@ -233,239 +1046,129 @@ sub publish { print $logfile "Copied original file to ".$copyfile."\n"; } else { print $logfile "Unable to write backup ".$copyfile.':'.$!."\n"; - return "Failed to write backup copy, $!,FAIL"; + return ("".&mt("Failed to write backup copy, [_1], FAIL",$1)."",1); } # ------------------------------------------------------------- IDs and indices - - my $maxindex=10; - my $maxid=10; - - my $needsfixup=0; - - { - my $org=Apache::File->new($source); - $content=join('',<$org>); - } - { - my $parser=HTML::TokeParser->new(\$content); - my $token; - while ($token=$parser->get_token) { - if ($token->[0] eq 'S') { - my $counter; - if ($counter=$addid{$token->[1]}) { - if ($counter eq 'id') { - if (defined($token->[2]->{'id'})) { - $maxid= - ($token->[2]->{'id'}>$maxid)?$token->[2]->{'id'}:$maxid; - } else { - $needsfixup=1; - } - } else { - if (defined($token->[2]->{'index'})) { - $maxindex= - ($token->[2]->{'index'}>$maxindex)?$token->[2]->{'index'}:$maxindex; - } else { - $needsfixup=1; - } - } - } - } - } - } - if ($needsfixup) { - print $logfile "Needs ID and/or index fixup\n". - "Max ID : $maxid (min 10)\n". - "Max Index: $maxindex (min 10)\n"; - } - my $outstring=''; - my $parser=HTML::TokeParser->new(\$content); - $parser->xml_mode(1); - my $token; - while ($token=$parser->get_token) { - if ($token->[0] eq 'S') { - my $counter; - my $tag=$token->[1]; - my $lctag=lc($tag); - unless ($lctag eq 'allow') { - my %parms=%{$token->[2]}; - $counter=$addid{$tag}; - if (!$counter) { $counter=$addid{$lctag}; } - if ($counter) { - if ($counter eq 'id') { - unless (defined($parms{'id'})) { - $maxid++; - $parms{'id'}=$maxid; - print $logfile 'ID: '.$tag.':'.$maxid."\n"; - } - } elsif ($counter eq 'index') { - unless (defined($parms{'index'})) { - $maxindex++; - $parms{'index'}=$maxindex; - print $logfile 'Index: '.$tag.':'.$maxindex."\n"; - } - } - } - - foreach ('src','href','background') { - if (defined($parms{$_})) { - my $oldurl=$parms{$_}; - my $newurl=&urlfixup($oldurl,$target); - if ($newurl ne $oldurl) { - $parms{$_}=$newurl; - print $logfile 'URL: '.$tag.':'.$oldurl.' - '. - $newurl."\n"; - } - $allow{$newurl}=1; - } - } - - if ($lctag eq 'applet') { - my $codebase=''; - if (defined($parms{'codebase'})) { - my $oldcodebase=$parms{'codebase'}; - unless ($oldcodebase=~/\/$/) { - $oldcodebase.='/'; - } - $codebase=&urlfixup($oldcodebase,$target); - $codebase=~s/\/$//; - if ($codebase ne $oldcodebase) { - $parms{'codebase'}=$codebase; - print $logfile 'URL codebase: '.$tag.':'. - $oldcodebase.' - '. - $codebase."\n"; - } - $allow{$codebase.'/*'}=1; - } else { - foreach ('archive','code','object') { - if (defined($parms{$_})) { - my $oldurl=$parms{$_}; - my $newurl=&urlfixup($oldurl,$target); - $newurl=~s/\/[^\/]+$/\/\*/; - print $logfile 'Allow: applet '.$_.':'. - $oldurl.' allows '. - $newurl."\n"; - $allow{$newurl}=1; - } - } - } - } - - my $newparmstring=''; - my $endtag=''; - foreach (keys %parms) { - if ($_ eq '/') { - $endtag=' /'; - } else { - my $quote=($parms{$_}=~/\"/?"'":'"'); - $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote; - } - } - if (!$endtag) { if ($token->[4]=~m:/>$:) { $endtag=' /'; }; } - $outstring.='<'.$tag.$newparmstring.$endtag.'>'; - } else { - $allow{$token->[2]->{'src'}}=1; - } - } elsif ($token->[0] eq 'E') { - if ($token->[2]) { - unless ($token->[1] eq 'allow') { - $outstring.='[1].'>'; - } - } - } else { - $outstring.=$token->[1]; - } - } + + my ($outstring,$error); + ($outstring,$error,%allow)=&fix_ids_and_indices($logfile,$source, + $target); + if ($error) { return ($outstring,$error); } # ------------------------------------------------------------ Construct Allows - $scrout.='

Dependencies

'; + my $outdep=''; # Collect dependencies output data my $allowstr=''; - foreach (keys %allow) { - my $thisdep=$_; + foreach my $thisdep (sort(keys(%allow))) { + if ($thisdep !~ /[^\s]/) { next; } + if ($thisdep =~/\$/) { + $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.='
'; - unless ($thisdep=~/\*/) { - $scrout.=''; + $outdep.='
'; + if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) { + $outdep.=''; } - $scrout.=''.$thisdep.''; - unless ($thisdep=~/\*/) { - $scrout.=''; + $outdep.=''.$thisdep.''; + if ($thisdep!~/[\*\$]/ && $thisdep!~m|^/adm/|) { + $outdep.=''; if ( &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'. $thisdep.'.meta') eq '-1') { - $scrout.= - ' - 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); - $thisdep=~/^\/res\/(\w+)\/(\w+)\//; + $thisdep=~m{^/res/($match_domain)/($match_username)/}; if ((defined($1)) && (defined($2))) { - &Apache::lonnet::put('resevaldata',\%temphash,$1,$2); + &Apache::lonnet::put('nohist_resevaldata',\%temphash, + $1,$2); } } } + $outdep.='

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

'.&mt('Dependencies').'

' + .$outdep } - $outstring=~s/(\<\/[^\>]+\>\s*)$/$allowstr$1/s; + $outstring=~s/\n*(\<\/[^\>]+\>[^<]*)$/$allowstr\n$1\n/s; -# ------------------------------------------------------------- Write modified +# ------------------------------------------------------------- Write modified. { my $org; unless ($org=Apache::File->new('>'.$source)) { print $logfile "No write permit to $source\n"; - return - "No write permission to $source, FAIL"; + return (''.&mt('No write permission to'). + ' '.$source. + ', '.&mt('FAIL').'',1); } - print $org $outstring; + print($org $outstring); } $content=$outstring; - if ($needsfixup) { - print $logfile "End of ID and/or index fixup\n". - "Max ID : $maxid (min 10)\n". - "Max Index: $maxindex (min 10)\n"; - } else { - print $logfile "Does not need ID and/or index fixup\n"; - } } -# --------------------------------------------- Initial step done, now metadata - -# ---------------------------------------- Storage for metadata keys and fields +# -------------------------------------------- Initial step done, now metadata. +# --------------------------------------- Storage for metadata keys and fields. +# these are globals +# %metadatafields=(); %metadatakeys=(); my %oldparmstores=(); - $scrout.='

Metadata Information

'; + unless ($batch) { + $scrout.='

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

'; + } # ------------------------------------------------ First, check out environment - unless (-e $source.'.meta') { - $metadatafields{'author'}=$ENV{'environment.firstname'}.' '. - $ENV{'environment.middlename'}.' '. - $ENV{'environment.lastname'}.' '. - $ENV{'environment.generation'}; + if ((!(-e $source.'.meta')) || ($env{'form.forceoverride'})) { + $metadatafields{'author'}=$env{'environment.firstname'}.' '. + $env{'environment.middlename'}.' '. + $env{'environment.lastname'}.' '. + $env{'environment.generation'}; $metadatafields{'author'}=~s/\s+/ /g; $metadatafields{'author'}=~s/\s+$//; - $metadatafields{'owner'}=$cuname.'@'.$cudom; + $metadatafields{'owner'}=$cuname.':'.$cudom; # ------------------------------------------------ Check out directory hierachy my $thisdisfn=$source; - $thisdisfn=~s/^\/home\/$cuname\///; - 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.'/'; - foreach (@urlparts) { - $currentpath.=$_.'/'; - $scrout.=&metaread($logfile,$currentpath.'default.meta'); + my $prefix='../'x($#urlparts); + foreach my $subdir (@urlparts) { + $currentpath.=$subdir.'/'; + $scrout.=&metaread($logfile,$currentpath.'default.meta',$prefix); + $prefix=~s|^\.\./||; } +# ----------------------------------------------------------- Parse file itself +# read %metadatafields from file itself + + $allmeta=&parseformeta($source,$style); + # ------------------- Clear out parameters and stores (there should not be any) foreach (keys %metadatafields) { @@ -485,723 +1188,1149 @@ sub publish { delete $metadatafields{$_}; } } - - } - -# -------------------------------------------------- Parse content for metadata - if ($style eq 'ssi') { - my $oldenv=$ENV{'request.uri'}; - - $ENV{'request.uri'}=$target; - $allmeta=Apache::lonxml::xmlparse('meta',$content); - $ENV{'request.uri'}=$oldenv; +# ------------------------------------------------------------- Save some stuff + my %savemeta=(); + foreach ('title') { + if ($metadatafields{$_}) { $savemeta{$_}=$metadatafields{$_}; } + } +# ------------------------------------------ See if anything new in file itself + + $allmeta=&parseformeta($source,$style); +# ----------------------------------------------------------- Restore the stuff + foreach (keys %savemeta) { + $metadatafields{$_}=$savemeta{$_}; + } + } - &metaeval($allmeta); - } + # ---------------- Find and document discrepancies in the parameters and stores - my $chparms=''; - foreach (sort keys %metadatafields) { - if (($_=~/^parameter/) || ($_=~/^stores/)) { - unless ($_=~/\.\w+$/) { - unless ($oldparmstores{$_}) { - print $logfile 'New: '.$_."\n"; - $chparms.=$_.' '; - } - } - } - } - if ($chparms) { - $scrout.='

New parameters or stored values: '. - $chparms; - } + my $chparms=''; + foreach (sort keys %metadatafields) { + if (($_=~/^parameter/) || ($_=~/^stores/)) { + unless ($_=~/\.\w+$/) { + unless ($oldparmstores{$_}) { + my $disp_key = $_; + $disp_key =~ tr/\0/_/; + print $logfile ('New: '.$disp_key."\n"); + $chparms .= $disp_key.' '; + } + } + } + } + if ($chparms) { + $scrout.='

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

'; + } - $chparms=''; - foreach (sort keys %oldparmstores) { - if (($_=~/^parameter/) || ($_=~/^stores/)) { - unless (($metadatafields{$_.'.name'}) || - ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { - print $logfile 'Obsolete: '.$_."\n"; - $chparms.=$_.' '; - } - } - } - if ($chparms) { - $scrout.='

Obsolete parameters or stored values: '. - $chparms; - } + $chparms=''; + foreach (sort keys %oldparmstores) { + if (($_=~/^parameter/) || ($_=~/^stores/)) { + unless (($metadatafields{$_.'.name'}) || + ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { + my $disp_key = $_; + $disp_key =~ tr/\0/_/; + print $logfile ('Obsolete: '.$disp_key."\n"); + $chparms.=$disp_key.' '; + } + } + } + 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.') + .'

'; + } + 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.') + .'

'; + } # ------------------------------------------------------- Now have all metadata - $scrout.= - '
'. - '

'. - &hiddenfield('phase','two'). - &hiddenfield('filename',$ENV{'form.filename'}). - &hiddenfield('allmeta',&Apache::lonnet::escape($allmeta)). - &hiddenfield('dependencies',join(',',keys %allow)). - &textfield('Title','title',$metadatafields{'title'}). - &textfield('Author(s)','author',$metadatafields{'author'}). - &textfield('Subject','subject',$metadatafields{'subject'}); - -# --------------------------------------------------- Scan content for keywords - - my $keywordout='

Keywords:
'; - my $colcount=0; - my %keywords=(); + my %keywords=(); - if (length($content)<500000) { - my $textonly=$content; - $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; - } + if (length($content)<500000) { + my $textonly=$content; + $textonly=~s/\//g; + $textonly=~s/\[^\<]+\<\/m\>//g; + $textonly=~s/\<[^\>]*\>//g; + + #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 (split(/\W+/,$metadatafields{'keywords'})) { - $keywords{$_}=1; - } + foreach my $addkey (split(/[\"\'\,\;]/,$metadatafields{'keywords'})) { + $addkey=~s/\s+/ /g; + $addkey=~s/^\s//; + $addkey=~s/\s$//; + if ($addkey=~/\w/) { + $keywords{$addkey}=1; + } + } +# --------------------------------------------------- Now we also have keywords +# ============================================================================= +# interactive mode html goes into $intr_scrout +# batch mode throws away this HTML +# additionally all of the field functions have a by product of setting +# $env{'from.'..} so that it can be used by the phase two handler in +# batch mode + + my $intr_scrout.='
' + .''; + unless ($env{'form.makeobsolete'}) { + $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)); + unless ($env{'form.makeobsolete'}) { + $intr_scrout.= + &textfield('Title','title',$metadatafields{'title'}). + &textfield('Author(s)','author',$metadatafields{'author'}). + &textfield('Subject','subject',$metadatafields{'subject'}); + # --------------------------------------------------- Scan content for keywords + + my $keywords_help = &Apache::loncommon::help_open_topic("Publishing_Keywords"); + my $keywordout=<<"END"; + +END + $keywordout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Keywords')) + .$keywords_help + .'' + .'' + .'


' + .&Apache::loncommon::start_data_table(); + my $cols_per_row = 10; + my $colcount=0; + my $wordcount=0; + my $numkeywords = scalar(keys(%keywords)); + + foreach my $word (sort(keys(%keywords))) { + if ($colcount == 0) { + $keywordout .= &Apache::loncommon::start_data_table_row(); + } + $colcount++; + $wordcount++; + if (($wordcount == $numkeywords) && ($colcount < $cols_per_row)) { + my $colspan = 1+$cols_per_row-$colcount; + $keywordout .= ''; + if ($colcount == $cols_per_row) { + $keywordout.=&Apache::loncommon::end_data_table_row(); + $colcount=0; + } + } + if ($colcount > 0) { + $keywordout .= &Apache::loncommon::end_data_table_row(); + } - $scrout.=$keywordout; + $env{'form.keywords'}=~s/\,$//; - $scrout.=&textfield('Additional Keywords','addkey',''); + $keywordout.=&Apache::loncommon::end_data_table_row() + .&Apache::loncommon::end_data_table() + .&Apache::lonhtmlcommon::row_closure(); - $scrout.=&textfield('Notes','notes',$metadatafields{'notes'}); + $intr_scrout.=$keywordout; - $scrout.= - '

Abstract:
'; + $intr_scrout.=&textfield('Additional Keywords','addkey',''); - $source=~/\.(\w+)$/; + $intr_scrout.=&textfield('Notes','notes',$metadatafields{'notes'}); - $scrout.=&hiddenfield('mime',$1); + $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Abstract')) + .'' + .&Apache::lonhtmlcommon::row_closure(); - $scrout.=&selectbox('Language','language', - $metadatafields{'language'}, - \&Apache::loncommon::languagedescription, - (&Apache::loncommon::languageids), + $source=~/\.(\w+)$/; + + $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Grade Levels')) + .&mt('Lowest Grade Level:').' ' + .&select_level_form($metadatafields{'lowestgradelevel'},'lowestgradelevel') +# .&Apache::lonhtmlcommon::row_closure(); +# $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title(&mt('Highest Grade Level')) + .' '.&mt('Highest Grade Level:').' ' + .&select_level_form($metadatafields{'highestgradelevel'},'highestgradelevel') + .&Apache::lonhtmlcommon::row_closure(); + + $intr_scrout.=&textfield('Standards','standards',$metadatafields{'standards'}); + + $intr_scrout.=&hiddenfield('mime',$1); + + my $defaultlanguage=$metadatafields{'language'}; + $defaultlanguage =~ s/\s*notset\s*//g; + $defaultlanguage =~ s/^,\s*//g; + $defaultlanguage =~ s/,\s*$//g; + + $intr_scrout.=&selectbox('Language','language', + $defaultlanguage, + \&Apache::loncommon::languagedescription, + (&Apache::loncommon::languageids), ); - unless ($metadatafields{'creationdate'}) { - $metadatafields{'creationdate'}=time; - } - $scrout.=&hiddenfield('creationdate',$metadatafields{'creationdate'}); + unless ($metadatafields{'creationdate'}) { + $metadatafields{'creationdate'}=time; + } + $intr_scrout.=&hiddenfield('creationdate', + &Apache::lonmysql::unsqltime($metadatafields{'creationdate'})); - $scrout.=&hiddenfield('lastrevisiondate',time); + $intr_scrout.=&hiddenfield('lastrevisiondate',time); - - $scrout.=&textfield('Publisher/Owner','owner', - $metadatafields{'owner'}); -# --------------------------------------------------- Correct copyright for rat - if ($style eq 'rat') { - if ($metadatafields{'copyright'} eq 'public') { - delete $metadatafields{'copyright'}; + my $pubowner_last; + if ($style eq 'prv') { + $pubowner_last = 1; + } + $intr_scrout.=&textfield('Publisher/Owner','owner', + $metadatafields{'owner'},$pubowner_last); + +# ---------------------------------------------- Retrofix for unused copyright + if ($metadatafields{'copyright'} eq 'free') { + $metadatafields{'copyright'}='default'; + $metadatafields{'sourceavail'}='open'; + } + if ($metadatafields{'copyright'} eq 'priv') { + $metadatafields{'copyright'}='domain'; + } +# ------------------------------------------------ Dial in reasonable defaults + my $defaultoption=$metadatafields{'copyright'}; + unless ($defaultoption) { $defaultoption='default'; } + my $defaultsourceoption=$metadatafields{'sourceavail'}; + unless ($defaultsourceoption) { $defaultsourceoption='closed'; } + unless ($style eq 'prv') { +# -------------------------------------------------- Correct copyright for rat. + if ($style eq 'rat') { +# -------------------------------------- Retrofix for non-applicable copyright + if ($metadatafields{'copyright'} eq 'public') { + delete $metadatafields{'copyright'}; + $defaultoption='default'; + } + $intr_scrout.=&selectbox('Copyright/Distribution','copyright', + $defaultoption, + \&Apache::loncommon::copyrightdescription, + (grep !/^(public|priv)$/,(&Apache::loncommon::copyrightids))); + } else { + $intr_scrout.=&selectbox('Copyright/Distribution','copyright', + $defaultoption, + \&Apache::loncommon::copyrightdescription, + (grep !/^priv$/,(&Apache::loncommon::copyrightids))); } - $scrout.=&selectbox('Copyright/Distribution','copyright', - $metadatafields{'copyright'}, - \&Apache::loncommon::copyrightdescription, - (grep !/^public$/,(&Apache::loncommon::copyrightids))); + my $copyright_help = + &Apache::loncommon::help_open_topic('Publishing_Copyright'); + my $replace=&mt('Copyright/Distribution:'); + $intr_scrout =~ s/$replace/$replace.' '.$copyright_help/ge; + + $intr_scrout.=&text_with_browse_field('Custom Distribution File','customdistributionfile',$metadatafields{'customdistributionfile'},'rights'); + $intr_scrout.=&selectbox('Source Distribution','sourceavail', + $defaultsourceoption, + \&Apache::loncommon::source_copyrightdescription, + (&Apache::loncommon::source_copyrightids)); +# $intr_scrout.=&text_with_browse_field('Source Custom Distribution File','sourcerights',$metadatafields{'sourcerights'},'rights'); + my $uctitle=&mt('Obsolete'); + my $obsolete_checked=($metadatafields{'obsolete'})?' checked="checked"':''; + $intr_scrout.="\n".&Apache::lonhtmlcommon::row_title($uctitle) + .'' + .&Apache::lonhtmlcommon::row_closure(1); + $intr_scrout.=&text_with_browse_field('Suggested Replacement for Obsolete File', + 'obsoletereplacement', + $metadatafields{'obsoletereplacement'},'',1); + } else { + $intr_scrout.=&hiddenfield('copyright','private'); } - else { - $scrout.=&selectbox('Copyright/Distribution','copyright', - $metadatafields{'copyright'}, - \&Apache::loncommon::copyrightdescription, - (&Apache::loncommon::copyrightids)); + } else { + $intr_scrout.= + &hiddenfield('title',$metadatafields{'title'}). + &hiddenfield('author',$metadatafields{'author'}). + &hiddenfield('subject',$metadatafields{'subject'}). + &hiddenfield('keywords',$metadatafields{'keywords'}). + &hiddenfield('abstract',$metadatafields{'abstract'}). + &hiddenfield('notes',$metadatafields{'notes'}). + &hiddenfield('mime',$metadatafields{'mime'}). + &hiddenfield('creationdate',$metadatafields{'creationdate'}). + &hiddenfield('lastrevisiondate',time). + &hiddenfield('owner',$metadatafields{'owner'}). + &hiddenfield('lowestgradelevel',$metadatafields{'lowestgradelevel'}). + &hiddenfield('standards',$metadatafields{'standards'}). + &hiddenfield('highestgradelevel',$metadatafields{'highestgradelevel'}). + &hiddenfield('language',$metadatafields{'language'}). + &hiddenfield('copyright',$metadatafields{'copyright'}). + &hiddenfield('sourceavail',$metadatafields{'sourceavail'}). + &hiddenfield('customdistributionfile',$metadatafields{'customdistributionfile'}). + &hiddenfield('obsolete',1). + &text_with_browse_field('Suggested Replacement for Obsolete File', + 'obsoletereplacement', + $metadatafields{'obsoletereplacement'},'',1); + } + if (!$batch) { + $scrout.=$intr_scrout + .&Apache::lonhtmlcommon::end_pick_box() + .'

' + .''; } - return $scrout. - '

'; + return($scrout,0); } -# -------------------------------------------------------- Publication Step Two +######################################### +######################################### -sub phasetwo { +=pod - my ($source,$target,$style,$distarget)=@_; - my $logfile; - my $scrout=''; +=item B - unless ($logfile=Apache::File->new('>>'.$source.'.log')) { - return - 'No write permission to user directory, FAIL'; - } - print $logfile -"\n================= Publish ".localtime()." Phase Two ================\n"; +Render second interface showing status of publication steps. +This is publication step two. - %metadatafields=(); - %metadatakeys=(); +Parameters: - &metaeval(&Apache::lonnet::unescape($ENV{'form.allmeta'})); +=over 4 - $metadatafields{'title'}=$ENV{'form.title'}; - $metadatafields{'author'}=$ENV{'form.author'}; - $metadatafields{'subject'}=$ENV{'form.subject'}; - $metadatafields{'notes'}=$ENV{'form.notes'}; - $metadatafields{'abstract'}=$ENV{'form.abstract'}; - $metadatafields{'mime'}=$ENV{'form.mime'}; - $metadatafields{'language'}=$ENV{'form.language'}; - $metadatafields{'creationdate'}=$ENV{'form.creationdate'}; - $metadatafields{'lastrevisiondate'}=$ENV{'form.lastrevisiondate'}; - $metadatafields{'owner'}=$ENV{'form.owner'}; - $metadatafields{'copyright'}=$ENV{'form.copyright'}; - $metadatafields{'dependencies'}=$ENV{'form.dependencies'}; - - my $allkeywords=$ENV{'form.addkey'}; - foreach (keys %ENV) { - if ($_=~/^form\.key\.(\w+)/) { - $allkeywords.=','.$1; - } - } - $allkeywords=~s/\W+/\,/; - $allkeywords=~s/^\,//; - $metadatafields{'keywords'}=$allkeywords; - - { - print $logfile "\nWrite metadata file for ".$source; - my $mfh; - unless ($mfh=Apache::File->new('>'.$source.'.meta')) { - return - 'Could not write metadata, FAIL'; - } - foreach (sort keys %metadatafields) { - unless ($_=~/\./) { - my $unikey=$_; - $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.'.'.$_}; - $value=~s/\"/\'\'/g; - print $mfh ' '.$_.'="'.$value.'"'; - } - print $mfh '>'.$metadatafields{$unikey}.''; - } - } - $scrout.='

Wrote Metadata'; - print $logfile "\nWrote metadata"; - } +=item I<$source> -# -------------------------------- Synchronize entry with SQL metadata database - my $warning; +=item I<$target> - unless ($metadatafields{'copyright'} eq 'priv') { +=item I<$style> - my $dbh; - { - unless ( - $dbh = DBI->connect("DBI:mysql:loncapa","www", - $Apache::lonnet::perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0}) - ) { - $warning='WARNING: Cannot connect to '. - 'database!'; - } - else { - my %sqldatafields; - $sqldatafields{'url'}=$distarget; - my $sth=$dbh->prepare( - 'delete from metadata where url like binary'. - '"'.$sqldatafields{'url'}.'"'); - $sth->execute(); - foreach ('title','author','subject','keywords','notes','abstract', - 'mime','language','creationdate','lastrevisiondate','owner', - 'copyright') { - my $field=$metadatafields{$_}; $field=~s/\"/\'\'/g; - $sqldatafields{$_}=$field; - } - - $sth=$dbh->prepare('insert into metadata values ('. - '"'.delete($sqldatafields{'title'}).'"'.','. - '"'.delete($sqldatafields{'author'}).'"'.','. - '"'.delete($sqldatafields{'subject'}).'"'.','. - '"'.delete($sqldatafields{'url'}).'"'.','. - '"'.delete($sqldatafields{'keywords'}).'"'.','. - '"'.'current'.'"'.','. - '"'.delete($sqldatafields{'notes'}).'"'.','. - '"'.delete($sqldatafields{'abstract'}).'"'.','. - '"'.delete($sqldatafields{'mime'}).'"'.','. - '"'.delete($sqldatafields{'language'}).'"'.','. - '"'. - sqltime(delete($sqldatafields{'creationdate'})) - .'"'.','. - '"'. - sqltime(delete( - $sqldatafields{'lastrevisiondate'})).'"'.','. - '"'.delete($sqldatafields{'owner'}).'"'.','. - '"'.delete( - $sqldatafields{'copyright'}).'"'.')'); - $sth->execute(); - $dbh->disconnect; - $scrout.='

Synchronized SQL metadata database'; - print $logfile "\nSynchronized SQL metadata database"; +=item I<$distarget> + +=back + +Returns: + +=over 4 + +=item integer + +0: fail +1: success + +=back + +=cut + +#'stupid emacs +######################################### +######################################### +sub phasetwo { + + my ($r,$source,$target,$style,$distarget,$batch)=@_; + $source=~s/\/+/\//g; + $target=~s/\/+/\//g; +# +# Unless trying to get rid of something, check name validity +# + unless ($env{'form.obsolete'}) { + if ($target=~/(\_\_\_|\&\&\&|\:\:\:)/) { + $r->print(''. + &mt('Unsupported character combination [_1] in filename, FAIL.',"'.$1.'"). + ''); + return 0; + } + unless ($target=~/\.(\w+)$/) { + $r->print(''.&mt('No valid extension found in filename, FAIL').''); + return 0; + } + if ($target=~/\.(\d+)\.(\w+)$/) { + $r->print(''.&mt('Filename of resource contains internal version number. Cannot publish such resources, FAIL').''); + return 0; } } -} else { - $scrout.='

Private Publication - did not synchronize database'; - print $logfile "\nPrivate: Did not synchronize data into ". - "SQL metadata database"; -} -# ----------------------------------------------------------- Copy old versions - -if (-e $target) { - my $filename; - my $maxversion=0; - $target=~/(.*)\/([^\/]+)\.(\w+)$/; - my $srcf=$2; - my $srct=$3; - my $srcd=$1; - unless ($srcd=~/^\/home\/httpd\/html\/res/) { - print $logfile "\nPANIC: Target dir is ".$srcd; - return "Invalid target directory, FAIL"; +# +# End name check +# + $distarget=~s/\/+/\//g; + my $logfile; + unless ($logfile=Apache::File->new('>>'.$source.'.log')) { + $r->print( + ''. + &mt('No write permission to user directory, FAIL').''); + return 0; } - opendir(DIR,$srcd); - while ($filename=readdir(DIR)) { - if ($filename=~/$srcf\.(\d+)\.$srct$/) { - $maxversion=($1>$maxversion)?$1:$maxversion; - } + + if ($source =~ /\.rights$/) { + $r->print('

'.&mt('Warning: It can take up to 1 hour for rights changes to fully propagate.').'

'); } - closedir(DIR); - $maxversion++; - $scrout.='

Creating old version '.$maxversion; - print $logfile "\nCreating old version ".$maxversion; - my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct; + print $logfile + "\n================= Publish ".localtime()." Phase Two ================\n".$env{'user.name'}.':'.$env{'user.domain'}."\n"; + + %metadatafields=(); + %metadatakeys=(); + &metaeval(&unescape($env{'form.allmeta'})); + + $metadatafields{'title'}=$env{'form.title'}; + $metadatafields{'author'}=$env{'form.author'}; + $metadatafields{'subject'}=$env{'form.subject'}; + $metadatafields{'notes'}=$env{'form.notes'}; + $metadatafields{'abstract'}=$env{'form.abstract'}; + $metadatafields{'mime'}=$env{'form.mime'}; + $metadatafields{'language'}=$env{'form.language'}; + $metadatafields{'creationdate'}=$env{'form.creationdate'}; + $metadatafields{'lastrevisiondate'}=$env{'form.lastrevisiondate'}; + $metadatafields{'owner'}=$env{'form.owner'}; + $metadatafields{'copyright'}=$env{'form.copyright'}; + $metadatafields{'standards'}=$env{'form.standards'}; + $metadatafields{'lowestgradelevel'}=$env{'form.lowestgradelevel'}; + $metadatafields{'highestgradelevel'}=$env{'form.highestgradelevel'}; + $metadatafields{'customdistributionfile'}= + $env{'form.customdistributionfile'}; + $metadatafields{'sourceavail'}=$env{'form.sourceavail'}; + $metadatafields{'obsolete'}=$env{'form.obsolete'}; + $metadatafields{'obsoletereplacement'}= + $env{'form.obsoletereplacement'}; + $metadatafields{'dependencies'}=$env{'form.dependencies'}; + $metadatafields{'modifyinguser'}=$env{'user.name'}.':'. + $env{'user.domain'}; + $metadatafields{'authorspace'}=$cuname.':'.$cudom; + $metadatafields{'domain'}=$cudom; + + my $allkeywords=$env{'form.addkey'}; + if (exists($env{'form.keywords'})) { + if (ref($env{'form.keywords'})) { + $allkeywords .= ','.join(',',@{$env{'form.keywords'}}); + } else { + $allkeywords .= ','.$env{'form.keywords'}; + } + } + $allkeywords=~s/[\"\']//g; + $allkeywords=~s/\s*[\;\,]\s*/\,/g; + $allkeywords=~s/\s+/ /g; + $allkeywords=~s/^[ \,]//; + $allkeywords=~s/[ \,]$//; + $metadatafields{'keywords'}=$allkeywords; + +# check if custom distribution file is specified + if ($metadatafields{'copyright'} eq 'custom') { + my $file=$metadatafields{'customdistributionfile'}; + unless ($file=~/\.rights$/) { + $r->print( + ''.&mt('No valid custom distribution rights file specified, FAIL'). + ''); + return 0; + } + } + { + print $logfile "\nWrite metadata file for ".$source; + my $mfh; + unless ($mfh=Apache::File->new('>'.$source.'.meta')) { + $r->print( + ''.&mt('Could not write metadata, FAIL'). + ''); + return 0; + } + foreach (sort keys %metadatafields) { + unless ($_=~/\./) { + my $unikey=$_; + $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.'.'.$_}; + $value=~s/\"/\'\'/g; + print $mfh ' '.$_.'="'.$value.'"'; + } + print $mfh '>'. + &HTML::Entities::encode($metadatafields{$unikey},'<>&"') + .''; + } + } + $r->print('

'.&mt('Wrote Metadata').'

'); + print $logfile "\nWrote metadata"; + } + +# -------------------------------- Synchronize entry with SQL metadata database + + $metadatafields{'url'} = $distarget; + $metadatafields{'version'} = 'current'; + + my ($error,$success) = &store_metadata(%metadatafields); + if ($success) { + $r->print('

'.&mt('Synchronized SQL metadata database').'

'); + print $logfile "\nSynchronized SQL metadata database"; + } else { + $r->print($error); + print $logfile "\n".$error; + } +# --------------------------------------------- Delete author resource messages + my $delresult=&Apache::lonmsg::del_url_author_res_msg($target); + $r->print('

'.&mt('Removing error messages:').' '.$delresult.'

'); + print $logfile "\nRemoving error messages: $delresult"; +# ----------------------------------------------------------- Copy old versions + + if (-e $target) { + my $filename; + my $maxversion=0; + $target=~/(.*)\/([^\/]+)\.(\w+)$/; + my $srcf=$2; + my $srct=$3; + my $srcd=$1; + my $docroot = $Apache::lonnet::perlvar{'lonDocRoot'}; + unless ($srcd=~/^\Q$docroot\E\/res/) { + print $logfile "\nPANIC: Target dir is ".$srcd; + $r->print( + "".&mt('Invalid target directory, FAIL').""); + return 0; + } + opendir(DIR,$srcd); + while ($filename=readdir(DIR)) { + if (-l $srcd.'/'.$filename) { + unlink($srcd.'/'.$filename); + unlink($srcd.'/'.$filename.'.meta'); + } else { + if ($filename=~/^\Q$srcf\E\.(\d+)\.\Q$srct\E$/) { + $maxversion=($1>$maxversion)?$1:$maxversion; + } + } + } + closedir(DIR); + $maxversion++; + $r->print('

'.&mt('Creating old version [_1]',$maxversion).'

'); + print $logfile "\nCreating old version ".$maxversion."\n"; + + my $copyfile=$srcd.'/'.$srcf.'.'.$maxversion.'.'.$srct; + if (copy($target,$copyfile)) { print $logfile "Copied old target to ".$copyfile."\n"; - $scrout.='

Copied old target file'; + $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied old target file'))); } else { print $logfile "Unable to write ".$copyfile.':'.$!."\n"; - return "Failed to copy old target, $!, FAIL"; + $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Failed to copy old target').", $!",1)); + return 0; } - + # --------------------------------------------------------------- Copy Metadata $copyfile=$copyfile.'.meta'; - + if (copy($target.'.meta',$copyfile)) { print $logfile "Copied old target metadata to ".$copyfile."\n"; - $scrout.='

Copied old metadata'; + $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied old metadata'))); } else { print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; if (-e $target.'.meta') { - return - "Failed to write old metadata copy, $!, FAIL"; + $r->print(&Apache::lonhtmlcommon::confirm_success( + &mt('Failed to write old metadata copy').", $!",1)); + return 0; } } - - -} else { - $scrout.='

Initial version'; - print $logfile "\nInitial version"; -} + + + } else { + $r->print('

'.&mt('Initial version').'

'); + print $logfile "\nInitial version"; + } # ---------------------------------------------------------------- Write Source - my $copyfile=$target; - - my @parts=split(/\//,$copyfile); - my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; - - my $count; - for ($count=5;$count<$#parts;$count++) { - $path.="/$parts[$count]"; - if ((-e $path)!=1) { - print $logfile "\nCreating directory ".$path; - $scrout.='

Created directory '.$parts[$count]; - mkdir($path,0777); - } - } - - if (copy($source,$copyfile)) { - print $logfile "Copied original source to ".$copyfile."\n"; - $scrout.='

Copied source file'; - } else { - print $logfile "Unable to write ".$copyfile.':'.$!."\n"; - return "Failed to copy source, $!, FAIL"; + my $copyfile=$target; + + my @parts=split(/\//,$copyfile); + my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; + + my $count; + for ($count=5;$count<$#parts;$count++) { + $path.="/$parts[$count]"; + if ((-e $path)!=1) { + print $logfile "\nCreating directory ".$path; + mkdir($path,0777); + $r->print('

' + .&mt('Created directory [_1]' + ,''.$parts[$count].'') + .'

' + ); } - + } + + if (copy($source,$copyfile)) { + print $logfile "\nCopied original source to ".$copyfile."\n"; + $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied source file'))); + } else { + print $logfile "\nUnable to write ".$copyfile.':'.$!."\n"; + $r->print(&Apache::lonhtmlcommon::confirm_success( + &mt('Failed to copy source').", $!",1)); + return 0; + } + +# ---------------------------------------------- Delete local tmp-preview files + unlink($copyfile.'.tmp'); # --------------------------------------------------------------- Copy Metadata - $copyfile=$copyfile.'.meta'; - - if (copy($source.'.meta',$copyfile)) { - print $logfile "Copied original metadata to ".$copyfile."\n"; - $scrout.='

Copied metadata'; - } else { - print $logfile "Unable to write metadata ".$copyfile.':'.$!."\n"; - return - "Failed to write metadata copy, $!, FAIL"; - } + $copyfile=$copyfile.'.meta'; + + if (copy($source.'.meta',$copyfile)) { + print $logfile "\nCopied original metadata to ".$copyfile."\n"; + $r->print(&Apache::lonhtmlcommon::confirm_success(&mt('Copied metadata'))); + } else { + print $logfile "\nUnable to write metadata ".$copyfile.':'.$!."\n"; + $r->print(&Apache::lonhtmlcommon::confirm_success( + &mt('Failed to write metadata copy').", $!",1)); + return 0; + } + $r->rflush; -# --------------------------------------------------- Send update notifications +# ------------------------------------------------------------- Trigger updates + push(@{$modified_urls},[$target,$source]); + unless ($registered_cleanup) { + my $handlers = $r->get_handlers('PerlCleanupHandler'); + $r->set_handlers('PerlCleanupHandler' => [\¬ify,@{$handlers}]); + $registered_cleanup=1; + } -{ +# ---------------------------------------------------------- Clear local caches + my $thisdistarget=$target; + $thisdistarget=~s/^\Q$docroot\E//; + &Apache::lonnet::devalidate_cache_new('resversion',$target); + &Apache::lonnet::devalidate_cache_new('meta', + &Apache::lonnet::declutter($thisdistarget)); + +# ------------------------------------------------------------- Everything done + $logfile->close(); + $r->print('

'.&mt('Done').'

'); - my $filename; - - $target=~/(.*)\/([^\/]+)$/; - my $srcf=$2; - opendir(DIR,$1); - while ($filename=readdir(DIR)) { - if ($filename=~/$srcf\.(\w+)$/) { - my $subhost=$1; - if ($subhost ne 'meta') { - $scrout.='

Notifying host '.$subhost.':'; - print $logfile "\nNotifying host '.$subhost.':'"; - my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); - $scrout.=$reply; - print $logfile $reply; - } - } +# ------------------------------------------------ Provide link to new resource + unless ($batch) { + + my $thissrc=&Apache::loncfile::url($source); + my $thissrcdir=$thissrc; + $thissrcdir=~s/\/[^\/]+$/\//; + + $r->print( + &Apache::lonhtmlcommon::actionbox([ + ''. + &mt('View Published Version'). + '', + ''. + &mt('Back to Source'). + '', + ''. + &mt('Back to Source Directory'). + '']) + ); } - closedir(DIR); - + return 1; } +# =============================================================== Notifications +sub notify { +# --------------------------------------------------- Send update notifications + foreach my $targetsource (@{$modified_urls}){ + my ($target,$source)=@{$targetsource}; + my $logfile=Apache::File->new('>>'.$source.'.log'); + print $logfile "\nCleanup phase: Notifications\n"; + my @subscribed=&get_subscribed_hosts($target); + foreach my $subhost (@subscribed) { + print $logfile "\nNotifying host ".$subhost.':'; + my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); + print $logfile $reply; + } # ---------------------------------------- Send update notifications, meta only - -{ - - my $filename; - - $target=~/(.*)\/([^\/]+)$/; - my $srcf=$2.'.meta'; - opendir(DIR,$1); - while ($filename=readdir(DIR)) { - if ($filename=~/$srcf\.(\w+)$/) { - my $subhost=$1; - if ($subhost ne 'meta') { - $scrout.= - '

Notifying host for metadata only '.$subhost.':'; - print $logfile - "\nNotifying host for metadata only '.$subhost.':'"; - my $reply=&Apache::lonnet::critical( - 'update:'.$target.'.meta',$subhost); - $scrout.=$reply; - print $logfile $reply; - } - } + my @subscribedmeta=&get_subscribed_hosts("$target.meta"); + foreach my $subhost (@subscribedmeta) { + print $logfile "\nNotifying host for metadata only ".$subhost.':'; + my $reply=&Apache::lonnet::critical('update:'.$target.'.meta', + $subhost); + print $logfile $reply; + } +# --------------------------------------------------- Notify subscribed courses + my %courses=&coursedependencies($target); + my $now=time; + foreach (keys %courses) { + print $logfile "\nNotifying course ".$_.':'; + my ($cdom,$cname)=split(/\_/,$_); + my $reply=&Apache::lonnet::cput + ('versionupdate',{$target => $now},$cdom,$cname); + print $logfile $reply; + } + print $logfile "\n============ Done ============\n"; + $logfile->close(); } - closedir(DIR); - + if ($lock) { &Apache::lonnet::remove_lock($lock); } + return OK; } -# ------------------------------------------------ Provide link to new resource - - my $thisdistarget=$target; - $thisdistarget=~s/^$docroot//; - - my $thissrc=$source; - $thissrc=~s/^\/home\/(\w+)\/public_html/\/priv\/$1/; +######################################### - my $thissrcdir=$thissrc; - $thissrcdir=~s/\/[^\/]+$/\//; +sub batchpublish { + my ($r,$srcfile,$targetfile)=@_; + #publication pollutes %env with form.* values + my %oldenv=%env; + $srcfile=~s/\/+/\//g; + $targetfile=~s/\/+/\//g; + $srcfile=~s/\/+/\//g; + my $docroot=$r->dir_config('lonDocRoot'); + my $thisdistarget=$targetfile; + $thisdistarget=~s/^\Q$docroot\E//; - return $warning.$scrout. - '

View Target'. - '

Back to Source'. - '

Back to Source Directory'; -} - -# ================================================================ Main Handler + %metadatafields=(); + %metadatakeys=(); + $srcfile=~/\.(\w+)$/; + my $thistype=$1; -sub handler { - my $r=shift; - if ($r->header_only) { - $r->content_type('text/html'); - $r->send_http_header; - return OK; - } - -# Get query string for limited number of parameters - - foreach (split(/&/,$ENV{'QUERY_STRING'})) { - my ($name, $value) = split(/=/,$_); - $value =~ tr/+/ /; - $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - if ($name eq 'filename') { - unless ($ENV{'form.'.$name}) { - $ENV{'form.'.$name}=$value; - } - } + my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); + + $r->print('

' + .&mt('Publishing [_1]',&Apache::loncfile::display($srcfile)) + .'

' + ); + +# phase one takes +# my ($source,$target,$style,$batch)=@_; + my ($outstring,$error)=&publish($srcfile,$targetfile,$thisembstyle,1); + $r->print('

'.$outstring.'

'); +# phase two takes +# my ($source,$target,$style,$distarget,batch)=@_; +# $env{'form.allmeta'},$env{'form.title'},$env{'form.author'},... + if (!$error) { + $r->print('

'); + &phasetwo($r,$srcfile,$targetfile,$thisembstyle,$thisdistarget,1); + $r->print('

'); } - - -# -------------------------------------------------------------- Check filename - - my $fn=$ENV{'form.filename'}; - - - unless ($fn) { - $r->log_reason($cuname.' at '.$cudom. - ' trying to publish empty filename', $r->filename); - return HTTP_NOT_FOUND; - } - - ($cuname,$cudom)= - &Apache::loncacc::constructaccess($fn,$r->dir_config('lonDefDomain')); - unless (($cuname) && ($cudom)) { - $r->log_reason($cuname.' at '.$cudom. - ' trying to publish file '.$ENV{'form.filename'}. - ' ('.$fn.') - not authorized', - $r->filename); - return HTTP_NOT_ACCEPTABLE; - } - - unless (&Apache::lonnet::homeserver($cuname,$cudom) - eq $r->dir_config('lonHostID')) { - $r->log_reason($cuname.' at '.$cudom. - ' trying to publish file '.$ENV{'form.filename'}. - ' ('.$fn.') - not homeserver ('. - &Apache::lonnet::homeserver($cuname,$cudom).')', - $r->filename); - return HTTP_NOT_ACCEPTABLE; - } - - $fn=~s/^http\:\/\/[^\/]+//; - $fn=~s/^\/\~(\w+)/\/home\/$1\/public_html/; - - my $targetdir=''; - $docroot=$r->dir_config('lonDocRoot'); - if ($1 ne $cuname) { - $r->log_reason($cuname.' at '.$cudom. - ' trying to publish unowned file '.$ENV{'form.filename'}. - ' ('.$fn.')', - $r->filename); - return HTTP_NOT_ACCEPTABLE; - } else { - $targetdir=$docroot.'/res/'.$cudom; - } - - - unless (-e $fn) { - $r->log_reason($cuname.' at '.$cudom. - ' trying to publish non-existing file '.$ENV{'form.filename'}. - ' ('.$fn.')', - $r->filename); - return HTTP_NOT_FOUND; - } - -unless ($ENV{'form.phase'} eq 'two') { - -# --------------------------------- File is there and owned, init lookup tables - - %addid=(); - - { - my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab'); - while (<$fh>=~/(\w+)\s+(\w+)/) { - $addid{$1}=$2; - } - } - - %nokey=(); - - { - my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab'); - while (<$fh>) { - my $word=$_; - chomp($word); - $nokey{$word}=1; - } - } - + %env=%oldenv; + return ''; } -# ----------------------------------------------------------- Start page output - - $r->content_type('text/html'); - $r->send_http_header; - - $r->print('LON-CAPA Publishing'); - $r->print( - ''); - my $thisfn=$fn; - -# ------------------------------------------------------------- Individual file - { - $thisfn=~/\.(\w+)$/; - my $thistype=$1; - my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); - - my $thistarget=$thisfn; - - $thistarget=~s/^\/home/$targetdir/; - $thistarget=~s/\/public\_html//; - - my $thisdistarget=$thistarget; - $thisdistarget=~s/^$docroot//; - - my $thisdisfn=$thisfn; - $thisdisfn=~s/^\/home\/$cuname\/public_html\///; - - $r->print('

Publishing '. - &Apache::loncommon::filedescription($thistype).' '. - $thisdisfn.'

Target: '.$thisdistarget.'

'); - - if (($cuname ne $ENV{'user.name'}) || ($cudom ne $ENV{'user.domain'})) { - $r->print('

Co-Author: '.$cuname.' at '.$cudom. - '

'); - } - - if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') { - $r->print('
Diffs with Current Version

'); - } - -# ------------ We are publishing from $thisfn to $thistarget with $thisembstyle - - unless ($ENV{'form.phase'} eq 'two') { - $r->print( - '

'.&publish($thisfn,$thistarget,$thisembstyle)); - } else { - $r->print( - '
'.&phasetwo($thisfn,$thistarget,$thisembstyle,$thisdistarget)); - } - - } - $r->print(''); +######################################### - return OK; +sub publishdirectory { + my ($r,$fn,$thisdisfn)=@_; + $fn=~s/\/+/\//g; + $thisdisfn=~s/\/+/\//g; + my $thisdisresdir=$thisdisfn; + $thisdisresdir=~s/^\/priv\//\/res\//; + 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() + .&Apache::lonhtmlcommon::row_title(&mt('Target')) + .''.$thisdisresdir.'' + ); + + my $dirptr=16384; # Mask indicating a directory in stat.cmode. + unless ($env{'form.phase'} eq 'two') { +# ask user what they want + $r->print(&Apache::lonhtmlcommon::row_closure() + .&Apache::lonhtmlcommon::row_title(&mt('Options')) + ); + $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') + ); + $r->print(&Apache::lonhtmlcommon::row_closure(1) + .&Apache::lonhtmlcommon::end_pick_box() + .'
' + ); + $lock=0; + } else { + $r->print(&Apache::lonhtmlcommon::row_closure(1) + .&Apache::lonhtmlcommon::end_pick_box() + ); + unless ($lock) { $lock=&Apache::lonnet::set_lock(&mt('Publishing [_1]',$fn)); } +# actually publish things + opendir(DIR,$fn); + my @files=sort(readdir(DIR)); + foreach my $filename (@files) { + my ($cdev,$cino,$cmode,$cnlink, + $cuid,$cgid,$crdev,$csize, + $catime,$cmtime,$cctime, + $cblksize,$cblocks)=stat($fn.'/'.$filename); + + my $extension=''; + if ($filename=~/\.(\w+)$/) { $extension=$1; } + if ($cmode&$dirptr) { + if (($filename!~/^\./) && ($env{'form.pubrec'})) { + &publishdirectory($r,$fn.'/'.$filename,$thisdisfn.'/'.$filename); + } + } elsif ((&Apache::loncommon::fileembstyle($extension) ne 'hdn') && + ($filename!~/^[\#\.]/) && ($filename!~/\~$/)) { +# find out publication status and/or exiting metadata + my $publishthis=0; + if (-e $resdir.'/'.$filename) { + my ($rdev,$rino,$rmode,$rnlink, + $ruid,$rgid,$rrdev,$rsize, + $ratime,$rmtime,$rctime, + $rblksize,$rblocks)=stat($resdir.'/'.$filename); + if (($rmtime<$cmtime) || ($env{'form.forcerepub'})) { +# previously published, modified now + $publishthis=1; + } + my $meta_cmtime = (stat($fn.'/'.$filename.'.meta'))[9]; + my $meta_rmtime = (stat($resdir.'/'.$filename.'.meta'))[9]; + if ( $meta_rmtime<$meta_cmtime ) { + $publishthis=1; + } + } else { +# never published + $publishthis=1; + } + + if ($publishthis) { + &batchpublish($r,$fn.'/'.$filename,$resdir.'/'.$filename); + } else { + $r->print('
'.&mt('Skipping').' '.$filename.'
'); + } + $r->rflush(); + } + } + closedir(DIR); + } } -1; -__END__ +######################################### +# publish a default.meta file -=head1 NAME +sub defaultmetapublish { + my ($r,$fn,$cuname,$cudom)=@_; + unless (-e $fn) { + return HTTP_NOT_FOUND; + } + my $target=$fn; + $target=~s/^\Q$Apache::lonnet::perlvar{'lonDocRoot'}\E\/priv\//\Q$Apache::lonnet::perlvar{'lonDocRoot'}\E\/res\//; -Apache::lonpublisher - Publication Handler -=head1 SYNOPSIS + &Apache::loncommon::content_type($r,'text/html'); + $r->send_http_header; -Invoked by /etc/httpd/conf/srm.conf: + $r->print(&Apache::loncommon::start_page('Metadata Publication')); - - PerlAccessHandler Apache::lonacc - SetHandler perl-script - PerlHandler Apache::lonpublisher - ErrorDocument 403 /adm/login - ErrorDocument 404 /adm/notfound.html - ErrorDocument 406 /adm/unauthorized.html - ErrorDocument 500 /adm/errorhandler - +# ---------------------------------------------------------------- Write Source + my $copyfile=$target; + + my @parts=split(/\//,$copyfile); + my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; + + my $count; + for ($count=5;$count<$#parts;$count++) { + $path.="/$parts[$count]"; + if ((-e $path)!=1) { + mkdir($path,0777); + $r->print('

' + .&mt('Created directory [_1]' + ,''.$parts[$count].'') + .'

' + ); + } + } + + if (copy($fn,$copyfile)) { + $r->print('

'.&mt('Copied source file').'

'); + } else { + return "". + &mt('Failed to copy source').", $!, ".&mt('FAIL').""; + } -=head1 INTRODUCTION +# --------------------------------------------------- Send update notifications -This module publishes a file. This involves gathering metadata, -versioning the file, copying file from construction space to -publication space, and copying metadata from construction space -to publication space. + my @subscribed=&get_subscribed_hosts($target); + foreach my $subhost (@subscribed) { + $r->print('

'.&mt('Notifying host').' '.$subhost.':');$r->rflush; + my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); + $r->print($reply.'


');$r->rflush; + } +# ------------------------------------------------------------------- Link back + $r->print("".&mt('Back to Metadata').''); + $r->print(&Apache::loncommon::end_page()); + return OK; +} +######################################### -This is part of the LearningOnline Network with CAPA project -described at http://www.lon-capa.org. +=pod -=head1 HANDLER SUBROUTINE +=item B -This routine is called by Apache and mod_perl. +A basic outline of the handler subroutine follows. =over 4 =item * -Get query string for limited number of parameters +Get query string for limited number of parameters. =item * -Check filename +Check filename. =item * -File is there and owned, init lookup tables +File is there and owned, init lookup tables. =item * -Start page output +Start page output. =item * -Individual file +Evaluate individual file, and then output information. =item * -publish from $thisfn to $thistarget with $thisembstyle +Publishing from $thisfn to $thistarget with $thisembstyle. =back -=head1 OTHER SUBROUTINES +=cut -=over 4 +######################################### +######################################### +sub handler { + my $r=shift; -=item * + if ($r->header_only) { + &Apache::loncommon::content_type($r,'text/html'); + $r->send_http_header; + return OK; + } -metaeval() : Evaluate string with metadata +# Get query string for limited number of parameters -=item * + &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, + ['filename']); -metaread() : Read a metadata file +# -------------------------------------- Flag and buffer for registered cleanup + $registered_cleanup=0; + @{$modified_urls}=(); +# -------------------------------------------------------------- Check filename -=item * + my $fn=&unescape($env{'form.filename'}); + ($cuname,$cudom)=&Apache::lonnet::constructaccess($fn); +# ----------------------------------------------------- Do we have permissions? + unless (($cuname) && ($cudom)) { + $r->log_reason($env{'user.name'}.' at '.$env{'user.domain'}. + ' trying to publish file '.$env{'form.filename'}. + ' - not authorized', + $r->filename); + return HTTP_NOT_ACCEPTABLE; + } +# ----------------------------------------------------------------- Get docroot + $docroot=$r->dir_config('lonDocRoot'); -sqltime() : convert 'time' format into a datetime sql format -=item * +# special publication: default.meta file + if ($fn=~/\/default.meta$/) { + return &defaultmetapublish($r,$fn,$cuname,$cudom); + } + $fn=~s/\.meta$//; + +# sanity test on the filename + + unless ($fn) { + $r->log_reason($cuname.' at '.$cudom. + ' trying to publish empty filename', $r->filename); + return HTTP_NOT_FOUND; + } + + unless (-e $docroot.$fn) { + $r->log_reason($cuname.' at '.$cudom. + ' trying to publish non-existing file '. + $env{'form.filename'}.' ('.$fn.')', + $r->filename); + return HTTP_NOT_FOUND; + } -textfield() : form field +# -------------------------------- File is there and owned, init lookup tables. -=item * + %addid=(); + + { + my $fh=Apache::File->new($r->dir_config('lonTabDir').'/addid.tab'); + while (<$fh>=~/(\w+)\s+(\w+)/) { + $addid{$1}=$2; + } + } -hiddenfield() : form field + %nokey=(); -=item * + { + my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab'); + while (<$fh>) { + my $word=$_; + chomp($word); + $nokey{$word}=1; + } + } -selectbox() : form field +# ---------------------------------------------------------- Start page output. -=item * + &Apache::loncommon::content_type($r,'text/html'); + $r->send_http_header; + + # Breadcrumbs + &Apache::lonhtmlcommon::clear_breadcrumbs(); + &Apache::lonhtmlcommon::add_breadcrumb({ + 'text' => 'Authoring Space', + 'href' => &Apache::loncommon::authorspace($fn), + }); + &Apache::lonhtmlcommon::add_breadcrumb({ + 'text' => 'Resource Publication', + 'href' => '', + }); + + my $js=''; + $r->print(&Apache::loncommon::start_page('Resource Publication',$js) + .&Apache::lonhtmlcommon::breadcrumbs() + .&Apache::loncommon::head_subbox( + &Apache::loncommon::CSTR_pageheader($docroot.$fn)) + ); + + my $thisdisfn=&HTML::Entities::encode($fn,'<>&"'); + my $thistarget=$fn; + $thistarget=~s/^\/priv\//\/res\//; + my $thisdistarget=&HTML::Entities::encode($thistarget,'<>&"'); + + if ($fn=~/\/$/) { +# -------------------------------------------------------- This is a directory + &publishdirectory($r,$docroot.$fn,$thisdisfn); + $r->print( + '

'. + &Apache::lonhtmlcommon::actionbox([ + ''.&mt('Return to Directory').''])); + } else { +# ---------------------- Evaluate individual file, and then output information. + $fn=~/\.(\w+)$/; + my $thistype=$1; + my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); + if ($thistype eq 'page') { $thisembstyle = 'rat'; } + + $r->print('

' + .&mt('Publishing [_1]' + ,''.$thisdisfn.'') + .'

' + ); + + $r->print('

'.&mt('Resource Details').'

'); + + $r->print(&Apache::lonhtmlcommon::start_pick_box()); + + $r->print(&Apache::lonhtmlcommon::row_title(&mt('Type')) + .&Apache::loncommon::filedescription($thistype) + .&Apache::lonhtmlcommon::row_closure() + ); + + $r->print(&Apache::lonhtmlcommon::row_title(&mt('Link to Resource')) + .'' + ); + $r->print(< +$thisdisfn +ENDCAPTION + $r->print('' + .&Apache::lonhtmlcommon::row_closure() + ); + + $r->print(&Apache::lonhtmlcommon::row_title(&mt('Target')) + .''.$thisdistarget.'' + ); + if (($cuname ne $env{'user.name'})||($cudom ne $env{'user.domain'})) { + $r->print(&Apache::lonhtmlcommon::row_closure() + .&Apache::lonhtmlcommon::row_title(&mt('Co-Author')) + .'' + .&Apache::loncommon::plainname($cuname,$cudom) .' ('.$cuname.':'.$cudom.')' + .'' + ); + } -urlfixup() : fixup URL (Publication Step One) + if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') { + $r->print(&Apache::lonhtmlcommon::row_closure() + .&Apache::lonhtmlcommon::row_title(&mt('Diffs'))); + $r->print(< +ENDDIFF + $r->print(&mt('Diffs with Current Version').''); + } + + $r->print(&Apache::lonhtmlcommon::row_closure(1) + .&Apache::lonhtmlcommon::end_pick_box() + ); + +# ---------------------- Publishing from $fn to $thistarget with $thisembstyle. -=item * + unless ($env{'form.phase'} eq 'two') { +# ---------------------------------------------------------- Parse for problems + my ($warningcount,$errorcount); + if ($thisembstyle eq 'ssi') { + ($warningcount,$errorcount)=&checkonthis($r,$fn); + } + unless ($errorcount) { + my ($outstring,$error)= + &publish($docroot.$fn,$docroot.$thistarget,$thisembstyle); + $r->print($outstring); + } else { + $r->print('

'. + &mt('The document contains errors and cannot be published.'). + '

'); + } + } else { + &phasetwo($r,$docroot.$fn,$docroot.$thistarget,$thisembstyle,$thisdistarget); + } + } + $r->print(&Apache::loncommon::end_page()); -publish() : publish (Publication Step One) + return OK; +} -=item * +1; +__END__ -phasetwo() : render second interface showing status of publication steps -(Publication Step Two) +=pod =back =cut +
'; + } else { + $keywordout .= ''; + } + $keywordout.='