#!/usr/local/bin/perl 
$Verbose = 0;
use Carp;
use Getopt::Long;
$opt_suffix = "htm";
$opt_tk     = "";
GetOptions('suffix=s','tk','q');
$SIG{INT} = sub { confess("Interrupt") };
use strict qw(subs);
use Carp; 
use lib qw(. ..);
{
 package HTML;
 use Carp; 
 use Tk::Pretty;
 use strict qw(subs);
 $enabled = 0;
 sub Enable
 {
  $enabled = 1;
 }
 sub new
 {
  my $package = shift;
  my $file = shift;
  my $obj;
  print STDERR "$file\n" unless ($main::opt_q);
  if (exists $file{$file})
   {
    $obj = $file{$file};
   }
  else
   {
    $obj = bless { 'FH'   => \*{$file}, 
                      'FNAME' => $file,
                      'LIST' => [],  
                      'PARA' => 1,
                      'FILL' => 1,
                      'SECTIONS' => {},
                      'SECTION'  => "",
                      'Number'   => 0, @_
                    },$package;
    $file{$file} = $obj;
   }
  if ($enabled)
   {
    my $l = length($file);
    warn "Long name ($l) $file\n" if ($l > 14);
    open($file,">$file") || die "Cannot open $file:$!";
    $obj->tag('HTML'); 
    $obj->tag('HEAD'); 
    $obj->tagged('TITLE',$obj->{Description}) if (defined $obj->{Description});
    $obj->tag('/HEAD'); 
    $obj->tag('BODY'); 
   }
  return $obj;
 }
 sub inlist
 {
  my $obj = shift;
  return @{$obj->{'LIST'}} != 0;
 }
 sub listtype
 {
  my $obj = shift;
  return $obj->{'LIST'}[0];
 }
 sub print
 {my $obj = shift;
  if ($enabled)
   {
    my $fh  = $obj->{'FH'};
    print $fh @_;
   }
 } 
 sub description
 {
  my $obj = shift;
  if (@_)
   {
    $obj->{Description} = shift;
   }
  return $obj->{Description}; 
 }
 sub tag
 {
  my $obj = shift;
  $obj->print("<",shift,">\n");
 }
 sub tagged
 {
  my $obj = shift;
  my $tag = shift;
  croak "bad tagged" if (!defined $obj || !defined $tag || !@_);
  foreach (@_)
   {
    croak "bad tagged" if (!defined $_);
   }
  my $text = join(' ',@_);
  $obj->print("<$tag>",$text,"</$tag>\n");
 }
 sub para
 {
  my $obj = shift;
  if ($obj->{'PARA'})
   {
   }
  else
   {
    $obj->tag('P');
    $obj->{'PARA'}++;
   }
 }
 sub force_list
 {
  my $obj = shift;
  my $type = shift;
  unshift(@{$obj->{'LIST'}},$type);
  $obj->tag($type);
 }
 sub start_list
 {
  my $obj = shift;
  my $type = shift;
  $obj->force_list($type) if (!$obj->inlist || $obj->listtype ne $type);
 }
 sub end_list
 {
  my $obj = shift;
  if ($obj->inlist)
   {
    my $type = shift(@{$obj->{'LIST'}});
    $obj->tag("/".$type);
   }
 }
 sub end_lists
 {
  my $obj = shift;
  $obj->end_list() while ($obj->inlist);
 }
 sub Href
  {
   my $obj = shift;
   my $text = 'HREF="';
   $text .= $obj->{'FNAME'};
   $text .= '#'.shift if (@_);
   $text .= '"';
   return $text;
  }
 sub Link
 {
  my $obj = shift;
  my $key = shift;
  my $sec = shift;
  my $text = $key;
  my $doc;
  my $href;
  $sec =~ s/^[\s'`]+//;
  $sec =~ s/[\s'`]+$//;
  if ($key eq "")
   {
    $text = $sec;
    if (exists $obj->{'SECTIONS'}{$sec})
     {
      $href = 'HREF="#' . $obj->{'SECTIONS'}{$sec} . '"';
     }
    else
     {
      warn "$ARGV:$.:No '$sec'" if ($enabled && $sec !~ /[a-z]/ && $^W);
     }
   }
  else
   {
    my $doc;
    if (ref($key) && ref($key) eq 'HTML')
     {
      $doc  = $key;
      $text = $doc->{'DOC'};
     }
    else
     {
      $key =~ s,<([BI])>(.*)</\1>,$2,; 
      $key =~ s,``(.*)'',$1,; 
      $doc = $Document{$key} if (exists $Document{$key});
     }
    if (defined $doc)
     {
      $href = $doc->Href;
      if ($sec ne "")
       {
        if (exists $doc->{'SECTIONS'}{$sec})
         {
          $href =~ s/"$/$doc->{'SECTIONS'}{$sec}"/;
         }
        else
         {
          warn "No $sec " . Pretty($doc->{'SECTIONS'}) if ($enabled && $^W);
         }
        $text .= " $sec";
       }
     }
   }
  if (defined $href)
   {
    return "<A $href> $text</A>";
   }
  else
   {
    if ($enabled && $^W)
     {
      warn "$ARGV:$.: No $key/$sec\n";
     }
   }
  return $text;
 }
sub Xref
{
 my $obj = shift;
 my ($start,$key,$sec,$end) = @_;
 return $start . $obj->Link($key,$sec) . $end;
}
 sub stdoption
 {
  my ($obj,$name,$space) = @_;
  if (exists $option{$name})
   {
    my $href = $option{$name}->Href($name);
    return "<A $href><B>$name</B></A>";
   }
  else
   {
    return "<B>$name</B>";
   }
 }
 sub text
 {
  my $obj = shift;
  my $line = shift;
  chomp($line);
  if ($obj->{'SECTION'} =~ /SEE\s+ALSO/i)
   {
    my @key = split(/\s*,\s*/,$line);
    foreach $key (@key)
     {
      $key = HTML->Link($key,"");
     }
    $line = join(', ',@key);
   }
  elsif ($obj->{'SECTION'} =~ /KEYWORDS/i)
   {
    my $key;
    foreach $key (split(/\s*,\s*/,$line))
     {
      $keyword{$key} = [] unless (exists $keyword{$key});
      push(@{$keyword{$key}},$obj);
     }
   }
  elsif ($obj->{'SECTION'} =~ /^NAME$/)
   {
    my $head = $line; 
    my $desc;
    $obj->description($1) if ($head =~ s/\s*-\s*(.*)$//);
    my $key;
    foreach $key (split(/\s*,\s*/,$head))
     {
      last if $key =~ /-/;
      $Document{$key} = $obj;
     }
   }
  elsif ($obj->{'SECTION'} =~ /STANDARD\s+OPTIONS/i && $main::opt_tk)
   {
    $line =~ s#<B>([a-zA-Z]+)</B>#&stdoption($obj,$1)#eg;
   }
  $obj->print($line);
  # Do optional 'br' ?
  $obj->print("\n");
  $obj->{'PARA'} = 0;
 }
 sub comment
 {
  my $obj = shift;
  my $line = shift;
  chomp($line);
  $obj->print("<!--$line-->\n") if (length $line);
 }
 sub close
 {
  my $obj = shift;
  if ($enabled)
   {
    $obj->tag('/BODY');
    $obj->tag('/HTML');
    my $fh  = $obj->{'FH'};
    close($fh);
   }
 }
 sub DESTROY
  {
   my $obj = shift;
   $obj->close;
   delete $obj->{'FH'};
  }
 sub Keywords
  {
   return sort(keys %keyword);
  }
 sub Document
  {my $obj = shift;
   my $doc = shift;
   $Document{$doc} = $obj;
   $obj->{'DOC'} = $doc;
   # $obj->tagged('H1',$doc);
  }
 sub Section
  {
   my $obj = shift;
   my $arg = shift;
   $obj->{'SECTION'} = $arg;
   my $sec  = $arg; 
   $sec =~ s/^\s+//;
   $sec =~ s/\s+$//;
   if (!exists $obj->{'SECTIONS'}{$sec})
    {
     my $name = ($sec =~ /^[A-Za-z][A-Za-z0-9_]*$/) 
                ? $sec  : "Section" . $obj->{'Number'}++;
     $obj->{'SECTIONS'}{$sec} = $name;
    }
   if (exists $obj->{'SECTIONS'}{$sec})
    {
     my $name = $obj->{'SECTIONS'}{$sec};
     $obj->tagged('H2',"<A NAME=$name>$arg</A>");
    }
   else
    {
     $obj->tagged('H2',$arg);
    }
  }
}
sub so 
{ 
}
sub B
{
 my $obj = shift;
 my $arg = shift;
 $obj->tagged('B',$arg);
}
sub I
{
 my $obj = shift;
 my $arg = shift;
 $obj->tagged('I',$arg) if (length $arg);
}
sub TH
{
 my $obj = shift;
 my ($doc,$sec,$ver,$tk,@pkg) = @_;
 my $pkg = join(' ',@pkg);
 $pkg =~ s/^"(.*)"$/$1/;
 $obj->Document($doc);
 unless(exists $Cat{$pkg})
  {
   $Cat{$pkg} = {}; 
   print STDERR "$pkg\n";
  }
 $Cat{$pkg}{$doc} = $obj;
}
sub HS
{ 
 my $obj = shift;
 my ($doc,$pkg,$ver) = @_;
 $obj->Document($doc);
 $Cat{$pkg} = {} unless exists $Cat{$pkg};
 $Cat{$pkg}{$doc} = $obj;
}
sub BS
{ 
 my $obj = shift;
 $obj->end_lists;
 $obj->print("<HR>\n");
}
sub BE
{ 
 my $obj = shift;
 $obj->end_lists;
 $obj->print("<HR>\n");
 fi($obj);
}
sub SH
{ 
 my $obj = shift;
 my $arg = join(' ',@_);
 $arg =~ s/^\s*"(.*)"\s*$/$1/;
 $obj->end_lists;
 $obj->Section($arg);
}
sub AS
{ 
 my $obj = shift;
 # just sets max length - ignore it.
}
sub AP
{ 
 my $obj = shift;
 my $dir = pop(@_);
 my $arg = join(' ',@_);
 $obj->start_list('DL');
 $obj->print("<DT>");
 $obj->tagged('CODE',$arg) if (length $arg);
 if (defined $dir)
  {
   $obj->print("($dir) ");    
  }
 $obj->print("<DD>");
}
sub PP
{ 
 my $obj = shift;
 $obj->end_list;
 $obj->para;
}
sub LP
{ 
 my $obj = shift;
 $obj->end_lists;
 $obj->para;
}
# low level flow
sub nf 
{ 
 my $obj = shift;
 $obj->{'FILL'} = 0;
 br($obj);
}
sub fi 
{
 my $obj = shift;
 $obj->{'FILL'} = 1; 
 br($obj);
}
# low level adjust
sub na {  }
sub ad {  }
sub sp
{ 
 my $obj = shift;
 $obj->para();
}
sub br
{ 
 my $obj = shift;
 $obj->print("<BR>\n");
}
sub VS
{
 my $obj = shift;
 # Start of change bar 
}
sub VE
{
 my $obj = shift;
 # End of change bar 
}
sub ta
{
 my $obj = shift;
}
sub DS
{
 my $obj = shift;
 nf($obj);
 $obj->tag('PRE');
}
sub DE 
{
 my $obj = shift;
 fi($obj);
 $obj->tag('/PRE');
}
sub BR
{
 my $obj = shift;
 my $title = shift;
 $obj->Xref("",$title,"","");
}
sub IP
{ 
 my $obj = shift;
 if (@_)
  {
   my $term = shift;
   if ($term =~ /^\s*\[(\d+)\]\s*$/)
    {
     $obj->start_list('OL');
     $obj->print("<LI>");
    }
   elsif ($term =~ /^\s*(\\\(bu|-)\s*$/)
    {
     $obj->start_list('UL');
     $obj->print("<LI>");
    }
   else
    {
     $obj->start_list('DL');
     $obj->print("<DT>");
     if ($obj->{FNAME} =~ /^options/ && $term =~ m#^Name:\s+<B>(\w+)</B>\s*$#)
      {
       $obj->print("<A NAME=$1>");
       $HTML::option{$1} = $obj;
       $obj->print($term);
       $obj->print("</A>");
      }
     else
      {
       $obj->print($term);
      }
     $obj->print("<DD>");
    }
  }
 else
  {
   $obj->para;
  }
}
sub TP
{
 my $obj = shift;
 my $heading = <>;
 IP($obj,fontstuff($heading));
}
sub RS
{
 my $obj = shift;
 # $obj->force_list('DL');
}
sub RE
{
 my $obj = shift;
 # $obj->end_list();
}                             
sub dummy
{
 my $name = shift;
 my $obj  = shift;
 # print STDERR ".$name ",join(' ',@_),"\n";
}
sub ft
{
 my ($obj,$arg) = @_;
 if ($arg eq 'CW')
  {
   $obj->tag('PRE');
  }
 else
  {
   $obj->tag('/PRE');
  }
}
my $name;
foreach $name (qw(rn ne tr ie ds el if rr nr IX UC bd rm))
 {
  *{"$name"} = sub { dummy($name,@_) };
 }
%special = ('&' => 'amp', '<' => 'lt', '>' => 'gt');
                             
sub fontstuff
{
 local ($_) = shift;
 s/\\0/ /g;
 s/\\ / /g; # Make &xx; ??
 s/\\&//g;
 s/\\\*\([LR](['"])/$1/g;
 s/([<&>])/'&'.$special{$1}.';'/eg; 
 if (/\\f/)
  {        
   s/\\f\(CW(.*?)(?=\\f)/<CODE>$1<\/CODE>/g;
   s/\\fC(.*?)(?=\\f)/<CODE>$1<\/CODE>/g;
   s/\\f([IB])(.*?)(?=\\f)/<$1>$2<\/$1>/g;
   s/\\f([IB])(.*?)$/<$1>$2<\/$1>/;
   s/\\fC(.*?)$/<CODE>$2<\/CODE>/;
   s/\\f[RP]//g;
  }        
 s/\\-/-/g;
 s/\\\^//g;
 s/\\\(\+-/&#177;/g;
 s/\\e/\\/g;
 return $_;
}
sub doline
{
 local $_ = shift;
 if (/^'/)
  {
   $html->comment($1) if (m#^'[\\/]"(.*$)#);
   return;
  }
 return if (/^\.\s*\\"/);
 while (/^\..*\\$/)
  {
   chomp;
   $_ .= <>;
  }
 # Do the font changes first
 if (/^\.de\s+(\w+)/)
  {
   my $name = $1;
   my @lines = ();
   while (<>)
    {
     last if (/^\.\./);
     push(@lines,$_);
    }
   $macro{$name} = \@lines;
  }
 elsif (/^\.\s*if\s+.*\\\{/)
  {
   my $count = 1;
   while (<>)
    {
     $count++ if (/\\\{/);
     $count-- if (/^\.\\\}/);
     last unless ($count);
    }
  }
 elsif (/^\.\\\}/)
  {
   chomp;
   die $_;
  }
 elsif (/^\.\s*(\w+)\s*(.*)$/)
  {
   my $cmd = $1;
   my $arg = $2;
   my @arg = ();
   while ($arg =~ /\S/)
    {
     $arg =~ s/^\s+//;
     if ($arg =~ s/^"([^"]*)"//)
      {
       push(@arg,$1) 
      }
     else
      {
       $arg =~ s/\S+//;
       push(@arg,$&) 
      }
    }
   if (defined &$cmd)
    {
     &{$cmd}($html,map(fontstuff($_),@arg));
    }
   elsif (exists $macro{$cmd})
    {
     my $line;
     my @line = @{$macro{$cmd}};
     foreach $line (@line)
      {
       if ($line =~ /\\\\\$(\d+)/)
        {
         $line =~ s/\\\\\$(\d+)/$arg[$1-1]||''/eg;
        }
       doline($line);
      }
    }
   else
    {
     chomp;
     die "No $_ ($ARGV:$.)";
    }
  }               
 else
  {
   $_ = fontstuff($_);
   s/See\s+the\s+(.*?)\s+manual\s+entry/$html->Xref("See the ",$1,""," manual entry")/ieg;
   s#(See\s+)(<B>.*?</B>)(\s+for)#$html->Xref($1,$2,"",$3)#ieg;
   s/(\s+)([`'A-Z ]+)\s+(above|below)/$html->Xref($1,"",$2," ".$3)/eg;
   if ($opt_tk && /^(\w+)\s*\\?-\s*Create\s+and\s+manipulate\s+.*\bwidgets\s*$/)
    {
     $Widgets{$1} = $html;
    }
   if ($Verbose && $HTML::enabled && /\bsee\b/i && !/HREF=/)
    {
     print "$ARGV:$.: $_";
     chmod(0644,$ARGV);
    }
   if (/^\S.*?:\t.*\S.*$/)
    {
     IP($html,$_);
    }
   else
    {
     $html->text($_);
    }
  }
}
sub process
{
  @ARGV = @_;
  local $html;
  while (<>)
   {
    if ($. == 1)
     {
      my $file = $ARGV;          
      $file =~ s/\.[^.]*$/.$opt_suffix/;
      $file =~ s#^.*/##;
      $html->close if (defined $html);
      $html = HTML->new($file);
     }
    doline($_);
    $. = 0 if eof;
   }
}
@ARGV = <man/*.[3n]> unless (@ARGV);
die "No files !" unless (@ARGV);
@files = @ARGV;
print STDERR "Pass 1\n";
process(@files);
HTML->Enable;
print STDERR "Pass 2\n";
process(@files);
if (@files > 1)
 {
  my $toc = HTML->new("index.html",Description => "perl/Tk Documentation");
  $toc->Document("Tk Documentation Table of Contents");
  $toc->tagged('H1',"Tk Documentation Table of Contents");
  if ($opt_tk)
   {
    $toc->print('<A HREF="license.html"> License terms</A>');
    SH($toc,"Tk Widget Classes");
    $toc->force_list('DIR');
    foreach (sort keys %Widgets)
     {             
      my $obj = $Widgets{$_};
      $toc->print("<LI>",$obj->Link($obj,"")," ",$obj->description,"\n");
     }             
    $toc->end_list;
   }
  foreach $cat (sort keys %Cat)
   {
    print "$cat\n";
    SH($toc,$cat);
    $toc->force_list('DIR');
    foreach (sort keys %{$Cat{$cat}})
     {
      next if exists $Widgets{$_};
      my $obj = $Cat{$cat}{$_};
      $toc->print("<LI>",$obj->Link($obj,"")," ",$obj->description,"\n");
     }
    $toc->end_list;
   }
  $toc->close;
 }