# The LearningOnline Network with CAPA
# Publication Handler
#
# $Id: lonpublisher.pm,v 1.83 2002/06/24 14:25:38 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,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 ##
## ##
###############################################################################
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::LCParser;
use Apache::lonxml;
use Apache::lonhomework;
use Apache::loncacc;
use DBI;
use Apache::lonnet();
use Apache::loncommon();
my %addid;
my %nokey;
my %metadatafields;
my %metadatakeys;
my $docroot;
my $cuname;
my $cudom;
# ----------------------------------------------- Evaluate string with metadata
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);
}
}
}
}
# -------------------------------------------------------- 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 $timef=shift @_;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
localtime($timef);
$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,$functionref,@idlist)=@_;
my $uctitle=uc($title);
my $selout="\n
$uctitle:".
"
".'';
}
# -------------------------------------------------------- Publication Step One
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;
}
sub absoluteurl {
my ($url,$target)=@_;
unless ($url) { return ''; }
if ($target) {
$target=~s/\/[^\/]+$//;
$url=&Apache::lonnet::hreflocation($target,$url);
}
return $url;
}
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
}
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::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;
}
}
}
}
}
}
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::LCParser->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 my $type ('src','href','background','bgimg') {
foreach my $key (keys(%parms)) {
print $logfile "for $type, and $key\n";
if ($key =~ /^$type$/i) {
print $logfile "calling set_allow\n";
$parms{$key}=&set_allow(\%allow,$logfile,
$target,$tag,
$parms{$key});
}
}
}
# probably a