--- loncom/publisher/lonpublisher.pm 2000/11/30 10:11:47 1.4 +++ loncom/publisher/lonpublisher.pm 2002/10/07 13:50:36 1.99 @@ -1,158 +1,1569 @@ # The LearningOnline Network with CAPA # Publication Handler +# +# $Id: lonpublisher.pm,v 1.99 2002/10/07 13:50:36 www Exp $ +# +# Copyright Michigan State University Board of Trustees +# +# This file is part of the LearningOnline Network with CAPA (LON-CAPA). +# +# LON-CAPA is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# LON-CAPA is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with LON-CAPA; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# /home/httpd/html/adm/gpl.txt +# +# http://www.lon-capa.org/ +# # # (TeX Content Handler # # 05/29/00,05/30,10/11 Gerd Kortemeyer) # -# 11/28,11/29,11/30 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 +# YEAR=2002 +# 1/16,1/17 Scott Harrison +# 1/17 Gerd Kortemeyer +# +### + +############################################################################### +## ## +## ORGANIZATION OF THIS PERL MODULE ## +## ## +## 1. Modules used by this module ## +## 2. Various subroutines ## +## 3. Publication Step One ## +## 4. Phase Two ## +## 5. Main Handler ## +## ## +############################################################################### + + +###################################################################### +###################################################################### + +=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 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. + +=over 4 + +=cut + +###################################################################### +###################################################################### + package Apache::lonpublisher; +# ------------------------------------------------- modules used by this module use strict; use Apache::File; +use File::Copy; use Apache::Constants qw(:common :http :methods); -use HTML::TokeParser; +use HTML::LCParser; use Apache::lonxml; +use Apache::lonhomework; +use Apache::loncacc; +use DBI; +use Apache::lonnet(); +use Apache::loncommon(); +use Apache::lonmysql; my %addid; +my %nokey; + +my %metadatafields; +my %metadatakeys; + +my $docroot; + +my $cuname; +my $cudom; + +######################################### +######################################### + +=pod + +=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 + +######################################### +######################################### +sub metaeval { + my $metastring=shift; + + 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; + 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); + } + } + } +} + +######################################### +######################################### + +=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)=@_; + unless (-e $fn) { + print($logfile 'No file '.$fn."\n"); + return '
No file: '.$fn.''; + } + print($logfile 'Processing '.$fn."\n"); + my $metastring; + { + my $metafh=Apache::File->new($fn); + $metastring=join('',<$metafh>); + } + &metaeval($metastring); + return '
Processed file: '.$fn.''; +} + +######################################### +######################################### + +=pod + +=item B + +Convert 'time' format into a datetime sql format + +Parameters: + +=over 4 + +=item I<$timef> + +Seconds since 00:00:00 UTC, January 1, 1970. + +=back + +Returns: + +=over 4 + +=item Scalar string + +MySQL-compatible datetime string. + +=back + +=cut + +######################################### +######################################### +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"; +} + + +######################################### +######################################### + +=pod + +=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:
". + ''; +} + +sub hiddenfield { + my ($name,$value)=@_; + return "\n".''; +} + +sub selectbox { + my ($title,$name,$value,$functionref,@idlist)=@_; + my $uctitle=uc($title); + my $selout="\n

