#!/usr/local/bin/perl
require "/home/roger/lib/weblib.lib";
#use DB_File;
use HTML::Parser;
use URI::URL;
@ISA=("HTML::Parser");
$|=1;
# Identify the web site desired
dbmopen(%DIR,"/home/todd/db/homepage.db",0);
@program=split(m#/#,$ENV{PATH_INFO});
$program=$program[1];
dbmopen(%INFO,$DIR{$program}."db",0644);
dbmclose(%DIR);
# Load button names and associated text
@buttons=split(/,/,$INFO{"%%BUTTONS"});
@buttondescription=split(/:/,$INFO{"%%BUTTONDESCRIPTION"});
$bno=0;
foreach $button(@buttons){
($button,$buttontext)=split(/:/,$button);
$buttontext{$button}=$buttontext?$buttontext:$button;
$button{$button}=++$bno;
}
# Determine source of call, either CGI or shell
if($ENV{GATEWAY_INTERFACE}){
print "Content-type: text/html\n\n";
}
# Initialize header elements, colors, base tag, body tag
$bgcolor=$INFO{"%%BGCOLOR"}?$INFO{"%%BGCOLOR"}:"#ffffff";
$bgtext=$INFO{"%%BGTEXT"}?$INFO{"%%BGTEXT"}:"#000000";
$bglink=$INFO{"%%BGLINK"}?$INFO{"%%BGLINK"}:"#0000ff";
$bgvlink=$INFO{"%%BGVLINK"}?$INFO{"%%BGVLINK"}:"#996600";
$bgalink=$INFO{"%%BGALINK"}?$INFO{"%%BGALINK"}:"#ff0000";
$background=$INFO{"%%BACKGROUND"};
$background=qq{background="$background" } if $background;
$defbody="\n";
# Create opening wrapper
$masthead=$INFO{"%%MASTHEADGRAPHIC"};
if($masthead){
@masthead=split(/:/,$masthead);
$masthead=qq{![[$masthead[3]]]($masthead[0])
".$INFO{"%%HOMEPAGENAME"}.
" - Site Map";
print $defbody;
$wrapopen="$masthead
\n";
foreach $button(@buttons){
$wrapopen.= "| \n";
}
$wrapopen.= " |
\n";
print $wrapopen;
# Get button children info
# Set up navigation graphics
@blank=split(/:/,$INFO{"%%SPACER"});
$blank=qq{![$blank[3]]($blank[0])
",&makeLinks($Child{$button}),"\n";
}
print "\n";
print "
";
dbmclose(%INFO);
sub makeLinks{
my $link=shift;
my ($title,$nonlink,$descriptivetext)=split(/[%^]/,$Title{$link});
my $returnvalue;
if(!$NCND{$link}||$Child{$link}){
$nonlink=" $nonlink" if $nonlink ne ""&& $title ne "";
$htmllink=$URL{$link}?$URL{$link}:$INFO{"%%HOMEPAGEPROGRAM"}."/$link";
if($descriptivetext){
$htmllink.=qq{ onMouseOver="window.status='$descriptivetext';return true"};}
else{$htmllink.=qq{ onMouseOver="window.status='$title';return true"};}
if($currentlevel == 0){
$font=0,$returnvalue.="\n" if $font==-1;
$returnvalue.= "";
$returnvalue.="$title" if $title ne "";
$returnvalue.="$nonlink
\n";
$font=-1;
$returnvalue.= "\n" if $Child{$link};
}
elsif($currentlevel == 1){
$returnvalue.= ${blank};
$returnvalue.= "$title" if $title ne "";
$returnvalue.=$nonlink;
# this is the line that causes problems in IE
$returnvalue.="
" if $nonlink!~/ 1){
$returnvalue.= ${blank}x($currentlevel-1);
$returnvalue.= $blank if $title ne ""; # It's not a label
$returnvalue.= "$title" if $title ne "";
$returnvalue.=$nonlink;
$returnvalue.="
" if $nonlink!~/" if $debug;
#$count++;
local($URL,$linkage,$title,$restrict)=split(/%%/,$INFO{$link});
%restrict=split(/[:;]/,$restrict);
$allow=1;
if($restrict{IP}){
$allow=0;
$addr=pack('C4',split(/\./,$ENV{REMOTE_ADDR}));
@IP=split(/,/,$restrict{IP});
foreach $IP(@IP){
my $deny=$IP=~s/^-//;
if($IP=~/^[\d.]+$/){$IP=pack("C*",split(/\./,$IP));}
else{$IP=gethostbyname($IP);}
if($deny){$DENY{$IP}=1;}
else{$ALLOW{$IP}=1;};
}
foreach $IP(keys %ALLOW){
last if $allow||=(substr($addr,0,length($IP)) eq $IP);
}
if($allow){
foreach $IP(keys %DENY){
last unless $allow=(substr($addr,0,length($IP)) ne $IP);
}
}
}
if($restrict{From} || $restrict{To}){
my @time=(localtime(time))[0..5];
$time[4]++;
$time[5]+=1900;
my $now=sprintf("%4d%02d%02d%02d%02d%02d",reverse(@time));
$allow&&= $restrict{From} le $now if $restrict{From};
@time=(localtime(time))[0..5];
$time[4]++;
$time[5]+=1900;
$now=sprintf("%4d%02d%02d%02d%02d%02d",reverse(@time));
$allow&&= $restrict{To}."235959" gt $now if $restrict{To};
}
($parent,$child,$succ)=split(/;/,$linkage);
if($allow){
$URL{$link}=$URL;
$Title{$link}=$title;
$Child{$link}=$child;
$Succ{$link}=$succ;
$Parent{$link}=$parent;
$NCND{$link}=1 if $restrict{NCND}; # check for No Child, No Display mode
return unless $link eq $button || $parent;
push(@predecessor,$link);
print "Pushed: $link
"if $debug;
print "| $Title{$link} | $link | $parent | ",
"$Child{$link} | $Succ{$link} |
\n" if $debug;
followLinks($child) if $child;
followLinks($Succ{$link}) if $Succ{$link};
}
else{
# Relink predecessor or parent as appropriate
if($Child{$parent} eq $link){
print "Relinking ${link}'s parent ($parent) to have child of $succ
"
if $debug;
$Child{$parent}=$succ;
followLinks($succ) if $succ;
return;
}
else{
print "Relinking $predecessor[$#predecessor] to be succeeded by ",
"$succ
" if $debug;
$link=$predecessor[$#predecessor];
$Succ{$link}=$succ;
print "| $Title{$link} | $link | $parent | ",
"$Child{$link} | $Succ{$link} |
\n" if $debug;
followLinks($succ) if $succ;
}
}
if($allow){
$temp=pop(@predecessor);
print "Popped: $temp->$Succ{$temp}
" if $debug;
}
}