#!/itl/links/generic/bin/perl  -w

### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
###
### TreeDec is a research product of the Information Technology
### Technology Laboratory (ITL) of the National Institute of Standards and
### Technology (NIST).  Since NIST is an agency of the Federal government,
### this software is not subject to copyright.  We ask anyone who uses or
### distributes this source code to include this notice.
###
###  Primary author: John Cugini / CUZ@NIST.GOV
###  Version Date:   2001-April-6
###
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###
### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###

### ### ### ### ### ### ### ### ### ### ### ### ### ###
###
### Main purpose: decorate pages of a website with tree-inspired
### links so as to allow easy navigation.
###
### Two Input files:
###    td-config.dat: A configuration file to control how TreeDec
###                   goes about its decoration chores
###
###    td-tree.dat: The file specifying the logical tree to be
###                 implemented.
###
### Output:
###    TreeDec can either re-write all the pages of a website, or
###    create a new decorated copy.
###
###    Messages are written to the stdout and to a message file.
###
### ### ### ### ### ### ### ### ### ### ### ### ### ###

### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub msg

# write message to file and print it out
{
    my ($p1) = @_;
    print         $p1;
    print MSGFILE $p1;
    return (0);
}

### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub errmsg

# write error message and increment error-count
{
    msg ("ERROR: $_[0] \n");
    $num_errs++;
    return (0);
}

### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub infmsg

# write info message
{
    msg ("INFO: $_[0] \n");
    return (0);
}

### ### ### ### ### ### ### ### ### ### ### ### ### ###
sub ptr_path