$uctitle:". + "
".''; +} + +######################################### +######################################### + +=pod + +=item B + +Fix up a url? First step of publication + +=cut + +######################################### +######################################### +sub urlfixup { + my ($url,$target)=@_; + unless ($url) { return ''; } + #javascript code needs no fixing + if ($url =~ /^javascript:/i) { return $url; } + 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//; + } + } + if ($url=~/^http\:\/\//) { return $url; } + $url=~s/\~$cuname/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); + } + return $url; +} + +######################################### +######################################### + +=pod + +=item B + +Currently undocumented + +=cut + +######################################### +######################################### +sub set_allow { + my ($allow,$logfile,$target,$tag,$oldurl)=@_; + 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:/i) && + ($newurl !~ /^\#/)) { + $$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); + while ($filename=readdir(DIR)) { + if ($filename=~/$srcf\.(\w+)$/) { + my $subhost=$1; + if (($subhost ne 'meta' && $subhost ne 'subscription') && + ($subhost ne $Apache::lonnet::perlvar{'lonHostID'})) { + push(@subscribed,$subhost); + } + } + } + closedir(DIR); + my $sh; + if ( $sh=Apache::File->new("$target.subscription") ) { + &Apache::lonnet::logthis("opened $target.subscription"); + while (my $subline=<$sh>) { + &Apache::lonnet::logthis("Trying $subline"); + if ($subline =~ /(^\w+):/) { + if ($1 ne $Apache::lonnet::perlvar{'lonHostID'}) { + push(@subscribed,$1); + } + } else { + &Apache::lonnet::logthis("No Match for $subline"); + } + } + } else { + &Apache::lonnet::logthis("Unable to open $target.subscription"); + } + &Apache::lonnet::logthis("Got list of ".join(':',@subscribed)); + 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 $parser=HTML::LCParser->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; + } + } + } + } + } + return ($needsfixup,$maxid,$maxindex); +} + +######################################### +######################################### + +=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 =~ /(.*)$tag(.*)/) { + #&Apache::lonnet::logthis('Got a winner with leftovers ::'.$2); + #&Apache::lonnet::logthis('Result is :'.$1); + $result=$1; + my $redo=$tag.$2; + 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)=&get_max_ids_indices(\$content); + + 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; + $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; + } + 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 my $type ('src','href','background','bgimg') { + foreach my $key (keys(%parms)) { + if ($key =~ /^$type$/i) { + $parms{$key}=&set_allow(\%allow,$logfile, + $target,$tag, + $parms{$key}); + } + } + } + # probably a image type

Dependencies

