path: root/pod/buildtoc

#!/usr/bin/perl -w

use strict;
use vars qw($Quiet);
use File::Spec;
use FindBin;
use Text::Wrap;
use Getopt::Long;

no locale;

# Assumption is that we're either already being run from the top level (*nix,
# VMS), or have absolute paths in @INC (Win32, pod/Makefile)
BEGIN {
  my $Top = File::Spec->catdir($FindBin::Bin, File::Spec->updir);
  chdir $Top or die "Can't chdir to $Top: $!";
  require 'Porting/pod_lib.pl';
}

die "$0: Usage: $0 [--quiet]\n"
    unless GetOptions (quiet => \$Quiet) && !@ARGV;

my $state = get_pod_metadata(0, sub { warn @_ if @_ }, 'pod/perltoc.pod');

my $found = pods_to_install();

my_die "Can't find any pods!\n" unless %$found;

# Accumulating everything into a lexical before writing to disk dates from the
# time when this script also provided the functionality of regen/pod_rules.pl
# and this code was in a subroutine do_toc(). In turn, the use of a file scoped
# lexical instead of a parameter or return value is because the code dates back
# further still, and used *only* to create pod/perltoc.pod by printing direct

my $OUT;
my $roffitall;

($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;

	# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
	# This file is autogenerated by buildtoc from all the other pods.
	# Edit those files and run $0 to effect changes.

	=encoding UTF-8

	=head1 NAME

	perltoc - perl documentation table of contents

	=head1 DESCRIPTION

	This page provides a brief table of contents for the rest of the Perl
	documentation set.  It is meant to be scanned quickly or grepped
	through to locate the proper section you're looking for.

	=head1 BASIC DOCUMENTATION

EOPOD2B

# All the things in the master list that happen to be pod filenames
foreach (grep {!$_->[2]{toc_omit}} @{$state->{master}}) {
    $roffitall .= "    \$mandir/$_->[0].1 \\\n";
    podset($_->[0], $_->[1]);
}

foreach my $type (qw(PRAGMA MODULE)) {
    ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;



	=head1 $type DOCUMENTATION

EOPOD2B

    foreach my $name (sort keys %{$found->{$type}}) {
        $roffitall .= "    \$libdir/$name.3 \\\n";
        podset($name, $found->{$type}{$name});
    }
}

$_= <<"EOPOD2B";


	=head1 AUXILIARY DOCUMENTATION

	Here should be listed all the extra programs' documentation, but they
	don't all have manual pages yet:

	=over 4

EOPOD2B

$_ .=  join "\n", map {"\t=item $_\n"} @{$state->{aux}};
$_ .= <<"EOPOD2B" ;

	=back

	=head1 AUTHOR

	Larry Wall <F<larry\@wall.org>>, with the help of oodles
	of other folks.


EOPOD2B

s/^\t//gm;
$OUT .= "$_\n";

$OUT =~ s/\n\s+\n/\n\n/gs;
$OUT =~ s/\n{3,}/\n\n/g;

$OUT =~ s/([^\n]+)/wrap('', '', $1)/ge;

write_or_die('pod/perltoc.pod', $OUT);

write_or_die('pod/roffitall', <<'EOH' . $roffitall . <<'EOT');
#!/bin/sh
#
# Usage: roffitall [-nroff|-psroff|-groff]
#
# Authors: Tom Christiansen, Raphael Manfredi

me=roffitall
tmp=.

if test -f ../config.sh; then
	. ../config.sh
fi

mandir=$installman1dir
libdir=$installman3dir

test -d $mandir || mandir=/usr/new/man/man1
test -d $libdir || libdir=/usr/new/man/man3

case "$1" in
-nroff) cmd="nroff -man"; ext='txt';;
-psroff) cmd="psroff -t"; ext='ps';;
-groff) cmd="groff -man"; ext='ps';;
*)
	echo "Usage: roffitall [-nroff|-psroff|-groff]" >&2
	exit 1
	;;
esac

