--- loncom/publisher/lonpublisher.pm 2001/12/25 21:58:54 1.67 +++ loncom/publisher/lonpublisher.pm 2002/08/09 17:57:48 1.89 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # Publication Handler # -# $Id: lonpublisher.pm,v 1.67 2001/12/25 21:58:54 www Exp $ +# $Id: lonpublisher.pm,v 1.89 2002/08/09 17:57:48 matthew Exp $ # # Copyright Michigan State University Board of Trustees # @@ -43,6 +43,9 @@ # 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 # ### @@ -65,13 +68,14 @@ 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; @@ -88,7 +92,7 @@ my $cudom; 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') { @@ -146,8 +150,9 @@ sub metaread { # ---------------------------- convert 'time' format into a datetime sql format 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"; } @@ -185,6 +190,11 @@ sub selectbox { 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) { @@ -194,6 +204,13 @@ sub urlfixup { } 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); @@ -201,6 +218,312 @@ sub urlfixup { 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 image type