'; + my $allowstr=''; + foreach (sort(keys(%allow))) { + my $thisdep=$_; + if ($thisdep !~ /[^\s]/) { next; } + unless ($style eq 'rat') { + $allowstr.="\n".''; + } + $scrout.='
'; + unless ($thisdep=~/\*/) { + $scrout.=''; + } + $scrout.=''.$thisdep.''; + unless ($thisdep=~/\*/) { + $scrout.=''; + if ( + &Apache::lonnet::getfile($Apache::lonnet::perlvar{'lonDocRoot'}.'/'. + $thisdep.'.meta') eq '-1') { + $scrout.= ' - Currently not available'. + ''; + } else { + my %temphash=(&Apache::lonnet::declutter($target).'___'. + &Apache::lonnet::declutter($thisdep).'___usage' + => time); + $thisdep=~/^\/res\/(\w+)\/(\w+)\//; + if ((defined($1)) && (defined($2))) { + &Apache::lonnet::put('nohist_resevaldata',\%temphash, + $1,$2); + } + } + } } - { - 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"; + $outstring=~s/\n*(\<\/[^\>]+\>)\s*$/$allowstr\n$1\n/s; + + #Encode any High ASCII characters + $outstring=&HTML::Entities::encode($outstring,"\200-\377"); +# ------------------------------------------------------------- Write modified. - my $outstring=''; - 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'})) { - $outstring.=$token->[4]; - } else { - $maxid++; - my $thisid=' id="'.$maxid.'"'; - my $fixup=$token->[4]; - $fixup=~s/(\<\w+)/$1$thisid/; - $outstring.=$fixup; - print $logfile 'ID: '.$fixup."\n"; - } - } else { - if (defined($token->[2]->{'index'})) { - $outstring.=$token->[4]; - } else { - $maxindex++; - my $thisindex=' index="'.$maxindex.'"'; - my $fixup=$token->[4]; - $fixup=~s/(\<\w+)/$1$thisindex/; - $outstring.=$fixup; - print $logfile 'Index: '.$fixup."\n"; - } - } - } else { - $outstring.=$token->[4]; - } - } elsif ($token->[0] eq 'E') { - $outstring.=$token->[2]; - } else { - $outstring.=$token->[1]; - } - } { my $org; unless ($org=Apache::File->new('>'.$source)) { print $logfile "No write permit to $source\n"; - return "No write permission to $source, FAIL"; + return + 'No write permission to '.$source. + ', FAIL'; } - print $org $outstring; + print($org $outstring); } $content=$outstring; - 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. + + %metadatafields=(); + %metadatakeys=(); + + my %oldparmstores=(); + + unless ($batch) { + $scrout.='

Metadata Information ' . + 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'}; + $metadatafields{'author'}=~s/\s+/ /g; + $metadatafields{'author'}=~s/\s+$//; + $metadatafields{'owner'}=$cuname.'@'.$cudom; + +# ------------------------------------------------ Check out directory hierachy + + my $thisdisfn=$source; + $thisdisfn=~s/^\/home\/$cuname\///; + + my @urlparts=split(/\//,$thisdisfn); + $#urlparts--; + + my $currentpath='/home/'.$cuname.'/'; + + foreach (@urlparts) { + $currentpath.=$_.'/'; + $scrout.=&metaread($logfile,$currentpath.'default.meta'); + } + +# ------------------- Clear out parameters and stores (there should not be any) + + foreach (keys %metadatafields) { + if (($_=~/^parameter/) || ($_=~/^stores/)) { + delete $metadatafields{$_}; + } + } + + } else { +# ---------------------- Read previous metafile, remember parameters and stores + + $scrout.=&metaread($logfile,$source.'.meta'); + + foreach (keys %metadatafields) { + if (($_=~/^parameter/) || ($_=~/^stores/)) { + $oldparmstores{$_}=1; + delete $metadatafields{$_}; + } + } + + } + # -------------------------------------------------- Parse content for metadata + if ($style eq 'ssi') { + my $oldenv=$ENV{'request.uri'}; + + $ENV{'request.uri'}=$target; + $allmeta=Apache::lonxml::xmlparse(undef,'meta',$content); + $ENV{'request.uri'}=$oldenv; + + &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; + } + + $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; + } + +# ------------------------------------------------------- Now have all metadata + + 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; + } + } + } + + + foreach (split(/\W+/,$metadatafields{'keywords'})) { + $keywords{$_}=1; + } +# --------------------------------------------------- Now we also have keywords +# ============================================================================= +# INTERACTIVE MODE +# + unless ($batch) { + $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 $keywords_help = Apache::loncommon::help_open_topic("Publishing_Keywords"); + my $keywordout=<<"END"; + +

Keywords: $keywords_help + + +
+END + $keywordout.=''; + my $colcount=0; + + foreach (sort keys %keywords) { + $keywordout.='\n"; + $colcount=0; + } + $colcount++; + } - $scrout=$allmeta; + $keywordout.='
'; + if ($colcount>10) { + $keywordout.="
'; + $scrout.=$keywordout; + + $scrout.=&textfield('Additional Keywords','addkey',''); + + $scrout.=&textfield('Notes','notes',$metadatafields{'notes'}); + + $scrout.= + '

Abstract:
'; + + $source=~/\.(\w+)$/; + + $scrout.=&hiddenfield('mime',$1); + + $scrout.=&selectbox('Language','language', + $metadatafields{'language'}, + \&Apache::loncommon::languagedescription, + (&Apache::loncommon::languageids), + ); + + unless ($metadatafields{'creationdate'}) { + $metadatafields{'creationdate'}=time; + } + $scrout.=&hiddenfield('creationdate',$metadatafields{'creationdate'}); + + $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'}; + } + $scrout.=&selectbox('Copyright/Distribution','copyright', + $metadatafields{'copyright'}, + \&Apache::loncommon::copyrightdescription, + (grep !/^public$/,(&Apache::loncommon::copyrightids))); + } + else { + $scrout.=&selectbox('Copyright/Distribution','copyright', + $metadatafields{'copyright'}, + \&Apache::loncommon::copyrightdescription, + (&Apache::loncommon::copyrightids)); + } + + my $copyright_help = + Apache::loncommon::help_open_topic('Publishing_Copyright'); + $scrout =~ s/DISTRIBUTION:/'DISTRIBUTION: ' . $copyright_help/ge; + return $scrout. + '

