#---------------------------------------------------------------------
package Texinfo::Menus;
#
# Copyright 1994-2007 Christopher J. Madsen
#
# Author: Christopher J. Madsen <perl@cjmweb.net>
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# 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 either the
# GNU General Public License or the Artistic License for more details.
#
# ABSTRACT: Update node links and menus in Texinfo documents
#---------------------------------------------------------------------

use 5.008;

use IO::File;
use strict;
use vars qw(
    $descColumn $layers $level $masterMenu $menuMark $node $printKids $section
    $No_Comments $No_Detail $Verbose $VERSION
    @parents @ISA @EXPORT
    %children %desc %level %next %prev %section %title %up
);

require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw(update_menus);

$VERSION = '1.02';

our %layersForEncoding = (qw(
  UTF-8        :utf8
  US-ASCII) => ''
);

#=====================================================================
# Subroutines:
#---------------------------------------------------------------------
# Print an error message on STDERR and exit:
#
# Input:
#   filename:  The file containing the error
#   line:      The line number of the error (-1 means use $INPUT_LINE_NUMBER)
#   message:   The error message to display

sub abort
{
    my ($filename,$line,$message) = @_;

    $line = $. if $line eq '-1'; # $INPUT_LINE_NUMBER

    die "$filename:$line: $message\n";
} # end abort

#---------------------------------------------------------------------
sub update_menus
{
    my $master = shift @_;
    my %parms = @_;

    $descColumn  = $parms{description_column} || 32; # The column for menu descriptions
    $No_Comments = (exists $parms{comments} ? !$parms{comments} : 0);
    $No_Detail   = (exists $parms{detailed} ? !$parms{detailed} : 0);
    $Verbose     = $parms{verbose}; # Defaults to off

    $masterMenu = 0;
    $menuMark = '*';
    $layers = '';

    undef $node;        # We are not in any node yet
    undef $level;       undef %next;
    undef $section;     undef %prev;
    undef @parents;     undef %section;
    undef %children;    undef %title;
    undef %desc;        undef %up;

    readStructure($master);

    $next{"Top"} = $children{"Top"}->[0];

    writeMenus($master);
} # end file

#---------------------------------------------------------------------
# Generate the master menu:
#
# Input:
#   node:  The node we are in (usually "Top")
#
# Input Variables:
#   %children
#   %section
#   $No_Detail

sub printMasterMenu
{
    my $node = shift;

    local $masterMenu = 1;
    print "\@menu\n";
    printMenu(@{$children{$node}});
    unless ($No_Detail) {
        print "\n --- The Detailed Node Listing ---\n";
        local $printKids = ($No_Comments ? 0 : 1);
        foreach my $child (@{$children{$node}}) {
            if (exists $children{$child}) {
                print "\n", ($section{$child} || $child), "\n\n";
                printMenu(@{$children{$child}});
            }
        } # end foreach
    } # end unless $No_Detail
    print "\@end menu\n";
} # end printMasterMenu

#---------------------------------------------------------------------
# Generate a menu:
#
# Input Variables:
#   $descColumn:  The column number for descriptions (0 is first column)
#   $masterMenu:  True prevents insertion of "@menu" and "@end menu".
#   $menuMark:    The mark that indicates a menu item (usually "*")
#   $printKids:   True inserts comments for child nodes

sub printMenu
{
    print "\@menu\n" unless $masterMenu;
    foreach $node (@_) { ## no critic (RequireLexicalLoopIterators)
        printf("%-${descColumn}s%s\n",
               ($title{$node}
                ? "$menuMark ${title{$node}}: ${node}." # Node with title
                : "$menuMark ${node}::"),               # Node with no title
               $desc{$node});
        printMenuComment(@{$children{$node}})
            if $printKids and exists $children{$node};
    } # end foreach $node
    print "\@end menu\n\n" unless $masterMenu;
} # end printMenu

#---------------------------------------------------------------------
# Generate comments for a submenu:
# Input Variables:
#   $masterMenu:  Must be True
#   $menuMark:    The mark that indicates a menu item (usually "*")
#   $printKids:   True inserts comments for child nodes

sub printMenuComment
{
    local $menuMark = $menuMark;
    if ($menuMark =~ /^\@c/) { $menuMark .= ' ' }
    else                     { $menuMark = '@c *' };
    &printMenu;
} # end printMenuComment

#---------------------------------------------------------------------
# Scan file for node structure and descriptions:
#
# Input:
#   $filename:  The file to scan
#
# Variables Created:
#   %children:
#     The children of a node, indexed by node name
#     Each entry is an array of node names (eg, @{$children{"Top"}}
#     is an array of all the children of the Top node, in the order
#     they occurred).
#   %desc:    Node descriptions, indexed by node name
#   %next:    The name of the next node, indexed by node name
#   %prev:    The name of the previous node, indexed by node name
#   %section: Section and subsection titles, indexed by node name
#   %title:   Node titles (menu-entry names), indexed by node name
#   %up:      The name of the "parent" node, indexed by node name
#
# Variables Used:
#   $node:     The node we are currently in
#   $level:    The level this node is at (0=Top, 1=Chapter, ...)
#   @parents:  A list of all the parent nodes of this node, including
#              the node itself ("Top", "Chapter Node", ... "This Node")

