File Coverage

blib/lib/Texinfo/Menus.pm

Criterion	Covered	Total	%
statement	10	159	6.2
branch	0	102	0.0
condition	0	26	0.0
subroutine	4	11	36.3
pod	0	7	0.0
total	14	305	4.5

#---------------------------------------------------------------------
package Texinfo::Menus;
#
# Copyright 1994-2007 Christopher J. Madsen
#
# Author: Christopher J. Madsen
#
# 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;
our (
    $descColumn,$layers,$level,$masterMenu,$menuMark,$node,$printKids,$section,
    $No_Comments,$No_Detail,$Verbose,
    @parents,
    %children,%desc,%level,%next,%prev,%section,%title,%up,
);

require Exporter;

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

our $VERSION = '1.03';

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 <
$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 <
$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__