'; +# ============================================================================= +# BATCH MODE +# + } else { +# Transfer metadata directly to environment for stage 2 + foreach (keys %metadatafields) { + $ENV{'form.'.$_}=$metadatafields{$_}; } + $ENV{'form.addkey'}=''; + $ENV{'form.keywords'}=''; + foreach (keys %keywords) { + if ($metadatafields{'keywords'}) { + if ($metadatafields{'keywords'}=~/$_/) { + $ENV{'form.keywords'}.=$_.','; + } + } elsif (&Apache::loncommon::keyword($_)) { + $ENV{'form.keywords'}.=$_.','; + } + } + $ENV{'form.keywords'}=~s/\,$//; + unless ($ENV{'form.creationdate'}) { $ENV{'form.creationdate'}=time; } + $ENV{'form.lastrevisiondate'}=time; + if ((($style eq 'rat') && ($ENV{'form.copyright'} eq 'public')) || + (!$ENV{'form.copyright'})) { + $ENV{'form.copyright'}='default'; + } + $ENV{'form.allmeta'}=&Apache::lonnet::escape($allmeta); return $scrout; + } } -# ================================================================ Main Handler +######################################### +######################################### + +=pod + +=item B + +Render second interface showing status of publication steps. +This is publication step two. + +Parameters: + +=over 4 + +=item I<$source> + +=item I<$target> +=item I<$style> + +=item I<$distarget> + +=back + +Returns: + +=over 4 + +=item Scalar string + +String contains status (errors and warnings) and information associated with +the server's attempts at publication. + +=cut + +######################################### +######################################### +sub phasetwo { + + my ($source,$target,$style,$distarget,$batch)=@_; + my $logfile; + my $scrout=''; + unless ($logfile=Apache::File->new('>>'.$source.'.log')) { + return + 'No write permission to user directory, FAIL'; + } + print $logfile +"\n================= Publish ".localtime()." Phase Two ================\n"; + + %metadatafields=(); + %metadatakeys=(); + + &metaeval(&Apache::lonnet::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'}= + &sqltime($ENV{'form.creationdate'}); + $metadatafields{'lastrevisiondate'}= + &sqltime($ENV{'form.lastrevisiondate'}); + $metadatafields{'owner'}=$ENV{'form.owner'}; + $metadatafields{'copyright'}=$ENV{'form.copyright'}; + $metadatafields{'dependencies'}=$ENV{'form.dependencies'}; + + 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/\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 '>'. + &HTML::Entities::encode($metadatafields{$unikey}) + .''; + } + } + $scrout.='

Wrote Metadata'; + print $logfile "\nWrote metadata"; + } + +# -------------------------------- Synchronize entry with SQL metadata database + my $warning; + $metadatafields{'url'} = $distarget; + $metadatafields{'version'} = 'current'; + unless ($metadatafields{'copyright'} eq 'priv') { + my ($error,$success) = &store_metadata(\%metadatafields); + if ($success) { + $scrout.='

Synchronized SQL metadata database'; + print $logfile "\nSynchronized SQL metadata database"; + } else { + $warning.=$error; + print $logfile "\n".$error; + } + } 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"; + } + opendir(DIR,$srcd); + while ($filename=readdir(DIR)) { + if (-l $srcd.'/'.$filename) { + unlink($srcd.'/'.$filename); + unlink($srcd.'/'.$filename.'.meta'); + } else { + if ($filename=~/$srcf\.(\d+)\.$srct$/) { + $maxversion=($1>$maxversion)?$1:$maxversion; + } + } + } + closedir(DIR); + $maxversion++; + $scrout.='

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

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

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

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 "\nCopied original source to ".$copyfile."\n"; + $scrout.='

