path: root/pod/buildtoc

#!/usr/bin/perl -w

use strict;
use vars qw(%Pragmata %Modules $Quiet);
use File::Spec;
use File::Find;
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('pod/perltoc.pod');

warn @{$state->{inconsistent}} if @{$state->{inconsistent}};

# Find all the modules
my @modpods;
find(sub {
    if (/\.p(od|m)$/) {
      my $file = $File::Find::name;
      return if $file =~ qr!/lib/Pod/Functions.pm\z!; # Used only by pod itself
      return if $file =~ m!(?:^|/)t/!;
      return if $file =~ m!lib/Attribute/Handlers/demo/!;
      return if $file =~ m!lib/Net/FTP/.+\.pm!; # Hi, Graham! :-)
      return if $file =~ m!lib/Math/BigInt/t/!;
      return if $file =~ m!/Devel/PPPort/[Hh]arness|lib/Devel/Harness!i;
      return if $file =~ m!XS/(?:APItest|Typemap)!;
      my $pod = $file;
      return if $pod =~ s/pm$/pod/ && -e $pod;
      unless (open my $f, '<', $_) {
	warn "$0: bogus <$file>: $!";
	system "ls", "-l", $file;
      }
      else {
	my $line;
	while ($line = <$f>) {
	  if ($line =~ /^=head1\s+NAME\b/) {
	    push @modpods, $file;
	    return;
	  }
	}
	warn "$0: NOTE: cannot find '=head1 NAME' in:\n  $file\n" unless $Quiet;
      }
    }
  }, 'lib');

my_die "Can't find any pods!\n" unless @modpods;

my %done;
for (@modpods) {
    my $name = $_;
    $name =~ s/\.p(m|od)$//;
    $name =~ s-.*?/lib/--;
    $name =~ s-/-::-g;
    next if $done{$name}++;

    if ($name =~ /^[a-z]/) {
	$Pragmata{$name} = $_;
    } else {
	$Modules{$name} = $_;
    }
}

# 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;

($_= <<"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.

	=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 {defined $_ && @$_ == 3 && !$_->[0]{toc_omit}} @{$state->{master}}) {
    podset(@$_);
}


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



	=head1 PRAGMA DOCUMENTATION

EOPOD2B

foreach (sort keys %Pragmata) {
    podset($_, $Pragmata{$_});
}

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



	=head1 MODULE DOCUMENTATION

EOPOD2B

foreach (sort keys %Modules) {
    podset($_, $Modules{$_});
}

$_= <<"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"} sort keys %{$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;

my $filename = 'pod/perltoc.pod';
open my $fh, '>', $filename
    or my_die "Can't open $filename for writing: $!";
print $fh $OUT or my_die "Can't print to $filename: $!";
close $fh or  my_die "Can't close $filename: $!";

exit(0);

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

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

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

    local $/ = '';

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

    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;
}

# Code added in commit 416302502f485afa, but never used.
# Probably roffitall should become something that buildtoc generates, instead
# of something that we ship in the distribution.

sub generate_roffitall {
  (map ({"\t\$maindir/$_.1\t\\"}sort keys %{$state->{pods}}),
   "\t\t\\",
   map ({"\t\$maindir/$_.1\t\\"}sort keys %{$state->{aux}}),
   "\t\t\\",
   map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata),
   "\t\t\\",
   map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules),
  )
}