# The LearningOnline Network with CAPA
# Publication Handler
#
# $Id: lonpublisher.pm,v 1.89 2002/08/09 17:57:48 matthew 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();
use Apache::lonmysql;
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 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;
}
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);
}
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
}
#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