version 1.85, 2002/07/26 19:35:20
|
version 1.88, 2002/08/07 19:59:06
|
Line 267 sub get_subscribed_hosts {
|
Line 267 sub get_subscribed_hosts {
|
return @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 <randomlabel> image type <label> |
|
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); |
|
} |
|
|
sub publish { |
sub publish { |
|
|
my ($source,$target,$style)=@_; |
my ($source,$target,$style)=@_; |
Line 275 sub publish {
|
Line 475 sub publish {
|
my $allmeta=''; |
my $allmeta=''; |
my $content=''; |
my $content=''; |
my %allow=(); |
my %allow=(); |
undef %allow; |
|
|
|
unless ($logfile=Apache::File->new('>>'.$source.'.log')) { |
unless ($logfile=Apache::File->new('>>'.$source.'.log')) { |
return |
return |
Line 296 sub publish {
|
Line 495 sub publish {
|
return "<font color=red>Failed to write backup copy, $!,FAIL</font>"; |
return "<font color=red>Failed to write backup copy, $!,FAIL</font>"; |
} |
} |
# ------------------------------------------------------------- IDs and indices |
# ------------------------------------------------------------- IDs and indices |
|
|
my $maxindex=10; |
my $outstring; |
my $maxid=10; |
($outstring,%allow)=&fix_ids_and_indices($logfile,$source,$target); |
|
|
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 <randomlabel> image type <label> |
|
if ($lctag eq 'label' && defined($parms{'description'})) { |
|
my $next_token=$parser->get_token(); |
|
if ($next_token->[0] eq 'T') { |
|
$next_token->[1]=&set_allow(\%allow,$logfile, |
|
$target,$tag, |
|
$next_token->[1]); |
|
} |
|
$parser->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.'>'; |
|
} else { |
|
$allow{$token->[2]->{'src'}}=1; |
|
} |
|
} elsif ($token->[0] eq 'E') { |
|
if ($token->[2]) { |
|
unless ($token->[1] eq 'allow') { |
|
$outstring.='</'.$token->[1].'>'; |
|
} |
|
} |
|
} else { |
|
$outstring.=$token->[1]; |
|
} |
|
} |
|
# ------------------------------------------------------------ Construct Allows |
# ------------------------------------------------------------ Construct Allows |
|
|
$scrout.='<h3>Dependencies</h3>'; |
$scrout.='<h3>Dependencies</h3>'; |
Line 493 sub publish {
|
Line 548 sub publish {
|
} |
} |
$content=$outstring; |
$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 |
# --------------------------------------------- Initial step done, now metadata |
|
|