#  Copyright (c) 1997-2005
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
#  http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.de
#
#  This program is free software; you can redistribute it and/or modify it
#  under the terms of the GNU General Public License as published by the
#  Free Software Foundation; either version 2, or (at your option) any
#  later version: http://www.gnu.org/licenses/gpl.txt.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#----------------------------------------------------------------------------
#  $Project: polymake $$Id: Help.pm,v 1.22 2006/03/07 17:55:19 gawrilow Exp $

use strict;
use namespaces;

package Poly::Help;

use Struct (
   [ new => ';$$$' ],
   [ '$name' => '#2' ],
   '$category',
   [ '$text' => '#3' ],
   '@toc',
   '%topics',
);

# between several entries with the same topic path
declare $separator="-----\n";

sub sanitize {
   $_[0] =~ s/^\s*\#//gm;
   $_[0] =~ s/^\#+\n//gm;
   $_[0] =~ s/^(?:\s*\\|[ \t]+)$//gm;
   $_[0] =~ s/\n{3,}/\n\n/gs;
   $_[0] =~ s/^\s+\n//s;
   $_[0] =~ s/\n{2,}$/\n/s;
}

#################################################################################
sub add {
   my ($self, $path, $text, $split_multi)=@_;
   $path=[ split m'/', $path ] unless ref $path;
   if ($path->[0] eq '$this') {
      splice @$path, 0, 1, 'objects', caller()->prototype->name;
   }
   my $cat;
   if ($text =~ s/^\#?\s* category: [ \t]* (.*(?<!\s)) [ \t]*\n//mxi) {
      splice @$path, -1, 0, $1;
      $cat=1;
   }
   sanitize($text);
   return undef unless $text =~ /\S/;
   if (! @$path) {
      if (length($self->text)) {
	 $self->text .= $separator . $text;
      } else {
	 $self->text=$text;
      }
   }

   my $topic=pop @$path;
   foreach (@$path) {
      if (defined (my $h=$self->topics->{$_})) {
	 $self=$h;
      } else {
	 push @{$self->toc}, $_;
	 $self=$self->topics->{$_}=new Help($self, $_);
      }
   }
   $self->category ||= $cat;

   if (defined (my $h=$self->topics->{$topic})) {
      if (!$split_multi) {
	 if (length($h->text)) {
	    $h->text .= $separator . $text;
	 } else {
	    $h->text=$text;
	 }
	 return $h;
      }
      if (exists $h->topics->{"$split_multi#0"}) {
	 $self=$h;
	 $topic="$split_multi#".scalar @{$self->toc};
      } else {
	 $self=$self->topics->{$topic}=new Help($self, $topic);
	 $h->name="$split_multi#0";
	 $self->topics->{$h->name}=$h;
	 $topic="$split_multi#1";
      }
   } else {
      push @{$self->toc}, $topic;
   }

   $self->topics->{$topic}=new Help($self, $topic, $text);
}
#################################################################################
my $id_re=qr{(?> (?!\d)\w+ )}x;

sub add_function {
   my ($self, $path, $help_text)=@_;
   my (%annex, %options);
   while ($help_text =~ s/^\#?\s* (args|return|signature): \s*(.*)$//xm) {
      $annex{$1}=$2;
   }
   while ($help_text =~ s/^\#?\s* option: \s* ($id_re) [ \t]* (.* \n
                          (?: (?:^\#?[ \t]*\n)* ^\#?(?:[ ]*\t[ \t]*|[ ]{6,}) (?!option:) \S.* \n )*) //xm) {
      my ($name, $text)=($1, $2);
      sanitize($text);
      $options{$name}=new Help(undef, $name, $text);
      $annex{options}="";
   }

   if (my $h=$self->add($path, $help_text, $annex{signature} && "overload")) {
      while (my ($annex, $text)=each %annex) {
	 $h->topics->{$annex}=new Help($h, $annex, $text);
      }
      if (%options) {
	 $h->topics->{options}->topics=\%options;
      }
      $h
   }
}
#################################################################################
sub clone {
   my ($src, $up)=@_;
   my $self=new Help($up, $src->name, $src->text);
   @{$self->toc}=@{$src->toc};
   while (my ($name, $topic)=each %{$src->topics}) {
      $self->topics->{$name}=$topic->clone($self);
   }
   $self->category=$src->category;
   $self
}
#################################################################################
sub merge {
   my ($self, $src)=@_;
   if (length($src->text)) {
      if (length($self->text)) {
	 $self->text .= $separator . $src->text;
      } else {
	 $self->text=$src->text;
      }
   }
   my %added;
   while (my ($name, $src_topic)=each %{$src->topics}) {
      if (defined (my $topic=$self->topics->{$name})) {
	 merge($topic, $src->topics->{$name});
      } else {
	 $self->topics->{$name}=$src_topic->clone($self);
	 $added{$name}=1;
      }
   }
   push @{$self->toc}, grep { $added{$_} } @{$src->toc};
   $self->category|=$src->category;
}
#################################################################################
sub get_topic {
   my $self=shift;
   my $path= @_ > 1 ? \@_ : is_ARRAY($_[0]) ? shift  : [ split m'/', shift ];
   foreach (@$path) {
      $self=$self->topics->{$_} or last;
   }
   $self
}
#################################################################################
sub get {
   my $self=&get_topic;
   $self && $self->text
}

1