Copied source file'; + } else { + print $logfile "\nUnable to write ".$copyfile.':'.$!."\n"; + return "Failed to copy source, $!, FAIL"; + } + +# --------------------------------------------------------------- Copy Metadata + + $copyfile=$copyfile.'.meta'; + + if (copy($source.'.meta',$copyfile)) { + print $logfile "\nCopied original metadata to ".$copyfile."\n"; + $scrout.='

Copied metadata'; + } else { + print $logfile "\nUnable to write metadata ".$copyfile.':'.$!."\n"; + return + "Failed to write metadata copy, $!, FAIL"; + } + +# --------------------------------------------------- Send update notifications + + my @subscribed=&get_subscribed_hosts($target); + foreach my $subhost (@subscribed) { + $scrout.='

Notifying host '.$subhost.':'; + print $logfile "\nNotifying host ".$subhost.':'; + my $reply=&Apache::lonnet::critical('update:'.$target,$subhost); + $scrout.=$reply; + print $logfile $reply; + } + +# ---------------------------------------- Send update notifications, meta only + + my @subscribedmeta=&get_subscribed_hosts("$target.meta"); + foreach my $subhost (@subscribedmeta) { + $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; + } + +# ------------------------------------------------ Provide link to new resource + unless ($batch) { + my $thisdistarget=$target; + $thisdistarget=~s/^$docroot//; + + my $thissrc=$source; + $thissrc=~s/^\/home\/(\w+)\/public_html/\/priv\/$1/; + + my $thissrcdir=$thissrc; + $thissrcdir=~s/\/[^\/]+$/\//; + + + return $warning.$scrout. + '

'. + 'View Published Version'. + '

Back to Source'. + '

Back to Source Directory'; + } else { + return $warning.$scrout; + } +} + +######################################### + +sub batchpublish { + my ($r,$srcfile,$targetfile)=@_; + my $thisdisfn=$srcfile; + $thisdisfn=~s/\/home\/korte\/public_html\///; + $srcfile=~s/\/+/\//g; + + my $docroot=$r->dir_config('lonDocRoot'); + my $thisdistarget=$targetfile; + $thisdistarget=~s/^$docroot//; + + + undef %metadatafields; + undef %metadatakeys; + %metadatafields=(); + %metadatakeys=(); + $srcfile=~/\.(\w+)$/; + my $thistype=$1; + + + my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); + + $r->print('

Publishing '.$thisdisfn.'

'); + +# phase one takes +# my ($source,$target,$style,$batch)=@_; + $r->print('

'.&publish($srcfile,$targetfile,$thisembstyle,1).'

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

'.&phasetwo($srcfile,$targetfile,$thisembstyle,$thisdistarget,1).'

'); + return ''; +} + +######################################### + +sub publishdirectory { + my ($r,$fn,$thisdisfn)=@_; + my $resdir= + $Apache::lonnet::perlvar{'lonDocRoot'}.'/res/'.$cudom.'/'.$cuname. + $thisdisfn; + $r->print('

Directory '.$thisdisfn.'/