# generate anchor from @path_list to targetfile
{
    my $ix;
    @to_list = split (/$dir_sep/, $_[0]);

    ## count same levels at top
    for ($ix=0 ; $ix < $#to_list && $ix < $#path_list; $ix++)
    {
       if ($path_list[$ix] ne $to_list[$ix])
       {  last; }
    }

    ## $ix points at first distinct element.

    $climb_up   = $dir_parent x ($#path_list - $ix);
    $climb_down = join ($dir_sep, @to_list[$ix..$#to_list]);

    ##DB print "up/down = $climb_up $climb_down \n";

    return ("<A\n" . 'href="' . $climb_up .  $climb_down . '">');
}

### ### ### ### ### ### ### ### ### ### ### ### ### ###
### ### ### ### ###     MAIN-LINE   ### ### ### ### ###
### ### ### ### ### ### ### ### ### ### ### ### ### ###

   print "----------   Begin TreeDec   ----------\n";

   open (MSGFILE, ">td-msg.txt") ||
      die "Could not open message file for output.\n";
   $num_errs = 0;

   ## parameter defaults
   $undo = 0;

   foreach $arg (@ARGV)
   {
      if ($arg eq "undo")
      {  $undo = 1;
         infmsg ("Undo parameter => undecorate files.");
      }
      else
      {  errmsg ("Mystery parameter: $arg");
      }
   }

   open (CFILE, "<td-config.dat") ||
      die "Could not open configuration file for input.\n";
   open (TFILE, "<td-tree.dat")   ||
      die "Could not open tree file for input.\n";

### set defaults
   $dir_sep = "/";
   $do_ancestors = 1;
   $do_siblings  = 1;
   $do_children  = 1;
   $ancestor_bg  = "#ffaaaa";
   $sibling_bg   = "#ffff66";
   $children_bg  = "#aaaaff";
   ## $ancestor_fg  = "#770000";
   ## $sibling_fg   = "#777700";
   ## $children_fg  = "#000077";
   $ancestor_sep = " -&gt; ";
   $ok_option  = "a";
   $err_option = "n";
   $insert_after   = "<body>";
   $case_sensitive = 1;
   $tempfile_dir = "tmpweb";
   $mark_start = "<!-- START TREE DECORATION -->";
   $mark_stop  = "<!-- END TREE DECORATION -->";

### read in config file

   while ($crec = <CFILE>)
   {
      next if ($crec =~ m%\A#%);  # skip comments
      chomp($crec);

      ## parse for keyword=value
      if ($crec =~ m%\A(\w+)=(.+)\Z%)
      {  $kw  = $1;
         $val = $2;
      }
      else
      {  errmsg ("Cannot parse config rec: $crec");
         next;
      }

      if ($val =~ m%\A"(.*)"\Z%)
      {  # strip off quotes
         $val = $1;
      }

      ### ### ### ### ###  Look for keyword  ### ### ### ### ###
      if ($kw eq "dir_sep")
      {
         if (length $val == 1)
         {  $dir_sep = $val;
         }
         else
         {  errmsg ("dir_sep must be a single character: $crec");
         }
      }

      elsif ($kw =~ m%\Ado_(ancestors|siblings|children)\Z%)
      {
         $ctl_code = '$do_' . $1 . ' = ' . $val . ';';
         if ($val == 0 || $val  == 1)
         {  eval $ctl_code;
         }
         else
         {  errmsg ("Value should be 0 or 1 in config rec: $crec");
         }
      }

      ## handle colors
      elsif ($kw =~ m%\A(ancestor|sibling|children)(_bg)\Z%)
      {
         $color_code = '$' . $1 . $2 . ' = "' . $val . '";';

         if ($val !~ m%\A#[\da-fA-F]+\Z%)
         {  infmsg ("Non-hex-digit color code in config rec: $crec");
         }
         eval $color_code;
      }

      elsif ($kw eq "rewrite_option")
      {
         if ($val =~ m%\A([ran])([ranq])\Z%)
         {  $ok_option  = $1;
            $err_option = $2;
         }
         else
         {  errmsg ("Invalid rewrite value in config rec: $crec");
         }
      }

      ### no editing of the following

      elsif ($kw eq "ancestor_sep")
      {  $ancestor_sep = $val;
      }
      elsif ($kw eq "insert_after")
      {  $insert_after = $val;
         $case_sensitive = 1;
      }
      elsif ($kw eq "Insert_After")
      {  $insert_after = $val;
         $case_sensitive = 0;
      }
      elsif ($kw eq "tempfile_dir")
      {  $tempfile_dir = $val;
      }

      else
      {  errmsg ("Invalid keyword in config rec: $crec");
      }
   }
   close (CFILE);

### end config file

   if ($num_errs > 0 && $err_option eq 'q')
   {  infmsg ("$num_errs error(s) detected in config file - quit.");
      goto alldone;
   }

   infmsg ("CONFIG values:");

   infmsg ("dir_sep       = $dir_sep");
   infmsg ("do_ancestors  = $do_ancestors");
   infmsg ("do_siblings   = $do_siblings");
   infmsg ("do_children   = $do_children");
   infmsg ("ancestor_bg   = $ancestor_bg");
   infmsg ("sibling_bg    = $sibling_bg ");
   infmsg ("children_bg   = $children_bg");
   infmsg ("ancestor_sep  = $ancestor_sep");
   infmsg ("insert_after  = $insert_after");
   infmsg ("tempfile_dir  = $tempfile_dir");
   infmsg ("ok_option     = $ok_option");
   infmsg ("err_option    = $err_option");

   $dir_parent = "..$dir_sep";

   ### this is for the skeleton table of contents
   open (TOCFILE, ">td-toc.html") ||
      die "Could not open TOC file for output.\n";
   print TOCFILE
      "<!-- This file is a skeleton TOC, generated by TreeDec -->\n";
   print TOCFILE "<html><head><title>TOC for Website</title></head>\n";
   print TOCFILE "<body>\n";
   print TOCFILE "<h2>Table of Contents for Website</h2>\n";

### read in tree file
   $cur_level = -1;
   @cur_node  = ();
   $cur_label = "";

   while ($trec = <TFILE>)
   {
      next if ($trec =~ m%\A#%);  # skip comments
      chomp($trec);

      if ($trec =~ m%\A((   )*)(\S+) +(.+)\Z%)
      {  $new_level = length($1) / 3;
         $pathname  = $3;
         $title     = $4;
      }
      else
      {  errmsg ("Cannot parse tree rec: $trec");
         next;
      }

      if ($new_level > $cur_level + 1)
      {  errmsg ("Skipped over a level: $trec");
         next;
      }

      if ($pathname =~ m%\A$dir_sep%)
      {  errmsg ("Absolute pathnames not allowed: $trec");
         next;
      }
      if ($pathname =~ m%$dir_sep\Z%)
      {  errmsg ("Pathname must not end with directory separator: $trec");
         next;
      }

      ## get rid of junk in pathname
      while ($pathname =~ s%$dir_sep\.?$dir_sep%$dir_sep%)
      { ; }

      @tmpath = split (/$dir_sep/, $pathname);
      for ($ix=1 ; $ix <= $#tmpath ; $ix++)
      {
         if ($tmpath[$ix] eq ".." && $tmpath[$ix-1] ne "..")
         {
            splice (@tmpath, $ix-1, 2);
            $ix -= 2;
         }
      }
      $pathname = join ($dir_sep, @tmpath);
      ##DB print "cleaned-up pathname = $pathname\n";

      ## handle TOCFILE
      if ($new_level == $cur_level + 1)
      {  $cur_node[$new_level] = 1;
         print TOCFILE "<ul>\n";
      }
      else
      {  $cur_node[$new_level]++;
         print TOCFILE ("</ul>" x ($cur_level - $new_level)), "\n";
      }
      print TOCFILE '<LI><a href="', $pathname, '">';
      print TOCFILE "$title</a>\n";

      $cur_level = $new_level;
      splice (@cur_node, $cur_level+1);

      ## convert array to string to use as hash key -
      $cur_label = join (".", @cur_node);

      ## this is the form in which we save the tree...
      $file_hash {$cur_label} = $pathname;
      $title_hash{$cur_label} = $title;

      ##DB print "Stored under $cur_label: $pathname, $title\n";
   }
   close (TFILE);

   print TOCFILE ("</ul>" x ($cur_level + 1)), "\n";
   print TOCFILE "End of Table of Contents\n";
   print TOCFILE "</body>\n</html>\n";
   close (TOCFILE);
### end tree file

   if ($num_errs > 0 && $err_option eq 'q')
   {  infmsg ("$num_errs error(s) detected in tree file - quit.");
      goto alldone;
   }

   if ($do_ancestors + $do_siblings + $do_children < 1)
   {  infmsg ("Done, TOC only, no decorations requested.");
      goto alldone;
   }

   $the_option = $num_errs ? $err_option : $ok_option;

   if ($the_option eq 'n')
   {  infmsg ("Done, TOC only, no rewrite requested for #errors = $num_errs");
      goto alldone;
   }

### ### ###    loop thru all the pages and decorate them    ### ### ###

   foreach $treekey (keys %file_hash)
   {
      ##  get name of input file
      $webin = $file_hash{$treekey};

      if (! open (WEBIN, "< $webin"))
      {  errmsg ("Cannot open $webin for input.");
         next;
      }

      ##  get name of output file
      $webout = $tempfile_dir . $dir_sep . $webin;

      if (! open (WEBOUT, "> $webout"))
      {  errmsg ("Cannot open $webout for output.");
         next;
      }

      ## convert pathname to a list.
      @path_list = split (/$dir_sep/, $webin);

      ## convert tree node label to a list
      @tree_list = split (/\./, $treekey);

      $insert_count = 0;
      ### loop thru HTML file and try to make a decorated copy
      while ($wrec = <WEBIN>)
      {
         chomp($wrec);
         if ($wrec eq $mark_start)
         {  ## old TreeDec decoration - gotta skip it
            ##DB print "Found start of old decorations in $webin\n";

            while ($wrec = <WEBIN>)
            {  chomp($wrec);
               if ($wrec eq $mark_stop)
               {  last; }  ## OK, got past old decoration
            }

            if ($wrec eq $mark_stop)
            {  next;  ## skip to 1st non-old-decoration record
            }

            errmsg ("Did not find end of old decorations in $webin.  File undecorated.");
            last;
         }

         ## look for insert marker - use minimal matching
         ##?? for now, case sensitive - maybe change someday ...
         
         if (($undo == 0) &&
               ($case_sensitive ? ($wrec =~ m%\A(.*?$insert_after)(.*)\Z%) 
                                : ($wrec =~ m%\A(.*?$insert_after)(.*)\Z%i) 
            )  )
         {  # found the insert marker
            print "found insert marker in $webin\n";
            $b4  = $1;
            $aft = $2;
         }
         else
         {  # nothing special -- just copy it and keep going
            print WEBOUT "$wrec\n";
            next;
         }

         ### we've found the insert marker ...
         $insert_count++;
         if ($insert_count > 1)
         {  next;  ## perform insert only at *1st* occurrence.
         }

         ## insert decorations here
         print WEBOUT "$b4\n";  ## from original file
         print WEBOUT "$mark_start\n";
         print WEBOUT '<TABLE WIDTH="100%" border=1 cellpadding=4>', "\n";
         print WEBOUT "<TBODY>\n\n\n";

         if ($do_ancestors)
         {
            print WEBOUT '<TR bgcolor="', $ancestor_bg, '">', "\n";
            print WEBOUT "<TD><b>Context:</b>\n<td>\n";

            for ($ix=0 ; $ix < $#tree_list; $ix++)
            {
               $to_key = join (".", @tree_list[0..$ix]);
               ## implictly coming from @path_list
               $anch = ptr_path ($file_hash{$to_key});
               print WEBOUT $anch, $title_hash{$to_key}, "</a>",
                            $ancestor_sep;
            }
            print WEBOUT "<b>$title_hash{$treekey}</b>\n\n\n";
         }

         if ($do_siblings)
         {
            $parent_key = join (".", @tree_list[0..$#tree_list-1]);
            $this_sib = $tree_list[$#tree_list];

            if (exists $file_hash {$parent_key . ".2"})
            {  ## OK, this is NOT an only child
               print WEBOUT '<TR bgcolor="', $sibling_bg, '">', "\n";
               print WEBOUT "<TD><b>Related:</b>\n<td>\n";

               $title_sep = "";
               for ($ix=1 ; 1; $ix++)
               {
                  $to_key = $parent_key . ".$ix";
                  if ( ! exists $file_hash {$to_key})
                  {  last; }

                  if ($ix == $this_sib)
                  {  print WEBOUT $title_sep, "<b>$title_hash{$to_key}</b>";
                  }
                  else
                  {
                     $anch = ptr_path ($file_hash{$to_key});
                     print WEBOUT $title_sep, $anch,
                                  $title_hash{$to_key}, "</a>";
                  }
                  $title_sep = ",\n";
               }  ## end loop thru sibs
               print WEBOUT "\n\n\n";

            }  ## end got_sibs
         }  ## end do_sibs

         if ($do_children)
         {
            ## check for children existence
            if (exists $file_hash {$treekey . ".1"})
            {  print WEBOUT '<TR bgcolor="', $children_bg, '">', "\n";
               print WEBOUT "<TD><b>Details:</b>\n<td>\n";

               $title_sep = "";
               for ($ix=1 ; 1; $ix++)
               {
                  $to_key = $treekey . ".$ix";
                  if ( ! exists $file_hash {$to_key})
                  {  last; }

                  $anch = ptr_path ($file_hash{$to_key});
                  print WEBOUT $title_sep, $anch,
                               $title_hash{$to_key}, "</a>";
                  $title_sep = ",\n";
               }  ## end loop thru sibs
               print WEBOUT "\n\n\n";
            }
         }

         print WEBOUT "</TBODY></TABLE>\n";
         print WEBOUT "$mark_stop\n";
         print WEBOUT "$aft\n";  ## from original file
      }  ## end loop thru copy of HTML file

      if ($undo)
      {  infmsg ("Undecorated: $webin");
      }
      else
      {  if ($insert_count < 1)
         {  errmsg ("Did not find insert marker in $webin.");
         }
         elsif ($insert_count > 1)
         {  errmsg ("Insert marker found $insert_count times in $webin.");
         }
         else
         {  infmsg ("Decorated: $webin");
         }
      }

      close (WEBIN);
      close (WEBOUT);

   }  ## end loop thru all HTML files

### ### ###    replace original files?   ### ### ###

   if ($num_errs > 0 && $err_option eq 'q')
   {  infmsg ("$num_errs error(s) detected - omit rewrite.");
      goto alldone;
   }

   $the_option = $num_errs ? $err_option : $ok_option;

   if ($the_option eq 'n')
   {  infmsg ("Done, TOC only, no rewrite requested for #errors = $num_errs");
      goto alldone;
   }

   if ($the_option eq 'a')
   {  ## ask what to do
      while (1)
      {
         print "Rewrite all website files (y or n)?\n";
         $response = <STDIN>;

         if ($response =~ m%\Ay%)
         {  last;
         }
         elsif ($response =~ m%\An%)
         {  goto alldone;
         }
         else
         {  print "Response must start with the letter y or n\n";
         }
      }
   }

   foreach $treekey (keys %file_hash)
   {  ##  get name of input file
      $webin = $file_hash{$treekey};

      ##  get name of output file
      $webout = $tempfile_dir . $dir_sep . $webin;
      rename $webout, $webin;
      infmsg ("Overwritten: $webin");
   }

### ### ###    we're done    ### ### ###

alldone:
   if ($num_errs == 0)
   {  infmsg ("Normal completion with no errors.");
   }
   else
   {  infmsg ("Completed with $num_errs error(s).");
   }

   close (MSGFILE);