--- loncom/publisher/lonpublisher.pm 2001/10/16 08:53:19 1.48
+++ loncom/publisher/lonpublisher.pm 2002/08/09 19:49:30 1.92
@@ -1,5 +1,30 @@
# The LearningOnline Network with CAPA
# Publication Handler
+#
+# $Id: lonpublisher.pm,v 1.92 2002/08/09 19:49:30 albertel 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
#
@@ -12,23 +37,85 @@
# 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
+
+lonpublisher takes the proper steps to add resources to the LON-CAPA
+digital library. This includes updating the metadata table in the
+LON-CAPA database.
+
+=head1 Description
+
+lonpublisher is many things to many people.
+To all people it is woefully documented.
+This documentation conforms to this standard.
+
+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 Internal Functions
+
+=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 %language;
-my %cprtag;
my %metadatafields;
my %metadatakeys;
@@ -38,12 +125,23 @@ my $docroot;
my $cuname;
my $cudom;
-# ----------------------------------------------- Evaluate string with metadata
+#########################################
+#########################################
+
+=pod
+=item metaeval
+
+Evaluate string with metadata
+
+=cut
+
+#########################################
+#########################################
sub metaeval {
my $metastring=shift;
- my $parser=HTML::TokeParser->new(\$metastring);
+ my $parser=HTML::LCParser->new(\$metastring);
my $token;
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
@@ -56,19 +154,19 @@ sub metaeval {
$unikey.='_'.$token->[2]->{'part'};
}
if (defined($token->[2]->{'id'})) {
- $unikey.='.'.$token->[2]->{'id'};
+ $unikey.='_'.$token->[2]->{'id'};
}
if (defined($token->[2]->{'name'})) {
$unikey.='_'.$token->[2]->{'name'};
}
- map {
+ foreach (@{$token->[3]}) {
$metadatafields{$unikey.'.'.$_}=$token->[2]->{$_};
if ($metadatakeys{$unikey}) {
$metadatakeys{$unikey}.=','.$_;
} else {
$metadatakeys{$unikey}=$_;
}
- } @{$token->[3]};
+ }
if ($metadatafields{$unikey}) {
my $newentry=$parser->get_text('/'.$entry);
unless (($metadatafields{$unikey}=~/$newentry/) ||
@@ -82,8 +180,19 @@ sub metaeval {
}
}
-# -------------------------------------------------------- Read a metadata file
+#########################################
+#########################################
+
+=pod
+=item metaread
+
+Read a metadata file
+
+=cut
+
+#########################################
+#########################################
sub metaread {
my ($logfile,$fn)=@_;
unless (-e $fn) {
@@ -100,16 +209,49 @@ sub metaread {
return 'Processed file: '.$fn.' ';
}
-# ---------------------------- convert 'time' format into a datetime sql format
+#########################################
+#########################################
+
+=pod
+
+=item sqltime
+
+Convert 'time' format into a datetime sql format
+
+=cut
+
+#########################################
+#########################################
sub sqltime {
+ my $timef=shift @_;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
- localtime(@_[0]);
+ localtime($timef);
$mon++; $year+=1900;
return "$year-$mon-$mday $hour:$min:$sec";
}
-# --------------------------------------------------------- Various form fields
+#########################################
+#########################################
+
+=pod
+
+=item Form field generating functions
+
+=over 4
+
+=item textfield
+
+=item hiddenfield
+
+=item selectbox
+
+=back
+
+=cut
+
+#########################################
+#########################################
sub textfield {
my ($title,$name,$value)=@_;
return "\n
$title: ".
@@ -122,30 +264,69 @@ sub hiddenfield {
}
sub selectbox {
- my ($title,$name,$value,%options)=@_;
- my $selout="\n
$title: ".'';
- map {
- $selout.=''.$options{$_}.' ';
- } sort keys %options;
+ my ($title,$name,$value,$functionref,@idlist)=@_;
+ my $uctitle=uc($title);
+ my $selout="\n$uctitle:".
+ " ".'';
+ foreach (@idlist) {
+ $selout.=''.&{$functionref}($_).' ';
+ }
+ else {$selout.='>'.&{$functionref}($_).'';}
+ }
return $selout.' ';
}
-# -------------------------------------------------------- Publication Step One
+#########################################
+#########################################
+
+=pod
+
+=item urlfixup
+
+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\:\/\/)*([^\/]+)/);
- map {
+ foreach (values %Apache::lonnet::hostname) {
if ($_ eq $host) {
$url=~s/^http\:\/\///;
$url=~s/^$host//;
}
- } values %Apache::lonnet::hostname;
+ }
if ($url=~/^http\:\/\//) { return $url; }
$url=~s/\~$cuname/res\/$cudom\/$cuname/;
+ return $url;
+}
+
+#########################################
+#########################################
+
+=pod
+
+=item absoluteurl
+
+Currently undocumented
+
+=cut
+
+#########################################
+#########################################
+sub absoluteurl {
+ my ($url,$target)=@_;
+ unless ($url) { return ''; }
if ($target) {
$target=~s/\/[^\/]+$//;
$url=&Apache::lonnet::hreflocation($target,$url);
@@ -153,6 +334,390 @@ sub urlfixup {
return $url;
}
+#########################################
+#########################################
+
+=pod
+
+=item set_allow
+
+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 get_subscribed_hosts
+
+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') {
+ 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+):/) { push(@subscribed,$1); } else {
+ &Apache::lonnet::logthis("No Match for $subline");
+ }
+ }
+ } else {
+ &Apache::lonnet::logthis("Un able to open $target.subscription");
+ }
+ &Apache::lonnet::logthis("Got list of ".join(':',@subscribed));
+ return @subscribed;
+}
+
+
+#########################################
+#########################################
+
+=pod
+
+=item get_max_ids_indices
+
+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 get_all_text_unbalanced
+
+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 fix_ids_and_indices
+
+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
+ if ($lctag eq 'label' && defined($parms{'description'})) {
+ my $next_token=$parser[-1]->get_token();
+ if ($next_token->[0] eq 'T') {
+ $next_token->[1]=&set_allow(\%allow,$logfile,
+ $target,$tag,
+ $next_token->[1]);
+ }
+ $parser[-1]->unget_token($next_token);
+ }
+ 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{&absoluteurl($codebase,$target).'/*'}=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{&absoluteurl($newurl,$target)}=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.'>';
+ if ($lctag eq 'm') {
+ $outstring.=&get_all_text_unbalanced('/m',\@parser);
+ }
+ } elsif ($token->[0] eq 'E') {
+ if ($token->[2]) {
+ unless ($token->[1] eq 'allow') {
+ $outstring.=''.$token->[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,%allow);
+}
+
+#########################################
+#########################################
+
+=pod
+
+=item store_metadata
+
+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 = %{shift()};
+ my $error;
+ # Determine if the table exists
+ my $status = &Apache::lonmysql::check_table('metadata');
+ if (! defined($status)) {
+ $error='WARNING: Cannot connect to '.
+ 'database! ';
+ &Apache::lonnet::logthis($error);
+ return ($error,undef);
+ }
+ if ($status == 0) {
+ # It would be nice to actually create the table....
+ $error ='WARNING: The metadata table does not '.
+ 'exist in the LON-CAPA database. ';
+ &Apache::lonnet::logthis($error);
+ return ($error,undef);
+ }
+ # Remove old value from table
+ $status = &Apache::lonmysql::remove_from_table
+ ('metadata','url',$metadata{'url'});
+ if (! defined($status)) {
+ $error = 'Error when removing old values from '.
+ 'metadata table in LON-CAPA database. ';
+ &Apache::lonnet::logthis($error);
+ return ($error,undef);
+ }
+ # Store data in table.
+ $status = &Apache::lonmysql::store_row('metadata',\%metadata);
+ if (! defined($status)) {
+ $error='Error occured storing new values in '.
+ 'metadata table in LON-CAPA database ';
+ &Apache::lonnet::logthis($error);
+ return ($error,undef);
+ }
+ return (undef,$status);
+}
+
+#########################################
+#########################################
+
+=pod
+
+=item publish
+
+Currently undocumented. This is the workhorse function of this module.
+
+=cut
+
+#########################################
+#########################################
sub publish {
my ($source,$target,$style)=@_;
@@ -161,7 +726,6 @@ sub publish {
my $allmeta='';
my $content='';
my %allow=();
- undef %allow;
unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
return
@@ -182,156 +746,47 @@ sub publish {
return "Failed to write backup copy, $!,FAIL ";
}
# ------------------------------------------------------------- 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);
- my $token;
- while ($token=$parser->get_token) {
- if ($token->[0] eq 'S') {
- my $counter;
- my $tag=$token->[1];
- unless ($tag eq 'allow') {
- my %parms=%{$token->[2]};
- if ($counter=$addid{$tag}) {
- 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";
- }
- }
- }
-
- map {
- 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;
- }
- } ('src','href','background');
-
- if ($tag 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 {
- map {
- if (defined($parms{$_})) {
- my $oldurl=$parms{$_};
- my $newurl=&urlfixup($oldurl,$target);
- $newurl=~s/\/[^\/]+$/\/\*/;
- print $logfile 'Allow: applet '.$_.':'.
- $oldurl.' allows '.
- $newurl."\n";
- $allow{$newurl}=1;
- }
- } ('archive','code','object');
- }
- }
-
- my $newparmstring='';
- my $endtag='';
- map {
- if ($_ eq '/') {
- $endtag=' /';
- } else {
- my $quote=($parms{$_}=~/\"/?"'":'"');
- $newparmstring.=' '.$_.'='.$quote.$parms{$_}.$quote;
- }
- } keys %parms;
-
- $outstring.='<'.$tag.$newparmstring.$endtag.'>';
- } else {
- $allow{$token->[2]->{'src'}}=1;
- }
- } elsif ($token->[0] eq 'E') {
- unless ($token->[1] eq 'allow') {
- $outstring.=''.$token->[1].'>';
- }
- } else {
- $outstring.=$token->[1];
- }
- }
+
+ my $outstring;
+ ($outstring,%allow)=&fix_ids_and_indices($logfile,$source,$target);
# ------------------------------------------------------------ Construct Allows
- unless ($style eq 'rat') {
+
$scrout.='Dependencies ';
- my $allowstr="\n";
- map {
- $allowstr.=' '."\n";
+ my $allowstr='';
+ foreach (sort(keys(%allow))) {
+ my $thisdep=$_;
+ if ($thisdep !~ /[^\s]/) { next; }
+ unless ($style eq 'rat') {
+ $allowstr.="\n".' ';
+ }
$scrout.=' ';
- unless ($_=~/\*/) {
- $scrout.='';
+ unless ($thisdep=~/\*/) {
+ $scrout.=' ';
}
- $scrout.=''.$_.' ';
- unless ($_=~/\*/) {
+ $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);
+ }
+ }
}
- } keys %allow;
- $outstring=~s/(\<\/[^\>]+\>\s*)$/$allowstr$1/s;
- }
+ }
+ $outstring=~s/\n*(\<\/[^\>]+\>)\s*$/$allowstr\n$1\n/s;
+
+ #Encode any High ASCII characters
+ $outstring=&HTML::Entities::encode($outstring,"\200-\377");
# ------------------------------------------------------------- Write modified
{
@@ -345,13 +800,6 @@ sub publish {
}
$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
@@ -362,7 +810,10 @@ sub publish {
my %oldparmstores=();
- $scrout.='Metadata Information ';
+
+ $scrout.='Metadata Information ' .
+ Apache::loncommon::help_open_topic("Metadata_Description")
+ . ' ';
# ------------------------------------------------ First, check out environment
unless (-e $source.'.meta') {
@@ -384,30 +835,30 @@ sub publish {
my $currentpath='/home/'.$cuname.'/';
- map {
+ foreach (@urlparts) {
$currentpath.=$_.'/';
$scrout.=&metaread($logfile,$currentpath.'default.meta');
- } @urlparts;
+ }
# ------------------- Clear out parameters and stores (there should not be any)
- map {
+ foreach (keys %metadatafields) {
if (($_=~/^parameter/) || ($_=~/^stores/)) {
delete $metadatafields{$_};
}
- } keys %metadatafields;
+ }
} else {
# ---------------------- Read previous metafile, remember parameters and stores
$scrout.=&metaread($logfile,$source.'.meta');
- map {
+ foreach (keys %metadatafields) {
if (($_=~/^parameter/) || ($_=~/^stores/)) {
$oldparmstores{$_}=1;
delete $metadatafields{$_};
}
- } keys %metadatafields;
+ }
}
@@ -416,7 +867,7 @@ sub publish {
my $oldenv=$ENV{'request.uri'};
$ENV{'request.uri'}=$target;
- $allmeta=Apache::lonxml::xmlparse('meta',$content);
+ $allmeta=Apache::lonxml::xmlparse(undef,'meta',$content);
$ENV{'request.uri'}=$oldenv;
&metaeval($allmeta);
@@ -424,7 +875,7 @@ sub publish {
# ---------------- Find and document discrepancies in the parameters and stores
my $chparms='';
- map {
+ foreach (sort keys %metadatafields) {
if (($_=~/^parameter/) || ($_=~/^stores/)) {
unless ($_=~/\.\w+$/) {
unless ($oldparmstores{$_}) {
@@ -433,14 +884,14 @@ sub publish {
}
}
}
- } sort keys %metadatafields;
+ }
if ($chparms) {
$scrout.='New parameters or stored values: '.
$chparms;
}
- my $chparms='';
- map {
+ $chparms='';
+ foreach (sort keys %oldparmstores) {
if (($_=~/^parameter/) || ($_=~/^stores/)) {
unless (($metadatafields{$_.'.name'}) ||
($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) {
@@ -448,7 +899,7 @@ sub publish {
$chparms.=$_.' ';
}
}
- } sort keys %oldparmstores;
+ }
if ($chparms) {
$scrout.='
Obsolete parameters or stored values: '.
$chparms;
@@ -457,18 +908,41 @@ sub publish {
# ------------------------------------------------------- Now have all metadata
$scrout.=
- '
';
+ '
';
}
-# -------------------------------------------------------- Publication Step Two
+#########################################
+#########################################
+
+=pod
+
+=item phasetwo
+
+Render second interface showing status of publication steps.
+This is publication step two.
+=cut
+
+#########################################
+#########################################
sub phasetwo {
my ($source,$target,$style,$distarget)=@_;
my $logfile;
my $scrout='';
-
unless ($logfile=Apache::File->new('>>'.$source.'.log')) {
return
'No write permission to user directory, FAIL ';
@@ -581,13 +1080,15 @@ sub phasetwo {
$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'};
- map {
- if ($_=~/^form\.key\.(\w+)/) {
- $allkeywords.=','.$1;
+ if (exists($ENV{'form.keywords'}) && (ref($ENV{'form.keywords'}))) {
+ my @Keywords = @{$ENV{'form.keywords'}};
+ foreach (@Keywords) {
+ $allkeywords.=','.$_;
}
- } keys %ENV;
+ }
$allkeywords=~s/\W+/\,/;
$allkeywords=~s/^\,//;
$metadatafields{'keywords'}=$allkeywords;
@@ -598,89 +1099,46 @@ sub phasetwo {
unless ($mfh=Apache::File->new('>'.$source.'.meta')) {
return
'Could not write metadata, FAIL ';
- }
- map {
+ }
+ foreach (sort keys %metadatafields) {
unless ($_=~/\./) {
my $unikey=$_;
$unikey=~/^([A-Za-z]+)/;
my $tag=$1;
$tag=~tr/A-Z/a-z/;
print $mfh "\n\<$tag";
- map {
+ foreach (split(/\,/,$metadatakeys{$unikey})) {
my $value=$metadatafields{$unikey.'.'.$_};
$value=~s/\"/\'\'/g;
print $mfh ' '.$_.'="'.$value.'"';
- } split(/\,/,$metadatakeys{$unikey});
- print $mfh '>'.$metadatafields{$unikey}.''.$tag.'>';
+ }
+ print $mfh '>'.
+ &HTML::Entities::encode($metadatafields{$unikey})
+ .''.$tag.'>';
}
- } sort keys %metadatafields;
+ }
$scrout.='Wrote Metadata';
print $logfile "\nWrote metadata";
}
# -------------------------------- Synchronize entry with SQL metadata database
- my %perlvar;
- open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
- my $configline;
- while ($configline=) {
- if ($configline =~ /PerlSetVar/) {
- my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
- chomp($varvalue);
- $perlvar{$varname}=$varvalue;
- }
- }
- close(CONFIG);
-
my $warning;
- my $dbh;
- {
- unless (
- $dbh = DBI->connect("DBI:mysql:loncapa","www",$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();
- map {my $field=$metadatafields{$_}; $field=~s/\"/\'\'/g;
- $sqldatafields{$_}=$field;}
- ('title','author','subject','keywords','notes','abstract',
- 'mime','language','creationdate','lastrevisiondate','owner',
- 'copyright');
-
- $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";
- }
+ $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) {
@@ -775,56 +1233,26 @@ if (-e $target) {
# --------------------------------------------------- Send update notifications
-{
-
- 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;
- }
- }
+ 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;
}
- closedir(DIR);
-
-}
# ---------------------------------------- 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) {
+ $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;
}
- closedir(DIR);
-
-}
# ------------------------------------------------ Provide link to new resource
@@ -839,15 +1267,43 @@ if (-e $target) {
return $warning.$scrout.
- '
View Target '.
+ 'View Published Version '.
'Back to Source '.
'
Back to Source Directory ';
}
-# ================================================================ Main Handler
+#########################################
+#########################################
+
+=pod
+
+=item handler
+
+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 Individual file
+
+=item publish from $thisfn to $thistarget with $thisembstyle
+
+=back
+
+=cut
+
+#########################################
+#########################################
sub handler {
my $r=shift;
@@ -859,17 +1315,8 @@ sub handler {
# Get query string for limited number of parameters
- map {
- 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;
- }
- }
- } (split(/&/,$ENV{'QUERY_STRING'}));
-
+ &Apache::loncommon::get_unprocessed_cgi($ENV{'QUERY_STRING'},
+ ['filename']);
# -------------------------------------------------------------- Check filename
@@ -943,31 +1390,11 @@ unless ($ENV{'form.phase'} eq 'two') {
{
my $fh=Apache::File->new($r->dir_config('lonIncludes').'/un_keyword.tab');
- map {
+ while (<$fh>) {
my $word=$_;
chomp($word);
$nokey{$word}=1;
- } <$fh>;
- }
-
- %language=();
-
- {
- my $fh=Apache::File->new($r->dir_config('lonTabDir').'/language.tab');
- map {
- $_=~/(\w+)\s+([\w\s\-]+)/;
- $language{$1}=$2;
- } <$fh>;
- }
-
- %cprtag=();
-
- {
- my $fh=Apache::File->new($r->dir_config('lonIncludes').'/copyright.tab');
- map {
- $_=~/(\w+)\s+([\w\s\-]+)/;
- $cprtag{$1}=$2;
- } <$fh>;
+ }
}
}
@@ -986,7 +1413,7 @@ unless ($ENV{'form.phase'} eq 'two') {
{
$thisfn=~/\.(\w+)$/;
my $thistype=$1;
- my $thisembstyle=&Apache::lonnet::fileembstyle($thistype);
+ my $thisembstyle=&Apache::loncommon::fileembstyle($thistype);
my $thistarget=$thisfn;
@@ -1000,7 +1427,7 @@ unless ($ENV{'form.phase'} eq 'two') {
$thisdisfn=~s/^\/home\/$cuname\/public_html\///;
$r->print('
Publishing '.
- &Apache::lonnet::filedescription($thistype).' '.
+ &Apache::loncommon::filedescription($thistype).' '.
$thisdisfn.' Target: '.$thisdistarget.' ');
if (($cuname ne $ENV{'user.name'}) || ($cudom ne $ENV{'user.domain'})) {
@@ -1008,7 +1435,7 @@ unless ($ENV{'form.phase'} eq 'two') {
'');
}
- if (&Apache::lonnet::fileembstyle($thistype) eq 'ssi') {
+ if (&Apache::loncommon::fileembstyle($thistype) eq 'ssi') {
$r->print('Diffs with Current Version
');
@@ -1033,9 +1460,9 @@ unless ($ENV{'form.phase'} eq 'two') {
1;
__END__
+=pod
+=back
-
-
-
+=cut