'. + 'Target: '.$resdir.'
'); + + my $dirptr=16384; # Mask indicating a directory in stat.cmode. + + 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) { +# previously published, modified now + $publishthis=1; + } + } else { +# never published + $publishthis=1; + } + if ($publishthis) { + &batchpublish($r,$fn.'/'.$filename,$resdir.'/'.$filename); + } else { + $r->print('
Skipping '.$filename.'
'); + } + $r->rflush(); + } + } + closedir(DIR); +} +######################################### + +=pod + +=item B + +A basic outline of the handler subroutine follows. + +=over 4 + +=item * + +Get query string for limited number of parameters. + +=item * + +Check filename. + +=item * + +File is there and owned, init lookup tables. + +=item * + +Start page output. + +=item * + +Evaluate individual file, and then output information. + +=item * + +Publishing from $thisfn to $thistarget with $thisembstyle. + +=back + +=cut + +######################################### +######################################### sub handler { my $r=shift; @@ -162,48 +1573,69 @@ sub handler { return OK; } +# Get query string for limited number of parameters + + &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'}, + ['filename']); + # -------------------------------------------------------------- Check filename my $fn=$ENV{'form.filename'}; + unless ($fn) { - $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. + $r->log_reason($cuname.' at '.$cudom. ' trying to publish empty filename', $r->filename); return HTTP_NOT_FOUND; } - unless ($ENV{'user.home'} eq $r->dir_config('lonHostID')) { - $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. + ($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 ('.$ENV{'user.home'}.')', + ' ('.$fn.') - not homeserver ('. + &Apache::lonnet::homeserver($cuname,$cudom).')', $r->filename); return HTTP_NOT_ACCEPTABLE; } - $fn=~s/^http\:\/\/[^\/]+\/\~(\w+)/\/home\/$1\/public_html/; + $fn=~s/^http\:\/\/[^\/]+//; + $fn=~s/^\/\~(\w+)/\/home\/$1\/public_html/; my $targetdir=''; - my $docroot=$r->dir_config('lonDocRoot'); - if ($1 ne $ENV{'user.name'}) { - $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. + $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/'.$ENV{'user.domain'}; + $targetdir=$docroot.'/res/'.$cudom; } unless (-e $fn) { - $r->log_reason($ENV{'user.name'}.' at '.$ENV{'user.domain'}. + $r->log_reason($cuname.' at '.$cudom. ' trying to publish non-existing file '.$ENV{'form.filename'}. ' ('.$fn.')', $r->filename); return HTTP_NOT_FOUND; } -# --------------------------------- File is there and owned, init lookup tables +unless ($ENV{'form.phase'} eq 'two') { + +# -------------------------------- File is there and owned, init lookup tables. %addid=(); @@ -213,42 +1645,78 @@ sub handler { $addid{$1}=$2; } } -# ----------------------------------------------------------- Start page output + + %nokey=(); + + { + my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab'); + while (<$fh>) { + my $word=$_; + chomp($word); + $nokey{$word}=1; + } + } + +} + +# ---------------------------------------------------------- Start page output. $r->content_type('text/html'); $r->send_http_header; $r->print('LON-CAPA Publishing'); - $r->print(''); + $r->print(&Apache::loncommon::bodytag('Resource Publication')); my $thisfn=$fn; - -# ------------------------------------------------------------- Individual file - { - $thisfn=~/\.(\w+)$/; - my $thistype=$1; - my $thisembstyle=&Apache::lonnet::fileembstyle($thistype); - my $thistarget=$thisfn; + my $thistarget=$thisfn; - $thistarget=~s/^\/home/$targetdir/; - $thistarget=~s/\/public\_html//; + $thistarget=~s/^\/home/$targetdir/; + $thistarget=~s/\/public\_html//; - my $thisdistarget=$thistarget; - $thisdistarget=~s/^$docroot//; + my $thisdistarget=$thistarget; + $thisdistarget=~s/^$docroot//; - my $thisdisfn=$thisfn; - $thisdisfn=~s/^\/home\/$ENV{'user.name'}\/public_html\///; + my $thisdisfn=$thisfn; + $thisdisfn=~s/^\/home\/$cuname\/public_html\///; + + if ($fn=~/\/$/) { +# -------------------------------------------------------- This is a directory + &publishdirectory($r,$fn,$thisdisfn); + + } else { +# ---------------------- Evaluate individual file, and then output information. + $thisfn=~/\.(\w+)$/; + my $thistype=$1; + my $thisembstyle=&Apache::loncommon::fileembstyle($thistype); $r->print('

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

Target: '.$thisdistarget.'

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

'); + } -# ------------ We are publishing from $thisfn to $thistarget with $thisembstyle + if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') { + $r->print('
Diffs with Current Version

'); + } + +# ------------------ Publishing from $thisfn to $thistarget with $thisembstyle. - $r->print('Result: '.&publish($thisfn,$thistarget,$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; @@ -257,9 +1725,9 @@ sub handler { 1; __END__ +=pod +=back - - - +=cut