sub readStructure
{
    my $filename = $_[0];

    my $handle   = IO::File->new;

  openFile:
    open($handle, "<$layers", $filename) or abort($filename,0,"Unable to open");

  line:
    while (<$handle>) {
        if (/^\@node +([^,\n]+)/) {
            my $newNode = $1;
            abort($filename, -1, "Duplicate node name `$newNode'")
                if defined $prev{$newNode};
            if ($newNode eq 'Top') {
                $node = 'Top';
                @parents = ($node); # The Top node has no parents
                $prev{$node} = '(dir)';
                $up{$node} = '(dir)';
                $level = 0;
                next line;
            }
            $section = <$handle>;
            $section = <$handle> while $section =~ /^\@c(omment)? /;
            abort($filename, -1,
                  'Chapter structuring command required after `@node\'')
                unless ($section =~ /^\@([a-z]+) +(.+)$/);
            abort($filename,-1,"\`\@$1' is not a chapter structuring command")
                unless exists $level{$1};
            my $newLevel = $level{$1};
            abort($filename,-1,"Skipped level")
                if ($newLevel - $level) > 1;
            $section = $2;
            $section{$newNode} = $section;
            if (not $desc{$newNode}) {
                $desc{$newNode} = ($newNode ne $section ? $section : "");
            }
            $next{$newNode} = "";
            if ($newLevel < $level) {
                $next{$node} = "";
                my $prevNode = $parents[$newLevel];
                $next{$prevNode} = $newNode;
                $prev{$newNode}  = $prevNode;
            }
            else {
                $next{$node}    = $newNode  unless $newLevel > $level;
                $prev{$newNode} = $node;
            }
            $parents[$newLevel] = $newNode;
            $node  = $newNode;
            $level = $newLevel;
            my $parent = $parents[$level-1];
            $up{$node} = $parent;
            push @{$children{$parent}}, $node;
        } # end if @node
        elsif (/^\@menu/ .. /^\@end menu/) {
            next line unless /^(\@c )?\* /;

            my($node, $title, $desc);

            if (/\* +([^:]+):: *(.*)$/) {
                ($node, $title, $desc) = ($1, "", $2);
            }
            elsif (/\* +([^:]+): *([^,.\t\n]+)[,.\t\n] *(.*)$/) {
                ($node, $title, $desc) = ($2, $1, $3);
            }
            else {
                abort($filename,-1,"Bad menu entry");
            }
            $title{$node} = $title;
            if ($desc and $desc{$node}) {
                print STDERR <<EOT if $desc ne $desc{$node} and $Verbose;
$filename:$.: Warning: Multiple descriptions for node \`$node'
    \`$desc{$node}' overrides
    \`$desc'
EOT
                undef $desc;    # Don't overwrite the first description
            }
            $desc{$node}  = $desc if $desc;
        } # end elsif in @menu
        elsif (/^\@c(omment)? DESC: *(.*?) *$/) {
            # A DESC comment in the node overrides any previous description:
            if ($Verbose and $desc{$node} and $desc{$node} ne $2
                and $desc{$node} ne $section) {
                print STDERR <<EOT; # '
$filename:$.: Warning: Multiple descriptions for node \`$node'
    \`$2' overrides
    \`$desc{$node}'
EOT
# '
            } # end if node description is not section name or blank
            $desc{$node} = $2;
        } # end elsif DESC comment in node
        elsif (/^ *\@include +(\S+)\s/) {
            readStructure($1);
        }
        elsif (/^ *\@documentencoding +(\S+)\s/) {
            my $wantLayers = $layersForEncoding{$1};
            $wantLayers = ":encoding($1)" unless defined $wantLayers;

            if ($layers) {
              abort($filename, -1, "Cannot switch from $layers to $wantLayers")
                  if $layers ne $wantLayers;
            } elsif ($wantLayers) {
              abort($filename, -1,
                    '@documentencoding must come before structuring commands')
                  if defined $node;
              $layers = $wantLayers;
              close $handle;
              goto openFile;
            }
        }
    } # end while

    close $handle;
} # end readStructure

#---------------------------------------------------------------------
# Insert menus and node links:
#
# Input:
#   $filename:  The file to write
#
# Variables Used:
#   %children:
#     The children of a node, indexed by node name
#     Each entry is an array of node names (eg, @{$children{"Top"}}
#     is an array of all the children of the Top node, in the order
#     they occurred).
#   %desc:   Node descriptions, indexed by node name
#   %next:   The name of the next node, indexed by node name
#   %prev:   The name of the previous node, indexed by node name
#   %title:  Node titles (menu-entry names), indexed by node name
#   %up:     The name of the "parent" node, indexed by node name

sub writeMenus
{
    my $filename = $_[0];

    my ($menu,$node);
    my $deleteBlanks = 0;

    rename $filename,"$filename#~" or die "Unable to rename $filename";

    my $inHandle  = IO::File->new;
    my $outHandle = IO::File->new;

    open($inHandle,"<$layers","$filename#~") or die "Unable to open $filename#~";
    open($outHandle,">$layers",$filename)    or die "Unable to open $filename";

    my $oldHandle = select $outHandle;

    while (<$inHandle>) {
        if (/^ *\@include +(\S+)\s/) {
            local $_;         # Preserve the current line
            writeMenus($1);
        } # end if @include
        elsif (/^\@menu/) {
            if (ref($menu)) {
                if ($node eq 'Top') { printMasterMenu($node) }
                else                { printMenu(@$menu)      }
            }
            undef $menu;
        } # end elsif @menu
        elsif (/^\@node +([^,\n]+)/) {
            my $newNode = $1;
            if (ref($menu)) {
                if ($node eq 'Top') { printMasterMenu($node) }
                else                { printMenu(@$menu)      }
            }
            undef $menu;
            $node = $newNode;
            $_ = "\@node $node, $next{$node}, $prev{$node}, $up{$node}\n";
            $menu = $children{$node} if exists $children{$node};
        } # end elsif @node
    } # end while <$inHandle>
    continue {
        if (/^\@menu/ .. /^\@end menu/) {
            $deleteBlanks = 1;
        } else {
            print($_), $deleteBlanks = 0 unless ($deleteBlanks and /^ *$/);
        }
    } # end while <$inHandle> (continue block)

    select $oldHandle;
    close $inHandle;
    close $outHandle;
    unlink "$filename#~";
} # end writeMenus

#=====================================================================
# Initialize variables:
#---------------------------------------------------------------------
BEGIN
{
    %level = (
        "chapter"             => 1,
        "section"             => 2,
        "subsection"          => 3,
        "subsubsection"       => 4,

        "unnumbered"          => 1,
        "unnumberedsec"       => 2,
        "unnumberedsubsec"    => 3,
        "unnumberedsubsubsec" => 4,

        "appendix"            => 1,
        "appendixsec"         => 2,
        "appendixsubsec"      => 3,
        "appendixsubsubsec"   => 4,

        "chapheading"         => 1,
        "heading"             => 2,
        "subheading"          => 3,
        "subsubheading"       => 4,
    );
} # end BEGIN

#=====================================================================
# Package Return Value:
#=====================================================================
1;

__END__

=head1 NAME

Texinfo::Menus - Update node links and menus in Texinfo documents

=head1 VERSION

This document describes version 1.02 of
Texinfo::Menus, released December 7, 2010.

=head1 SYNOPSIS

  use Texinfo::Menus;

  update_menus($filename, verbose => 1);

=head1 DESCRIPTION

Texinfo::Menus exports just one function: B<update_menus>.  It updates
the menus and node links in a Texinfo file based on its chapter
structure.  The file may use C<@include> to include other files, which
may also C<@inlcude> other files.  Unlike the similar Emacs functions,
B<update_menus> does not require that each chapter be in a separate file.

The first node in the file should be named `Top'.

Each C<@node> command must be followed immediately by a Texinfo
structuring command (e.g, C<@chapter>, C<@section>, C<@appendix>).  A
comment may come between them, but nothing else.

A node can supply a menu description with a comment in the form:

 @c DESC: Menu description

This comment (if present) must come B<after> the structuring command.

=head1 OPTIONS

=over 5

=item B<comments>

B<update_menus> normally adds comments to the master menu to retain the
descriptions of subsection and lesser nodes.  (This is useful when the
subfiles are automatically generated and the descriptions are added by
hand.)  Use C<< comments => 0 >> to prevent this.

=item B<detailed>

Normally, B<update_menus> generates a detailed node listing (consisting of
the section nodes for each chapter) following the master menu.  Use
C<< detailed => 0 >> to omit the detailed node listing.

=item B<verbose>

The B<verbose> option causes B<update_menus> to generate a warning
message if it finds multiple descriptions for a node (only one of
which will be used).  Use C<< verbose => 1 >> to enable this.

=back

=head1 CONFIGURATION AND ENVIRONMENT

Texinfo::Menus requires no configuration files or environment variables.

=head1 DEPENDENCIES

None.

=head1 INCOMPATIBILITIES

None reported.

=head1 BUGS AND LIMITATIONS

Texinfo::Menus cannot handle C<@include> inside a menu.


=for Pod::Coverage
^abort$
^printMasterMenu$
^printMenu$
^printMenuComment$
^readStructure$
^writeMenus$
^update_menus$

=head1 AUTHOR

Christopher J. Madsen  S<C<< <perl AT cjmweb.net> >>>

Please report any bugs or feature requests to
S<C<< <bug-Texinfo-Menus AT rt.cpan.org> >>>,
or through the web interface at
L<http://rt.cpan.org/Public/Bug/Report.html?Queue=Texinfo-Menus>

You can follow or contribute to Texinfo-Menus's development at
L<< http://github.com/madsen/texinfo-menus >>.

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by Christopher J. Madsen.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=head1 DISCLAIMER OF WARRANTY

BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
NECESSARY SERVICING, REPAIR, OR CORRECTION.

IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE
LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.

=cut