# The LearningOnline Network with CAPA
# Publication Handler
#
# (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
package Apache::lonpublisher;
use strict;
use Apache::File;
use File::Copy;
use Apache::Constants qw(:common :http :methods);
use HTML::TokeParser;
use Apache::lonxml;
use Apache::lonhomework;
use Apache::loncacc;
use DBI;
my %addid;
my %nokey;
my %language;
my %cprtag;
my %metadatafields;
my %metadatakeys;
my $docroot;
my $cuname;
my $cudom;
# ----------------------------------------------- Evaluate string with metadata
sub metaeval {
my $metastring=shift;
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'};
}
map {
$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/) ||
($newentry eq '')) {
$metadatafields{$unikey}.=', '.$newentry;
}
} else {
$metadatafields{$unikey}=$parser->get_text('/'.$entry);
}
}
}
}
# -------------------------------------------------------- Read a metadata file
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.'';
}
# ---------------------------- convert 'time' format into a datetime sql format
sub sqltime {
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime(@_[0]);
$mon++; $year+=1900;
return "$year-$mon-$mday $hour:$min:$sec";
}
# --------------------------------------------------------- Various form fields
sub textfield {
my ($title,$name,$value)=@_;
return "\n
$title:
".
'';
}
sub hiddenfield {
my ($name,$value)=@_;
return "\n".'';
}
sub selectbox {
my ($title,$name,$value,%options)=@_;
my $selout="\n
$title:
".'';
}
# -------------------------------------------------------- Publication Step One
sub urlfixup {
my ($url,$target)=@_;
unless ($url) { return ''; }
my ($host)=($url=~/(?:http\:\/\/)*([^\/]+)/);
map {
if ($_ eq $host) {
$url=~s/^http\:\/\///;
$url=~s/^$host//;
}
} values %Apache::lonnet::hostname;
if ($url=~/^http\:\/\//) { return $url; }
$url=~s/\~$cuname/res\/$cudom\/$cuname/;
if ($target) {
$target=~s/\/[^\/]+$//;
$url=&Apache::lonnet::hreflocation($target,$url);
}
return $url;
}
sub publish {
my ($source,$target,$style)=@_;
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';
}
print $logfile
"\n\n================= Publish ".localtime()." Phase One ================\n";
if (($style eq 'ssi') || ($style eq 'rat')) {
# ------------------------------------------------------- This needs processing
# ----------------------------------------------------------------- Backup Copy
my $copyfile=$source.'.save';
if (copy($source,$copyfile)) {
print $logfile "Copied original file to ".$copyfile."\n";
} else {
print $logfile "Unable to write backup ".$copyfile.':'.$!."\n";
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);
$parser->xml_mode(1);
my $token;
while ($token=$parser->get_token) {
if ($token->[0] eq 'S') {
my $counter;
my $tag=$token->[1];
my $lctag=$tag;$lctag=~/[A-Z]/[a-z]/g;
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";
}
}
}
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 ($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 {
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];
}
}
# ------------------------------------------------------------ Construct Allows
unless ($style eq 'rat') {
$scrout.='
New parameters or stored values: '. $chparms; } my $chparms=''; map { if (($_=~/^parameter/) || ($_=~/^stores/)) { unless (($metadatafields{$_.'.name'}) || ($metadatafields{$_.'.package'}) || ($_=~/\.\w+$/)) { print $logfile 'Obsolete: '.$_."\n"; $chparms.=$_.' '; } } } sort keys %oldparmstores; if ($chparms) { $scrout.='
Obsolete parameters or stored values: '. $chparms; } # ------------------------------------------------------- Now have all metadata $scrout.= '