toroff=`
	echo		\
EOH
    | perl -ne 'map { -r && print "$_ " } split'`

    # Bypass internal shell buffer limit -- can't use case
    if perl -e '$a = shift; exit($a =~ m|/|)' $toroff; then
	echo "$me: empty file list -- did you run install?" >&2
	exit 1
    fi

    #psroff -t -man -rC1 -rD1 -rF1 > $tmp/PerlDoc.ps 2>$tmp/PerlTOC.raw
    #nroff -man -rC1 -rD1 -rF1 > $tmp/PerlDoc.txt 2>$tmp/PerlTOC.nr.raw

    # First, create the raw data
    run="$cmd -rC1 -rD1 -rF1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw"
    echo "$me: running $run"
    eval $run $toroff

    #Now create the TOC
    echo "$me: parsing TOC"
    perl rofftoc $tmp/PerlTOC.$ext.raw > $tmp/PerlTOC.tmp.man
    run="$cmd $tmp/PerlTOC.tmp.man >$tmp/PerlTOC.$ext"
    echo "$me: running $run"
    eval $run

    # Finally, recreate the Doc, without the blank page 0
    run="$cmd -rC1 -rD1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw"
    echo "$me: running $run"
    eval $run $toroff
    rm -f $tmp/PerlTOC.tmp.man $tmp/PerlTOC.$ext.raw
    echo "$me: leaving you with $tmp/PerlDoc.$ext and $tmp/PerlTOC.$ext"
EOT

exit(0);

# Below are all the auxiliary routines for generating perltoc.pod

my ($inhead1, $inhead2, $initem);

sub podset {
    my ($pod, $file) = @_;

    open my $fh, '<', $file or my_die "Can't open file '$file' for $pod: $!";

    local *_;
    my $found_pod;
    while (<$fh>) {
        if (/^=head1\s+NAME\b/) {
            ++$found_pod;
            last;
        }
    }

    unless ($found_pod) {
	warn "$0: NOTE: cannot find '=head1 NAME' in:\n  $file\n" unless $Quiet;
        return;
    }

    seek $fh, 0, 0 or my_die "Can't rewind file '$file': $!";
    local $/ = '';

    while(<$fh>) {
	tr/\015//d;
	if (s/^=head1 (NAME)\s*/=head2 /) {
	    unhead1();
	    $OUT .= "\n\n=head2 ";
	    $_ = <$fh>;
	    # Remove svn keyword expansions from the Perl FAQ
	    s/ \(\$Revision: \d+ \$\)//g;
	    if ( /^\s*\Q$pod\E\b/ ) {
		s/$pod\.pm/$pod/;       # '.pm' in NAME !?
	    } else {
		s/^/$pod, /;
	    }
	}
	elsif (s/^=head1 (.*)/=item $1/) {
	    unhead2();
	    $OUT .= "=over 4\n\n" unless $inhead1;
	    $inhead1 = 1;
	    $_ .= "\n";
	}
	elsif (s/^=head2 (.*)/=item $1/) {
	    unitem();
	    $OUT .= "=over 4\n\n" unless $inhead2;
	    $inhead2 = 1;
	    $_ .= "\n";
	}
	elsif (s/^=item ([^=].*)/$1/) {
	    next if $pod eq 'perldiag';
	    s/^\s*\*\s*$// && next;
	    s/^\s*\*\s*//;
	    s/\n/ /g;
	    s/\s+$//;
	    next if /^[\d.]+$/;
	    next if $pod eq 'perlmodlib' && /^ftp:/;
	    $OUT .= ", " if $initem;
	    $initem = 1;
	    s/\.$//;
	    s/^-X\b/-I<X>/;
	}
	else {
	    unhead1() if /^=cut\s*\n/;
	    next;
	}
	$OUT .= $_;
    }
}

sub unhead1 {
    unhead2();
    if ($inhead1) {
	$OUT .= "\n\n=back\n\n";
    }
    $inhead1 = 0;
}

sub unhead2 {
    unitem();
    if ($inhead2) {
	$OUT .= "\n\n=back\n\n";
    }
    $inhead2 = 0;
}

sub unitem {
    if ($initem) {
	$OUT .= "\n\n";
    }
    $initem = 0;
}

# ex: set ts=8 sts=4 sw=4 et: