#
# Copyright (C) Motorola 2001 - All rights reserved
#
# This software is an extension to the TWiki system and is
# to be regarded as a derivative work covered by the same licenses 
# and copyrights.
#
# TWiki extension that adds tags for the generation of tables of contents.
#
use strict;
use integer;
use wiki;

# Class of attribute sets
{ package Attrs;

  # Parse a standard attribute string containing name=value pairs. The
  # value may be a word or a quoted string (no escapes!)
  sub new {
      my ($class, $string) = @_;
      my $this = {};

      if (defined($string)) {
	  # name="value" pairs
	  while ($string =~ s/([a-z]+)\s*=\s*\"([^\"]*)\"//o) {
	      $this->{$1} = $2;
	  }
	  # name=value pairs
	  while ($string =~ s/([a-z]+)\s*=\s*([^\s,\}]*)//o) {
	      $this->{$1} = $2;
	  }
	  # simple name with no value (boolean)
	  while ($string =~ s/([a-z]+)//o) {
	      $this->{$1} = 1;
	  }
      }
      return bless $this, $class;
  }

  # Get an attr value; return undef if not set
  sub get {
      my ($this, $attr) = @_;
      return $this->{$attr};
  }
} # end of class Attrs

# Class of target anchors
{ package Anchor;

  # Constructor
  sub new {
      my ($class, $type, $name, $text, $visible) = @_;
      my $this = {};
      $this->{TYPE} = $type;
      $this->{NAME} = $name;
      $this->{TEXT} = $text;
      $this->{IS_VISIBLE} = $visible;
      return bless($this, $class);
  }

  sub type {
      my $this = shift;
      if (@_) { $this->{TYPE} = shift; };
      return $this->{TYPE};
  }

  sub name {
      my $this = shift;
      if (@_) { $this->{NAME} = shift; };
      return $this->{NAME};
  }

  sub text {
      my $this = shift;
      if (@_) { $this->{TEXT} = shift; };
      return $this->{TEXT};
  }

  sub visible {
      my $this = shift;
      if (@_) { $this->{IS_VISIBLE} = shift; };
      return $this->{IS_VISIBLE};
  }

  # Generate HTML to anchor the link
  sub generateTarget {
      my $this = shift;
      my $text = "<A name=\"";
      $text = $text . $this->type() . "_" . $this->name() . "\">";
      if ($this->visible()) {
	  $text = $text . " " . $this->text();
      }
      $text = $text . " </A>";
      return $text;
  }

  # Generate HTML to target the link
  sub generateReference {
      my ($this, $topic) = @_;

      my $tgt = "";
      if ($topic) {
	  $tgt = $topic->wikiName();
      }
      $tgt = $tgt . "#" . $this->type() . "_" . $this->name();
      return "<A href=\"". $tgt . "\"> " . $this->text() . " </A>";
  }

  # Generate a string representation for debugging
  sub toString {
      my $this = shift;
      return "#" . $this->type() . "_" . $this->name();
  }
} # end of package Anchor

# A node in the tree of sections
{ package Section;

  @Section::ISA = ("Anchor");

  sub new {
      my ($class, $level, $text) = @_;

      my $this = $class->SUPER::new("Section", $level, $text, 1);

      # array of subsections
      $this->{SECTIONS} = [];
      # depth of this section in the section hierarchy
      $this->{LEVEL} = $level;
      # parent section
      $this->{PARENT} = undef;
      # position in the parent section's subsection list
      $this->{POSITION} = undef;
      # link anchors targetting this section
      $this->{ANCHORS} = {};
      # files only - wiki name of this section
      $this->{WIKINAME} = undef;
      # file only - has been loaded
      $this->{IS_LOADED} = undef;

      return bless($this, $class);
  }

  sub level {
      my $this = shift;
      if (@_) { $this->{LEVEL} = shift; };
      return $this->{LEVEL};
  }

  sub parent {
      my $this = shift;
      if (@_) { $this->{PARENT} = shift; };
      return $this->{PARENT};
  }

  sub position {
      my $this = shift;
      if (@_) { $this->{POSITION} = shift; };
      return $this->{POSITION};
  }

  sub wikiName {
      my $this = shift;
      if (@_) { $this->{WIKINAME} = shift; };
      return $this->{WIKINAME};
  }

  # Get the list of anchors for a given gey
  sub anchors {
      my ($this, $key) = @_;
      die unless defined($key);
      if (defined($this->{ANCHORS}->{$key})) {
	  return @{$this->{ANCHORS}->{$key}};
      } else {
	  return [];
      }
  }

  # Generate a decorated target for this section
  sub generateTarget {
      my $this = shift;
      my $topic = $this->_getTopic();
      my $level = $this->level() - $topic->level();
      my $text = "";

      # For SECTION0 use <H1>
      if ($level <= 0) {
	  $level = 1;
      }

      $text = $this->SUPER::generateTarget();

      my $key;
      foreach $key (keys %{$this->{ANCHORS}}) {
	  my $link;
	  foreach $link ( $this->anchors($key) ) {
	      $text = $text . $link->generateTarget() . "\n";
	  }
      }

      return "<H" . $level . ">\n" . $text . "\n</H" . $level . ">";
  }

  # add a new subsection to the end of our list of subsections
  sub _push_back {
      my ($this, $that) = @_;

      push @{$this->{SECTIONS}}, $that;
      
      $that->parent($this);
      $that->position(scalar(@{$this->{SECTIONS}}));
  }

  # Get the root from within a topic
  sub _getRoot {
      my $this = shift;

      while (defined($this->parent())) {
	  $this = $this->parent();
      }
      return $this;
  }

  # Get the topic that contains this section
  sub _getTopic {
      my $this = shift;

      if (defined($this->wikiName()) || !defined($this->parent())) {
	  return $this;
      }
      return $this->parent()->_getTopic();
  }

  # Get the wiki name of the topic that is, or contains, this
  sub _getTopicURL {
      my $this = shift;
      return $this->_getTopic()->wikiName();
  }

  # Get the most recently added subsection
  sub _getLastSubsection {
      my $this = shift;
      return @{$this->{SECTIONS}}[$#{$this->{SECTIONS}}];
  }

  # add a new subsection at, or below, the level of this section.
  sub _addSection {
      my ($this, $newEntry) = @_;

      if ($newEntry->level() == $this->level() + 1) {
	  # add at this level
	  $this->_push_back($newEntry);
      } else {
	  # add to the last entry added
	  if (scalar(@{$this->{SECTIONS}}) == 0) {
	      # insert a pseudo-section to compensate for the
	      # missing section level
	      my $tmp = Section->new($this->level() + 1, "_missing_");
	      $this->_push_back($tmp);
	  }
	  $this->_getLastSubsection()->_addSection($newEntry);
      }
  }

  # Add a reference.
  sub _addAnchor {
      my ($this, $type, $name, $text, $visible) = @_;

      my $pretext = $this->_getSectionNumber();
      if ($type ne "Section") {
	  my $idx = 0;
	  if (defined($this->{ANCHORS}->{$type})) {
	      $idx = @{$this->{ANCHORS}->{$type}};
	  }
	  $pretext = $type . " " . $pretext . 
	      pack("c", ord("A") + $idx);
      }
      my $ref = Anchor->new($type, $name,
			  $pretext . " " . $text . " ", $visible);
      push(@{$this->{ANCHORS}->{$type}}, $ref);
      return $ref;
  }

  # Get the unique section number for this section.
  sub _getSectionNumber {
      my $this = shift;

      my $parent = $this->parent();
      if (!defined($parent)) {
	  return "";
      } else {
	  return $parent->_getSectionNumber() . $this->position() . ".";
      }
  }

  # Convert to a string for debugging
  sub toString {
      my ($this, $indent) = @_;

      if (!defined($indent)) {
	  $indent = "";
      }
      my $res = $indent . $this->_getSectionNumber() . " " .
	  $this->text();
      if (defined($this->wikiName())) {
	  $res = $res . " is file " . $this->_getTopicURL();
      }
      
      my $key;
      foreach $key (keys %{$this->{ANCHORS}}) {
	  $res = $res . "\n" . $indent . "...";
	  my $link;
	  foreach $link ( @{$this->{ANCHORS}->{$key}} ) {
	      $res = $res . " " . $link->toString();
	  }
      }
      $res = $res . "\n";

      my $child;
      foreach $child ( @{$this->{SECTIONS}} ) {
	  $res = $res . $child->toString($indent . "  ");
      }
      return $res;
  }

  # Find a link target and return the topic and the link
  sub _findTarget {
      my ($this, $type, $name) = @_;

      # find the tag
      my $link;
      foreach $link ( @{$this->{ANCHORS}->{$type}} ) {
	  if ($link->name() eq $name) {
	      return ($this, $link);
	  }
      }

      my $section;
      foreach $section ( @{$this->{SECTIONS}} ) {
	  my ($sec, $link) = $section->_findTarget($type, $name);
	  if ($link) { return ($sec, $link) };
      }
      return undef;
  }

  # Find a FILE topic in the TOC
  sub _findTopic {
      my ( $this, $wikiName ) = @_;
      
      if (defined($this->wikiName()) && $wikiName eq $this->wikiName()) {
	  return $this;
      }

      my $section;
      foreach $section ( @{$this->{SECTIONS}} ) {
	  my $found = $section->_findTopic($wikiName);
	  if (defined($found)) {
	      return $found;
	  }
      }

      return undef;
  }

  # Generate table of contents for this section
  sub processTOCTag {
      my ($this, $attrs) = @_;
      my $attrSet = Attrs->new($attrs);
      my $topic = $attrSet->get("topic");
      if ($topic) {
	  $topic = TOC::_tocEntryToWikiName($topic);
	  $this = $this->_getRoot()->_findTopic($topic);
	  if (!$this) {
	      return TOC::_error("Bad topic $topic");
	  }
      }
      my $depth = $attrSet->get("depth");

      return $this->_generateTOCEntry(1, $depth);
  }

  # Generate a prettifying indent to make the HTML readable
  sub _indent {
      my $level = shift;
      my $text = "";
      for (my $i = 0; $i < $level; $i++) {
	  $text = $text . "  ";
      }
      return $text;
  }

  # Generate table of contents rows for this section and it's children
  sub _generateTOCEntry {
      my ($this, $level, $depth) = @_;

      my $row = _indent($level);
      if ($level > 1) {
	  $row = $row . $this->generateReference() . " <BR>";
      }

      if (defined($depth)) {
	  return $row if ($level == $depth + 1);
      }

      if (defined($this->wikiName()) && !defined($this->{IS_LOADED})) {
	  $this->_loadTopic();
      }

      if (scalar(@{$this->{SECTIONS}})) {
	  $row = $row . _indent($level) . "<UL>\n";
	  my $section;
	  foreach $section ( @{$this->{SECTIONS}} ) {
	      $row = $row . $section->_generateTOCEntry($level + 1, $depth);
	  }
	  $row = $row . _indent($level) . "</UL>\n";
      }
      return $row;
  }

  # Load the topic into this section
  sub _parseTopicText {
      my ($this, $text) = @_;

      while ($text =~ s/%(SECTION[0-9]+|ANCHOR)({[^%]*})?%(.*)//o) {
	  my $key = $1;
	  my $attrs = $2;
	  my $title = $3;
	  if ($key =~ s/([0-9]+)//o) {
	      $this->processSECTIONTag($attrs, $1, $title);
	  } else {
	      $this->processANCHORTag($attrs, $title);
	  }
	  # recursively parse the title text
	  $this->_parseTopicText($title);
      }
  }

  # Load the sections for a topic from the data directory
  sub _loadTopic {
      my $this = shift;
      my $topic = $this->_getTopicURL();
      if ($topic) {
	  my $text = wiki::readTopic($topic);
	  $text =~ s/\r//go;
	  $this->_parseTopicText($text);
	  $this->{IS_LOADED} = 1;
      }
  }

  # Process a SECTION tag
  sub processSECTIONTag {
      my ($this, $attrs, $secLevel, $title) = @_;

      my $attrSet = Attrs->new($attrs);
      my $noTagsTitle = " " . TOC::_removeAllTags($title);
      my $ne;
      if ($secLevel > 0) {
	  my $level = $this->level() + $secLevel;
	  $ne = Section->new($level, $noTagsTitle);
	  $this->_addSection($ne);
	  # We know the section number now, so adjust
	  # the name and text.
	  my $sec = $ne->_getSectionNumber();
	  $ne->name($sec);
	  $ne->text($sec . " " . $ne->text());
      } else {
	  # level 0; referring to this section
	  $ne = $this;
	  # N.B. Text after a %SECTION0% tag is ignored
      }
      # add an extra anchor if so requested
      my $link = $attrSet->get("name");
      if (defined($link)) {
	  $ne->_addAnchor("Section", $link, $noTagsTitle, 0);
      }
      return $ne;
  }

  # Process an ANCHOR tag
  sub processANCHORTag {
      my ($this, $attrs, $title) = @_;

      my $attrSet = Attrs->new($attrs);
      my $noTagsTitle = " " . TOC::_removeAllTags($title);
      my $type = $attrSet->get("type");
      my $name = $attrSet->get("name");
      my $display = $attrSet->{"display"};
      my $visible = (!$display || $display ne "no");
      return undef unless (defined($type) && defined($name));
      # Add the anchor to the last subsection under this
      my $lss = $this;
      while (scalar(@{$lss->{SECTIONS}})) {
	  $lss = $lss->_getLastSubsection();
      }
      return $lss->_addAnchor($type, $name, $noTagsTitle, $visible);
  }

  # Process a REF tag and return the topic and the link
  sub processREFTag {
      my ($this, $attrs, $text) = @_;

      my $attrSet = Attrs->new($attrs);
      my $type = $attrSet->get("type");
      my $topic = $attrSet->get("topic");
      my $name = $attrSet->get("name");

      if ($topic) {
	  $topic = TOC::_tocEntryToWikiName($topic);
	  $this = $this->_getRoot()->_findTopic($topic);
	  if (!$this) {
	      return undef;
	  }
      }
      return $this->_findTarget($type, $name);
  }

  # Generate a table of contents.
  # REFTABLE tag implementation
  sub processREFTABLETag {
      my ( $this, $attrs ) = @_;
      my $attrSet = Attrs->new($attrs);
      my $type = $attrSet->get("type");

      return TOC::_error("Bad type in REFTABLE") unless (defined($type));
      my $table = "<TABLE cols=1 border=2>\n<TR><TD width=\"10%\"> *$type* " .
	  "</TD></TR>\n";
      
      $table = $table . $this->_generateRefRow($type);
      
      return $table . "</TABLE>\n";
  }

  sub _generateRefRow {
      my ($this, $type) = @_;
      my $row = "";

      if (defined($this->wikiName()) && !defined($this->{IS_LOADED})) {
	  $this->_loadTopic();
      }

      # find the tag
      my $topic = $this->_getTopic();
      my $link;
      foreach $link ( @{$this->{ANCHORS}->{$type}} ) {
	  $row = $row . "<TR><TD> " .
	      $link->generateReference($topic) . " </TD><TR>\n";
      }

      my $section;
      foreach $section ( @{$this->{SECTIONS}} ) {
	  $row = $row . $section->_generateRefRow($type);
      }
      return $row;
  }
}

{ package TOC;
  @TOC::ISA = ("Section");

  sub new {
      my $class = shift;
      my $this = $class->SUPER::new(0, "");
      $this->{CURRENT_TOPIC} = undef;
      return bless($this, $class);
  }

  # Create a red string
  sub _error {
      my ( $text ) = @_;
      return "<FONT color=#ff0000>$text</FONT>";
  }

  # remove tags of a given type from a string
  sub _removeTypeTags {
      my ($type, $text) = @_;
      $text =~ s/%$type({[^%]*})?%//go;
      return $text;
  }

  # Remove all types of TOC tag from the string
  sub _removeAllTags {
      my $text = shift;

      $text = _removeTypeTags("ANCHOR", $text);
      $text =~ s/%SECTION[0-9]+({[^%]*})?%//go;
      $text = _removeTypeTags("REFTABLE", $text);
      $text = _removeTypeTags("TOC", $text);
      $text = _removeTypeTags("TOCCHECK", $text);
      
      return $text;
  }

  # Find files in this web which are not listed in the table of contents topic
  # TOCCHECK tag implementation
  sub processTOCCHECKTag {
      my $this = shift;

      # Get list of files in the web
      chdir( "$wiki::dataDir/$wiki::webName" );
      my $cmd = "$wiki::lsCmd *.txt";
      my $fullText = `$cmd`;
      $fullText =~ s/\.txt//go;
      # ignore topics that start with "Web"
      $fullText =~ s/\nWeb.*//go;
      my @fullList = split( /\n/, $fullText );

      my $result = "";
      my $topic;
      foreach $topic ( @fullList ) {
	  if (!$this->_findTopic($topic)) {
	      $result = $result . "\n<LI>" . $topic . "</LI>";
	  }
      }
      if ($result ne "") {
	  $result = _error("The following topics were not found " .
			   "in the WebOrder:\n<OL>" . $result . "\n</OL>\n");
      }
      return $result;
  }

  # Modified version of internalLink from wiki.pm, required because the
  # original is rather overenthusiastic in reformatting the link.
  sub _expandOddLink {
      my( $topic ) = @_;

      # kill spaces and Wikify topic name
      $topic =~ s/^\s*//o;
      $topic =~ s/\s*$//o;
      $topic =~ s/^(.)/\U$1/o;
      $topic =~ s/\s([a-zA-Z0-9])/\U$1/go;
      return $topic;
  }

  # static method to convert a toc entry to a wiki word
  sub _tocEntryToWikiName {
      my $t  = shift;
      $t =~ s/^[\s*]*//o;
      $t =~ s/[\s*]*$//o;
      # expand [[odd link]]
      $t =~ s/\[\[([\w\s]+)\]\]/_expandOddLink($1)/eo;
      return $t;
  }

  # Factory method to construct from a list as contained in the WebOrder
  sub _constructFromTocList {
      my ($class, @list) = @_;

      my $root = TOC->new();
      my $tocEntry;

      foreach $tocEntry ( @list ) {
	  my $name = $tocEntry;
	  $name =~ s/^[\s\*]*//o;

	  my $level = 0;
	  while ($tocEntry =~ s/^(\t|   )//o) {
	      $level++;
	  };

	  my $ne = $root->processSECTIONTag("", $level, $name);
	  $ne->wikiName(_tocEntryToWikiName($name));
      }

      return $root;
  }

  # Set the current topic being read and flag it as loaded; we are
  # about to perform an operation that requires it.
  # Must only be applied to the root.
  sub _getCurrTopic {
      my $this = shift;
      my $currTopic = $this->{CURRENT_TOPIC};
      return $currTopic if ($currTopic);
      $currTopic = $this->_findTopic($wiki::topicName);
      if ($currTopic) {
	  $currTopic->{IS_LOADED} = 1;
      }
      $this->{CURRENT_TOPIC} = $currTopic;
      return $currTopic;
  }

  # Static instance; root of the table of contents
  my $toc;

  sub processTag {
      my ($tag, @params) = @_;

      if (!$toc) {
	  if (!&wiki::topicExists($wiki::webName, "WebOrder")) {
	      return _error("No WebOrder in $wiki::webName");
	  }
	  # load the table of contents topic
	  my $tocText = &wiki::readTopic("WebOrder");
	  # allow [[Odd Wiki Word]] links
	  my @tocNames = split( /[\n\r]/, $tocText );
	  # extract the bulleted list
	  @tocNames = grep( /^\s+\*\s/, @tocNames );

	  $toc = TOC->_constructFromTocList(@tocNames);
      }

      if ($tag eq "ANCHOR") {
	  if (!$toc->_getCurrTopic()) {
	      return _error("Bad ANCHOR: Current topic not in WebOrder");
	  }
	  my $anchor = $toc->_getCurrTopic()->processANCHORTag(@params);
	  if ($anchor) {
	      return $anchor->generateTarget();
	  }
      } elsif ($tag eq "SECTION") {
	  if (!$toc->_getCurrTopic()) {
	      return _error("Bad SECTION: Current topic not in WebOrder");
	  }
	  my $sec = $toc->_getCurrTopic()->processSECTIONTag(@params);
	  if ($sec) {
	      return $sec->generateTarget();
	  }
      } elsif ($tag eq "REF") {
	  if (!$toc->_getCurrTopic()) {
	      return _error("Bad REF: Current topic not in WebOrder");
	  }
	  my ($sec, $link) = $toc->_getCurrTopic()->processREFTag(@params);
	  if ($link) {
	      return $link->generateReference($sec->_getTopic());
	  }
      } elsif ($tag eq "TOCCHECK") {
	  return $toc->processTOCCHECKTag(@params);
      } elsif ($tag eq "TOC") {
	  return $toc->processTOCTag(@params);
      } elsif ($tag eq "REFTABLE") {
	  return $toc->processREFTABLETag(@params);
      }
      return _error("Bad tag $tag: " . join(",", @params));
  }

  sub processTOCTags {
      my $text = shift;

      # Process wikitoc tags. Must be done in order so that anchor tags
      # get added in the right places and before we generate the table
      # of contents and ref tables.
      while ($text =~ s/%((SECTION[0-9]+)|ANCHOR)({[^%]*})?%(.*)/\<TOC_Mark\>/o) {
	  my $tag = $1;
	  my $a = $3;
	  my $r = $4;
	  if ($tag =~ s/SECTION([0-9]+)//o) {
	      my $l = $1;
	      #print "SECTION $level $a $r\n";
	      $text =~ s/\<TOC_Mark\>/&processTag("SECTION",$a,$l,$r)/eo;
	  } else {
	      #print "ANCHOR $a $r\n";
	      $text =~ s/\<TOC_Mark\>/&processTag("ANCHOR",$a,$r)/eo;
	  }
      }
      # The order in which the other tags is done is irrelevant
      $text =~ s/%(REF){([^%]*)}%/&processTag($1,$2)/geo;
      $text =~ s/%(TOC)({[^%]*})?%/&processTag($1,$2)/geo;
      $text =~ s/%(TOCCHECK)%/&processTag($1)/geo;
      $text =~ s/%(REFTABLE){([^%]*)}%/&processTag($1,$2)/geo;

      return $text;
  }
} # end of class TOC

1;