#!/usr/local/bin/perl -w

$Verbose = 0;

use strict qw(subs);
use Carp; 

{
 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";
  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)
   {
    open($file,">$file") || die "Cannot open $file:$!";
   }
  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 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
  {
   return 'HREF="' . shift->{'FNAME'} . '"';
  }

 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]/);
     }
   }
  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);
         }
        $text .= " $sec";
       }
     }
   }
  if (defined $href)
   {
    return "<A $href> $text</A>";
   }
  else
   {
    if ($enabled)
     {
      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 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/i)
   {
    my $head = $line; 
    $head =~ s/\s*-.*$//;
    my $key;
    foreach $key (split(/\s*,\s*/,$head))
     {
      last if $key =~ /-/;
      $Document{$key} = $obj;
     }
   }
  $obj->print($line);
  $obj->print("<BR>") unless ($obj->{'FILL'});
  $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)
   {
    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->print("<A NAME=$name>");
     $obj->tagged('H2',$arg);
     $obj->print("</A>");
    }
   else
    {
     $obj->tagged('H2',$arg);
    }
  }

}

sub so 
{ 
}

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");
}

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 (defined $dir)
  {
   $obj->print("($dir) ");    
  }
 $obj->print("<DD>");
}

sub PP
{ 
 my $obj = shift;
 $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;

}

sub VE
{
 my $obj = shift;

}

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 IP
{ 
 my $obj = shift;
 if (@_)
  {
   my $term = shift;
   $obj->start_list('DL');
   $obj->print("<DT>$term\n");
   $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();
}

%special = ('&' => 'amp', '<' => 'lt', '>' => 'gt');
                            
sub fontstuff
{
 local ($_) = shift;
 s/\\0/ /g;
 s/\\ / /g; # Make &xx; ??
 s/\\&//g;
 s/([<&>])/'&'.$special{$1}.';'/eg; 
 if (/\\f/)
  {        
   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 process
{
  @ARGV = @_;
  local $html;
  while (<>)
   {
    if ($. == 1)
     {
      my $file = $ARGV;          
      $file =~ s/\.[^.]*$/.ht/;
      $file =~ s#^.*/##;
      $html->close if (defined $html);
      $html = HTML->new($file);
     }
    if (m#^'[\\/]"(.*$)#)
     {
      $html->comment($1);
      next;
     }
    # Do the font changes first
    $_ = fontstuff($_);
    if (/^\.(\w+)\s*(.*)$/)
     {
      my $cmd = $1;
      my @arg = split(/\s+/,$2);
      if (defined &$cmd)
       {
        &{$cmd}($html,@arg);
       }
      else
       {
        chomp;
        die "No $_ ($ARGV:$.)";
       }
     }
    else
     {
      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 (/-\s*Create.*\s(\w+)\s*widgets\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($_);
       }
     }
    $. = 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("tk_toc.ht");

  $toc->Document("Tk Documentation Table of Contents");

  $toc->print('<A HREF="license.terms.ht"> License terms</A>');
                 
  SH($toc,"Widgets");
  $toc->force_list('DIR');
  foreach (sort keys %Widgets)
   {             
    my $obj = $Widgets{$_};
    $toc->print("<LI>",$obj->Link($obj,""),"\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,""),"\n");
     }
    $toc->end_list;
   }

  $toc->close;
 }


