[perl5.git] / pod / buildtoc

#!/usr/bin/perl -w

use strict;
use vars qw($masterpodfile %Build %Targets $Verbose $Up %Ignore
	    @Master %Readmes %Pods %Aux %Readmepods %Pragmata %Modules);
use File::Spec;
use File::Find;
use FindBin;
use Text::Tabs;
use Text::Wrap;
use Getopt::Long;

no locale;

$Up = File::Spec->updir;
$masterpodfile = File::Spec->catdir($Up, "pod.lst");

# Generate any/all of these files
# --verbose gives slightly more output
# --build-all tries to build everything
# --build-foo updates foo as follows
# --showfiles shows the files to be changed

%Targets
  = (
     toc => "perltoc.pod",
     manifest => File::Spec->catdir($Up, "MANIFEST"),
     perlpod => "perl.pod",
     vms => File::Spec->catdir($Up, "vms", "descrip_mms.template"),
     nmake => File::Spec->catdir($Up, "win32", "Makefile"),
     dmake => File::Spec->catdir($Up, "win32", "makefile.mk"),
     podmak => File::Spec->catdir($Up, "win32", "pod.mak"),
     # plan9 =>  File::Spec->catdir($Up, "plan9", "mkfile"),
    );

{
  my @files = keys %Targets;
  my $filesopts = join(" | ", map { "--build-$_" } "all", sort @files);
  my $showfiles;
  die <<__USAGE__
$0: Usage: $0 [--verbose] [--showfiles] $filesopts
__USAGE__
  unless @ARGV
	&& GetOptions (verbose => \$Verbose,
		       showfiles => \$showfiles,
		       map {+"build-$_", \$Build{$_}} @files, 'all');
  # Set them all to true
  @Build{@files} = @files if ($Build{all});
  if ($showfiles) {
      print
	  join(" ",
	       sort { lc $a cmp lc $b }
	       map {
		   my ($v, $d, $f) = File::Spec->splitpath($_);
		   my @d;
		   @d = defined $d ? File::Spec->splitdir($d) : ();
		   shift @d if @d;
		   File::Spec->catfile(@d ?
				       (@d == 1 && $d[0] eq '' ? () : @d)
				       : "pod", $f);
	       } @Targets{grep { $_ ne 'all' && $Build{$_} } keys %Build}),
          "\n";
      exit(0);
  }
}

# Don't copy these top level READMEs
%Ignore
  = (
     Y2K => 1,
     micro => 1,
#     vms => 1,
     );

if ($Verbose) {
  print "I'm building $_\n" foreach grep {$Build{$_}} keys %Build;
}

chdir $FindBin::Bin or die "$0: Can't chdir $FindBin::Bin: $!";

open MASTER, $masterpodfile or die "$0: Can't open $masterpodfile: $!";

foreach (<MASTER>) {
  next if /^\#/;

  # At least one upper case letter somewhere in the first group
  if (/^(\S+)\s(.*)/ && $1 =~ tr/A-Z//) {
    # it's a heading
    my $flags = $1;
    my %flags = (header => 1);
    $flags{toc_omit} = 1 if $flags =~ tr/O//d;
    $flags{include} = 1 if $flags =~ tr/I//d;
    $flags{aux} = 1 if $flags =~ tr/A//d;
    die "$0: Unknown flag found in heading line: $_" if length $flags;
    push @Master, [\%flags, $2];

  } elsif (/^(\S*)\s+(\S+)\s+(.*)/) {
    # it's a section
    my ($flags, $filename, $desc) = ($1, $2, $3);

    my %flags = (indent => 0);
    $flags{indent} = $1 if $flags =~ s/(\d+)//;
    $flags{toc_omit} = 1 if $flags =~ tr/o//d;
    $flags{aux} = 1 if $flags =~ tr/a//d;
    if ($flags =~ tr/r//d) {
      my $readme = $filename;
      $readme =~ s/^perl//;
      $Readmepods{$filename} = $Readmes{$readme} = $desc;
      $flags{readme} = 1;
    } elsif ($flags{aux}) {
      $Aux{$filename} = $desc;
    } else {
      $Pods{$filename} = $desc;
    }
    die "$0: Unknown flag found in section line: $_" if length $flags;
    push @Master, [\%flags, $filename, $desc];
  } elsif (/^$/) {
    push @Master, undef;
  } else {
    die "$0: Malformed line: $_" if $1 =~ tr/A-Z//;
  }
}

close MASTER;

# Sanity cross check
{
  my (%disk_pods, @disk_pods);
  my (@manipods, %manipods);
  my (@manireadmes, %manireadmes);
  my (@perlpods, %perlpods);
  my (%our_pods);

  # Convert these to a list of filenames.
  foreach (keys %Pods, keys %Readmepods) {
    $our_pods{"$_.pod"}++;
  }

  # None of these filenames will be boolean false
  @disk_pods = glob("*.pod");
  @disk_pods{@disk_pods} = @disk_pods;

  open(MANI, "../MANIFEST") || die "$0: opening ../MANIFEST failed: $!";
  while (<MANI>) {
    if (m!^pod/([^.]+\.pod)\s+!i) {
      push @manipods, $1;
    } elsif (m!^README\.(\S+)\s+!i) {
      next if $Ignore{$1};
      push @manireadmes, "perl$1.pod";
    }
  }
  close(MANI);
  @manipods{@manipods} = @manipods;
  @manireadmes{@manireadmes} = @manireadmes;

  open(PERLPOD, "perl.pod") || die "$0: opening perl.pod failed: $!\n";
  while (<PERLPOD>) {
    if (/^For ease of access, /../^\(If you're intending /) {
      if (/^\s+(perl\S*)\s+\w/) {
	push @perlpods, "$1.pod";
      }
    }
  }
  close(PERLPOD);
  die "$0: could not find the pod listing of perl.pod\n"
    unless @perlpods;
  @perlpods{@perlpods} = @perlpods;

  foreach my $i (sort keys %disk_pods) {
    warn "$0: $i exists but is unknown by buildtoc\n"
      unless $our_pods{$i};
    warn "$0: $i exists but is unknown by ../MANIFEST\n"
      if !$manipods{$i} && !$manireadmes{$i};
    warn "$0: $i exists but is unknown by perl.pod\n"
	unless $perlpods{$i};
  }
  foreach my $i (sort keys %our_pods) {
    warn "$0: $i is known by buildtoc but does not exist\n"
      unless $disk_pods{$i};
  }
  foreach my $i (sort keys %manipods) {
    warn "$0: $i is known by ../MANIFEST but does not exist\n"
      unless $disk_pods{$i};
  }
  foreach my $i (sort keys %perlpods) {
    warn "$0: $i is known by perl.pod but does not exist\n"
      unless $disk_pods{$i};
  }
}

# Find all the mdoules
{
  my @modpods;
  find \&getpods => qw(../lib ../ext);

  sub getpods {
    if (/\.p(od|m)$/) {
      my $file = $File::Find::name;
      return if $file eq '../lib/Pod/Functions.pm'; # 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)!;
      die "$0: tut $File::Find::name" if $file =~ /TUT/;
      unless (open (F, "< $_\0")) {
	warn "$0: bogus <$file>: $!";
	system "ls", "-l", $file;
      }
      else {
	my $line;
	while ($line = <F>) {
	  if ($line =~ /^=head1\s+NAME\b/) {
	    push @modpods, $file;
	    #warn "GOOD $file\n";
	    return;
	  }
	}
	warn "$0: $file: cannot find =head1 NAME\n";
      }
    }
  }

  die "$0: no pods" unless @modpods;

  my %done;
  for (@modpods) {
    #($name) = /(\w+)\.p(m|od)$/;
    my $name = path2modname($_);
    if ($name =~ /^[a-z]/) {
      $Pragmata{$name} = $_;
    } else {
      if ($done{$name}++) {
	# warn "already did $_\n";
	next;
      }
      $Modules{$name} = $_;
    }
  }
}

# OK. Now a lot of ancillay function definitions follow
# Main program returns at "Do stuff"

sub path2modname {
    local $_ = shift;
    s/\.p(m|od)$//;
    s-.*?/(lib|ext)/--;
    s-/-::-g;
    s/(\w+)::\1/$1/;
    return $_;
}

sub output ($);

sub output_perltoc {
  open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!";

  $/ = '';

  ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);

	=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
#' make emacs happy

  # All the things in the master list that happen to be pod filenames
  podset(map {"$_->[1].pod"} grep {defined $_ && @$_ == 3 && !$_->[0]{toc_omit}} @Master);


  ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);


	=head1 PRAGMA DOCUMENTATION

EOPOD2B

  podset(sort values %Pragmata);

  ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);


	=head1 MODULE DOCUMENTATION

EOPOD2B

  podset( @Modules{ sort keys %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 %Aux;
  $_ .= <<"EOPOD2B" ;

	=back

	=head1 AUTHOR

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


EOPOD2B

  s/^\t//gm;
  output $_;
  output "\n";                    # flush $LINE
}

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

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

sub podset {
    local @ARGV = @_;
    my $pod;

    while(<>) {
	if (s/^=head1 (NAME)\s*/=head2 /) {
	    $pod = path2modname($ARGV);
	    unhead1();
	    output "\n \n\n=head2 ";
	    $_ = <>;
	    if ( /^\s*$pod\b/ ) {
		s/$pod\.pm/$pod/;       # '.pm' in NAME !?
		output $_;
	    } else {
		s/^/$pod, /;
		output $_;
	    }
	    next;
	}
	if (s/^=head1 (.*)/=item $1/) {
	    unhead2();
	    output "=over 4\n\n" unless $inhead1;
	    $inhead1 = 1;
	    output $_; nl(); next;
	}
	if (s/^=head2 (.*)/=item $1/) {
	    unitem();
	    output "=over 4\n\n" unless $inhead2;
	    $inhead2 = 1;
	    output $_; nl(); next;
	}
	if (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:/;
	    ##print "=over 4\n\n" unless $initem;
	    output ", " if $initem;
	    $initem = 1;
	    s/\.$//;
	    s/^-X\b/-I<X>/;
	    output $_; next;
	}
	if (s/^=cut\s*\n//) {
	    unhead1();
	    next;
	}
    }
}

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

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

sub unitem {
    if ($initem) {
	output "\n\n";
	##print "\n\n=back\n\n";
    }
    $initem = 0;
}

sub nl {
    output "\n";
}

my $NEWLINE = 0;	# how many newlines have we seen recently
my $LINE;		# what remains to be printed

sub output ($) {
    for (split /(\n)/, shift) {
	if ($_ eq "\n") {
	    if ($LINE) {
		print OUT wrap('', '', $LINE);
		$LINE = '';
	    }
	    if (($NEWLINE) < 2) {
		print OUT;
		$NEWLINE++;
	    }
	}
	elsif (/\S/ && length) {
	    $LINE .= $_;
	    $NEWLINE = 0;
	}
    }
}

# End of original buildtoc. From here on are routines to generate new sections
# for and inplace edit other files

sub generate_perlpod {
  my @output;
  my $maxlength = 0;
  foreach (@Master) {
    my $flags = $_->[0];
    next if $flags->{aux};

    if (@$_ == 2) {
      # Heading
      push @output, "=head2 $_->[1]\n";
    } elsif (@$_ == 3) {
      # Section
      my $start = " " x (4 + $flags->{indent}) . $_->[1];
      $maxlength = length $start if length ($start) > $maxlength;
      push @output, [$start, $_->[2]];
    } elsif (@$_ == 0) {
      # blank line
      push @output, "\n";
    } else {
      die "$0: Illegal length " . scalar @$_;
    }
  }
  # want at least 2 spaces padding
  $maxlength += 2;
  $maxlength = ($maxlength + 3) & ~3;
  # sprintf gives $1.....$2 where ... are spaces:
  return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
		   @output);
}


sub generate_manifest {
  # Annyoingly unexpand doesn't consider it good form to replace a single
  # space before a tab with a tab
  # Annoyingly (2) it returns read only values.
  my @temp = unexpand (map {sprintf "%-32s%s\n", @$_} @_);
  map {s/ \t/\t\t/g; $_} @temp;
}
sub generate_manifest_pod {
  generate_manifest map {["pod/$_.pod", $Pods{$_}]} sort keys %Pods;
}
sub generate_manifest_readme {
  generate_manifest map {["README.$_", $Readmes{$_}]} sort keys %Readmes;
}

sub generate_roffitall {
  (map ({"\t\$maindir/$_.1\t\\"}sort keys %Pods),
   "\t\t\\",
   map ({"\t\$maindir/$_.1\t\\"}sort keys %Aux),
   "\t\t\\",
   map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata),
   "\t\t\\",
   map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules),
  )
}

sub generate_descrip_mms_1 {
  local $Text::Wrap::columns = 150;
  my $count = 0;
  my @lines = map {"pod" . $count++ . " = $_"}
    split /\n/, wrap('', '', join " ", map "[.lib.pod]$_.pod",
		     sort keys %Pods, keys %Readmepods);
  @lines, "pod = " . join ' ', map {"\$(pod$_)"} 0 .. $count - 1;
}

sub generate_descrip_mms_2 {
  map {sprintf <<'SNIP', $_, $_}
[.lib.pod]%s.pod : [.pod]%s.pod
	@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
	Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod]
SNIP
   sort keys %Pods, keys %Readmepods;
}

sub generate_nmake_1 {
  map {sprintf "\tcopy ..\\README.%-8s .\\perl$_.pod\n", $_}
    sort keys %Readmes;
}

# This doesn't have a trailing newline
sub generate_nmake_2 {
  # Spot the special case
  local $Text::Wrap::columns = 76;
  my $line = wrap ("\t    ", "\t    ",
		   join " ", sort map {"perl$_.pod"} "vms", keys %Readmes);
  $line =~ s/$/ \\/mg;
  $line;
}

sub generate_pod_mak {
  my $variable = shift;
  my @lines;
  my $line = join "\\\n", "\U$variable = ",
    map {"\t$_.$variable\t"} sort keys %Pods;
  # Special case
  $line =~ s/.*perltoc.html.*\n//m;
  $line;
}

sub do_manifest {
  my $name = shift;
  my @manifest =
    grep {! m!^pod/[^.]+\.pod.*\n!}
      grep {! m!^README\.(\S+)! || $Ignore{$1}} @_;
  # Dictionary order - fold and handle non-word chars as nothing
  map  { $_->[0] }
  sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] }
  map  { [ $_, lc $_ ] }
    @manifest,
      &generate_manifest_pod(),
	&generate_manifest_readme();
}

sub do_nmake {
  my $name = shift;
  my $makefile = join '', @_;
  die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
  $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
  my $sections = () = $makefile =~ m/\0+/g;
  die "$0: $name contains no README copies" if $sections < 1;
  die "$0: $name contains discontiguous README copies" if $sections > 1;
  $makefile =~ s/\0+/join "", &generate_nmake_1/se;

  $makefile =~ s{(cd \$\(PODDIR\) && del /f [^\n]+).*?(pod2html)}
    {"$1\n" . &generate_nmake_2."\n\t    $2"}se;
  $makefile;
}

# shut up used only once warning
*do_dmake = *do_dmake = \&do_nmake;

sub do_perlpod {
  my $name = shift;
  my $pod = join '', @_;

  unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
		    (?:\s+[a-z]{4,}.*\n	#   fooo
		    |=head.*\n		# =head foo
		    |\s*\n		# blank line
		   )+
		  }
	  {$1 . join "", &generate_perlpod}mxe) {
    die "$0: Failed to insert ammendments in do_perlpod";
  }
  $pod;
}

sub do_podmak {
  my $name = shift;
  my $body = join '', @_;
  foreach my $variable qw(pod man html tex) {
    die "$0: could not find $variable in $name"
      unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*}
	{"\n" . generate_pod_mak ($variable)}se;
  }
  $body;
}

sub do_vms {
  my $name = shift;
  my $makefile = join '', @_;
  die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
  $makefile =~ s/\npod\d* =[^\n]*/\0/gs;
  my $sections = () = $makefile =~ m/\0+/g;
  die "$0: $name contains no pod assignments" if $sections < 1;
  die "$0: $name contains $sections discontigous pod assignments"
    if $sections > 1;
  $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_1/se;

  die "$0: $name contains NUL bytes" if $makefile =~ /\0/;

# Looking for rules like this
# [.lib.pod]perl.pod : [.pod]perl.pod
#	@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
#	Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod]

  $makefile =~ s/\n\Q[.lib.pod]\Eperl[^\n\.]*\.pod[^\n]+\n
		 [^\n]+\n	# Another line
		 [^\n]+\Q[.lib.pod]\E\n		# ends [.lib.pod]
		    /\0/gsx;
  $sections = () = $makefile =~ m/\0+/g;
  die "$0: $name contains no copy rules" if $sections < 1;
  die "$0: $name contains $sections discontigous copy rules"
    if $sections > 1;
  $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_2/se;
  $makefile;
}

# Do stuff

my $built;
while (my ($target, $name) = each %Targets) {
  next unless $Build{$target};
  $built++;
  if ($target eq "toc") {
    &output_perltoc;
    next;
  }
  print "Now processing $name\n" if $Verbose;
  open THING, $name or die "Can't open $name: $!";
  my @orig = <THING>;
  my $orig = join '', @orig;
  close THING;
  my @new = do {
    no strict 'refs';
    &{"do_$target"}($target, @orig);
  };
  my $new = join '', @new;
  if ($new eq $orig) {
    print "Was not modified\n" if $Verbose;
    next;
  }
  rename $name, "$name.old" or die "$0: Can't rename $name to $name.old: $!";
  open THING, ">$name" or die "$0: Can't open $name for writing: $!";
  print THING $new or die "$0: print to $name failed: $!";
  close THING or die die "$0: close $name failed: $!";
}

warn "$0: was not instructed to build anything\n" unless $built;
Commit	Line	Data
41630250 JH	1	#!/usr/bin/perl -w
	2
	3	use strict;
	4	use vars qw($masterpodfile %Build %Targets $Verbose $Up %Ignore
	5	@Master %Readmes %Pods %Aux %Readmepods %Pragmata %Modules);
	6	use File::Spec;
	7	use File::Find;
	8	use FindBin;
	9	use Text::Tabs;
	10	use Text::Wrap;
	11	use Getopt::Long;
	12
	13	no locale;
	14
	15	$Up = File::Spec->updir;
	16	$masterpodfile = File::Spec->catdir($Up, "pod.lst");
	17
	18	# Generate any/all of these files
	19	# --verbose gives slightly more output
	20	# --build-all tries to build everything
	21	# --build-foo updates foo as follows
	22	# --showfiles shows the files to be changed
	23
	24	%Targets
	25	= (
	26	toc => "perltoc.pod",
	27	manifest => File::Spec->catdir($Up, "MANIFEST"),
	28	perlpod => "perl.pod",
	29	vms => File::Spec->catdir($Up, "vms", "descrip_mms.template"),
	30	nmake => File::Spec->catdir($Up, "win32", "Makefile"),
	31	dmake => File::Spec->catdir($Up, "win32", "makefile.mk"),
	32	podmak => File::Spec->catdir($Up, "win32", "pod.mak"),
	33	# plan9 => File::Spec->catdir($Up, "plan9", "mkfile"),
	34	);
	35
	36	{
	37	my @files = keys %Targets;
	38	my $filesopts = join(" \| ", map { "--build-$_" } "all", sort @files);
	39	my $showfiles;
	40	die <<__USAGE__
	41	$0: Usage: $0 [--verbose] [--showfiles] $filesopts
	42	__USAGE__
	43	unless @ARGV
	44	&& GetOptions (verbose => \$Verbose,
	45	showfiles => \$showfiles,
	46	map {+"build-$_", \$Build{$_}} @files, 'all');
	47	# Set them all to true
	48	@Build{@files} = @files if ($Build{all});
	49	if ($showfiles) {
	50	print
	51	join(" ",
	52	sort { lc $a cmp lc $b }
	53	map {
	54	my ($v, $d, $f) = File::Spec->splitpath($_);
	55	my @d;
	56	@d = defined $d ? File::Spec->splitdir($d) : ();
	57	shift @d if @d;
	58	File::Spec->catfile(@d ?
	59	(@d == 1 && $d[0] eq '' ? () : @d)
	60	: "pod", $f);
	61	} @Targets{grep { $_ ne 'all' && $Build{$_} } keys %Build}),
	62	"\n";
	63	exit(0);
	64	}
65	}
66
67	# Don't copy these top level READMEs
68	%Ignore
69	= (
70	Y2K => 1,
71	micro => 1,
72	# vms => 1,
73	);
74
75	if ($Verbose) {
76	print "I'm building $_\n" foreach grep {$Build{$_}} keys %Build;
77	}
78
79	chdir $FindBin::Bin or die "$0: Can't chdir $FindBin::Bin: $!";
80
81	open MASTER, $masterpodfile or die "$0: Can't open $masterpodfile: $!";
82
83	foreach (<MASTER>) {
84	next if /^\#/;
85
86	# At least one upper case letter somewhere in the first group
87	if (/^(\S+)\s(.*)/ && $1 =~ tr/A-Z//) {
88	# it's a heading
89	my $flags = $1;
90	my %flags = (header => 1);
91	$flags{toc_omit} = 1 if $flags =~ tr/O//d;
92	$flags{include} = 1 if $flags =~ tr/I//d;
93	$flags{aux} = 1 if $flags =~ tr/A//d;
94	die "$0: Unknown flag found in heading line: $_" if length $flags;
95	push @Master, [\%flags, $2];
96
97	} elsif (/^(\S)\s+(\S+)\s+(.)/) {
98	# it's a section
99	my ($flags, $filename, $desc) = ($1, $2, $3);
100
101	my %flags = (indent => 0);
102	$flags{indent} = $1 if $flags =~ s/(\d+)//;
103	$flags{toc_omit} = 1 if $flags =~ tr/o//d;
104	$flags{aux} = 1 if $flags =~ tr/a//d;
105	if ($flags =~ tr/r//d) {
106	my $readme = $filename;
107	$readme =~ s/^perl//;
108	$Readmepods{$filename} = $Readmes{$readme} = $desc;
109	$flags{readme} = 1;
110	} elsif ($flags{aux}) {
111	$Aux{$filename} = $desc;
112	} else {
113	$Pods{$filename} = $desc;
114	}
115	die "$0: Unknown flag found in section line: $_" if length $flags;
116	push @Master, [\%flags, $filename, $desc];
117	} elsif (/^$/) {
118	push @Master, undef;
119	} else {
120	die "$0: Malformed line: $_" if $1 =~ tr/A-Z//;
121	}
122	}
123
124	close MASTER;
125
126	# Sanity cross check
127	{
128	my (%disk_pods, @disk_pods);
129	my (@manipods, %manipods);
130	my (@manireadmes, %manireadmes);
131	my (@perlpods, %perlpods);
132	my (%our_pods);
133
134	# Convert these to a list of filenames.
135	foreach (keys %Pods, keys %Readmepods) {
136	$our_pods{"$_.pod"}++;
137	}
138
139	# None of these filenames will be boolean false
140	@disk_pods = glob("*.pod");
141	@disk_pods{@disk_pods} = @disk_pods;
142
143	open(MANI, "../MANIFEST") \|\| die "$0: opening ../MANIFEST failed: $!";
144	while (<MANI>) {
145	if (m!^pod/([^.]+\.pod)\s+!i) {
146	push @manipods, $1;
147	} elsif (m!^README\.(\S+)\s+!i) {
148	next if $Ignore{$1};
149	push @manireadmes, "perl$1.pod";
150	}
151	}
152	close(MANI);
153	@manipods{@manipods} = @manipods;
154	@manireadmes{@manireadmes} = @manireadmes;
155
156	open(PERLPOD, "perl.pod") \|\| die "$0: opening perl.pod failed: $!\n";
157	while (<PERLPOD>) {
158	if (/^For ease of access, /../^\(If you're intending /) {
159	if (/^\s+(perl\S*)\s+\w/) {
160	push @perlpods, "$1.pod";
161	}
162	}
163	}
164	close(PERLPOD);
165	die "$0: could not find the pod listing of perl.pod\n"
166	unless @perlpods;
167	@perlpods{@perlpods} = @perlpods;
168
169	foreach my $i (sort keys %disk_pods) {
170	warn "$0: $i exists but is unknown by buildtoc\n"
171	unless $our_pods{$i};
172	warn "$0: $i exists but is unknown by ../MANIFEST\n"
173	if !$manipods{$i} && !$manireadmes{$i};
174	warn "$0: $i exists but is unknown by perl.pod\n"
175	unless $perlpods{$i};
176	}
177	foreach my $i (sort keys %our_pods) {
178	warn "$0: $i is known by buildtoc but does not exist\n"
179	unless $disk_pods{$i};
180	}
181	foreach my $i (sort keys %manipods) {
182	warn "$0: $i is known by ../MANIFEST but does not exist\n"
183	unless $disk_pods{$i};
184	}
185	foreach my $i (sort keys %perlpods) {
186	warn "$0: $i is known by perl.pod but does not exist\n"
187	unless $disk_pods{$i};
188	}
189	}
190
191	# Find all the mdoules
192	{
193	my @modpods;
194	find \&getpods => qw(../lib ../ext);
195
196	sub getpods {
197	if (/\.p(od\|m)$/) {
198	my $file = $File::Find::name;
199	return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
200	return if $file =~ m!(?:^\|/)t/!;
201	return if $file =~ m!lib/Attribute/Handlers/demo/!;
202	return if $file =~ m!lib/Net/FTP/.+\.pm!; # Hi, Graham! :-)
203	return if $file =~ m!lib/Math/BigInt/t/!;
204	return if $file =~ m!/Devel/PPPort/[Hh]arness\|lib/Devel/Harness!i;
205	return if $file =~ m!XS/(?:APItest\|Typemap)!;
206	die "$0: tut $File::Find::name" if $file =~ /TUT/;
207	unless (open (F, "< $_\0")) {
208	warn "$0: bogus <$file>: $!";
209	system "ls", "-l", $file;
210	}
211	else {
212	my $line;
213	while ($line = <F>) {
214	if ($line =~ /^=head1\s+NAME\b/) {
215	push @modpods, $file;
216	#warn "GOOD $file\n";
217	return;
218	}
219	}
220	warn "$0: $file: cannot find =head1 NAME\n";
221	}
222	}
223	}
224
225	die "$0: no pods" unless @modpods;
226
227	my %done;
228	for (@modpods) {
229	#($name) = /(\w+)\.p(m\|od)$/;
230	my $name = path2modname($_);
231	if ($name =~ /^[a-z]/) {
232	$Pragmata{$name} = $_;
233	} else {
234	if ($done{$name}++) {
235	# warn "already did $_\n";
236	next;
237	}
238	$Modules{$name} = $_;
239	}
240	}
241	}
242
243	# OK. Now a lot of ancillay function definitions follow
244	# Main program returns at "Do stuff"
245
246	sub path2modname {
247	local $_ = shift;
248	s/\.p(m\|od)$//;
249	s-.*?/(lib\|ext)/--;
250	s-/-::-g;
251	s/(\w+)::\1/$1/;
252	return $_;
253	}
254
255	sub output ($);
256
257	sub output_perltoc {
258	open(OUT, ">perltoc.pod") \|\| die "$0: creating perltoc.pod failed: $!";
259
260	$/ = '';
261
262	($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
263
264	=head1 NAME
265
266	perltoc - perl documentation table of contents
267
268	=head1 DESCRIPTION
269
270	This page provides a brief table of contents for the rest of the Perl
271	documentation set. It is meant to be scanned quickly or grepped
272	through to locate the proper section you're looking for.
273
274	=head1 BASIC DOCUMENTATION
275
276	EOPOD2B
277	#' make emacs happy
278
279	# All the things in the master list that happen to be pod filenames
280	podset(map {"$_->[1].pod"} grep {defined $_ && @$_ == 3 && !$_->[0]{toc_omit}} @Master);
281
282
283	($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
284
285
286
287	=head1 PRAGMA DOCUMENTATION
288
289	EOPOD2B
290
291	podset(sort values %Pragmata);
292
293	($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
294
295
296
297	=head1 MODULE DOCUMENTATION
298
299	EOPOD2B
300
301	podset( @Modules{ sort keys %Modules } );
302
303	$_= <<"EOPOD2B";
304
305
306	=head1 AUXILIARY DOCUMENTATION
307
308	Here should be listed all the extra programs' documentation, but they
309	don't all have manual pages yet:
310
311	=over 4
312
313	EOPOD2B
314
315	$_ .= join "\n", map {"\t=item $_\n"} sort keys %Aux;
316	$_ .= <<"EOPOD2B" ;
317
318	=back
319
320	=head1 AUTHOR
321
322	Larry Wall <F<larry\@wall.org>>, with the help of oodles
323	of other folks.
324
325
326	EOPOD2B
327
328	s/^\t//gm;
329	output $_;
330	output "\n"; # flush $LINE
331	}
332
333	# Below are all the auxiliary routines for generating perltoc.pod
334
335	my ($inhead1, $inhead2, $initem);
336
337	sub podset {
338	local @ARGV = @_;
339	my $pod;
340
341	while(<>) {
342	if (s/^=head1 (NAME)\s*/=head2 /) {
343	$pod = path2modname($ARGV);
344	unhead1();
345	output "\n \n\n=head2 ";
346	$_ = <>;
347	if ( /^\s*$pod\b/ ) {
348	s/$pod\.pm/$pod/; # '.pm' in NAME !?
349	output $_;
350	} else {
351	s/^/$pod, /;
352	output $_;
353	}
354	next;
355	}
356	if (s/^=head1 (.*)/=item $1/) {
357	unhead2();
358	output "=over 4\n\n" unless $inhead1;
359	$inhead1 = 1;
360	output $_; nl(); next;
361	}
362	if (s/^=head2 (.*)/=item $1/) {
363	unitem();
364	output "=over 4\n\n" unless $inhead2;
365	$inhead2 = 1;
366	output $_; nl(); next;
367	}
368	if (s/^=item ([^=].*)/$1/) {
369	next if $pod eq 'perldiag';
370	s/^\s\\s*$// && next;
371	s/^\s\\s*//;
372	s/\n/ /g;
373	s/\s+$//;
374	next if /^[\d.]+$/;
375	next if $pod eq 'perlmodlib' && /^ftp:/;
376	##print "=over 4\n\n" unless $initem;
377	output ", " if $initem;
378	$initem = 1;
379	s/\.$//;
380	s/^-X\b/-I<X>/;
381	output $_; next;
382	}
383	if (s/^=cut\s*\n//) {
384	unhead1();
385	next;
386	}
387	}
388	}
389
390	sub unhead1 {
391	unhead2();
392	if ($inhead1) {
393	output "\n\n=back\n\n";
394	}
395	$inhead1 = 0;
396	}
397
398	sub unhead2 {
399	unitem();
400	if ($inhead2) {
401	output "\n\n=back\n\n";
402	}
403	$inhead2 = 0;
404	}
405
406	sub unitem {
407	if ($initem) {
408	output "\n\n";
409	##print "\n\n=back\n\n";
410	}
411	$initem = 0;
412	}
413
414	sub nl {
415	output "\n";
416	}
417
418	my $NEWLINE = 0; # how many newlines have we seen recently
419	my $LINE; # what remains to be printed
420
421	sub output ($) {
422	for (split /(\n)/, shift) {
423	if ($_ eq "\n") {
424	if ($LINE) {
425	print OUT wrap('', '', $LINE);
426	$LINE = '';
427	}
428	if (($NEWLINE) < 2) {
429	print OUT;
430	$NEWLINE++;
431	}
432	}
433	elsif (/\S/ && length) {
434	$LINE .= $_;
435	$NEWLINE = 0;
436	}
437	}
438	}
439
440	# End of original buildtoc. From here on are routines to generate new sections
441	# for and inplace edit other files
442
443	sub generate_perlpod {
444	my @output;
445	my $maxlength = 0;
446	foreach (@Master) {
447	my $flags = $_->[0];
448	next if $flags->{aux};
449
450	if (@$_ == 2) {
451	# Heading
452	push @output, "=head2 $_->[1]\n";
453	} elsif (@$_ == 3) {
454	# Section
455	my $start = " " x (4 + $flags->{indent}) . $_->[1];
456	$maxlength = length $start if length ($start) > $maxlength;
457	push @output, [$start, $_->[2]];
458	} elsif (@$_ == 0) {
459	# blank line
460	push @output, "\n";
461	} else {
462	die "$0: Illegal length " . scalar @$_;
463	}
464	}
465	# want at least 2 spaces padding
466	$maxlength += 2;
467	$maxlength = ($maxlength + 3) & ~3;
468	# sprintf gives $1.....$2 where ... are spaces:
469	return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
470	@output);
471	}
472
473
474	sub generate_manifest {
475	# Annyoingly unexpand doesn't consider it good form to replace a single
476	# space before a tab with a tab
477	# Annoyingly (2) it returns read only values.
478	my @temp = unexpand (map {sprintf "%-32s%s\n", @$_} @_);
479	map {s/ \t/\t\t/g; $_} @temp;
480	}
481	sub generate_manifest_pod {
482	generate_manifest map {["pod/$_.pod", $Pods{$_}]} sort keys %Pods;
483	}
484	sub generate_manifest_readme {
485	generate_manifest map {["README.$_", $Readmes{$_}]} sort keys %Readmes;
486	}
487
488	sub generate_roffitall {
489	(map ({"\t\$maindir/$_.1\t\\"}sort keys %Pods),
490	"\t\t\\",
491	map ({"\t\$maindir/$_.1\t\\"}sort keys %Aux),
492	"\t\t\\",
493	map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata),
494	"\t\t\\",
495	map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules),
496	)
497	}
498
499	sub generate_descrip_mms_1 {
500	local $Text::Wrap::columns = 150;
501	my $count = 0;
502	my @lines = map {"pod" . $count++ . " = $_"}
503	split /\n/, wrap('', '', join " ", map "[.lib.pod]$_.pod",
504	sort keys %Pods, keys %Readmepods);
505	@lines, "pod = " . join ' ', map {"\$(pod$_)"} 0 .. $count - 1;
506	}
507
508	sub generate_descrip_mms_2 {
509	map {sprintf <<'SNIP', $_, $_}
510	[.lib.pod]%s.pod : [.pod]%s.pod
511	@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
512	Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod]
513	SNIP
514	sort keys %Pods, keys %Readmepods;
515	}
516
517	sub generate_nmake_1 {
518	map {sprintf "\tcopy ..\\README.%-8s .\\perl$_.pod\n", $_}
519	sort keys %Readmes;
520	}
521
522	# This doesn't have a trailing newline
523	sub generate_nmake_2 {
524	# Spot the special case
525	local $Text::Wrap::columns = 76;
526	my $line = wrap ("\t ", "\t ",
527	join " ", sort map {"perl$_.pod"} "vms", keys %Readmes);
528	$line =~ s/$/ \\/mg;
529	$line;
530	}
531
532	sub generate_pod_mak {
533	my $variable = shift;
534	my @lines;
535	my $line = join "\\\n", "\U$variable = ",
536	map {"\t$_.$variable\t"} sort keys %Pods;
537	# Special case
538	$line =~ s/.perltoc.html.\n//m;
539	$line;
540	}
541
542	sub do_manifest {
543	my $name = shift;
544	my @manifest =
545	grep {! m!^pod/[^.]+\.pod.*\n!}
546	grep {! m!^README\.(\S+)! \|\| $Ignore{$1}} @_;
547	# Dictionary order - fold and handle non-word chars as nothing
548	map { $_->[0] }
549	sort { $a->[1] cmp $b->[1] \|\| $a->[0] cmp $b->[0] }
550	map { [ $_, lc $_ ] }
551	@manifest,
552	&generate_manifest_pod(),
553	&generate_manifest_readme();
554	}
555
556	sub do_nmake {
557	my $name = shift;
558	my $makefile = join '', @_;
559	die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
560	$makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
561	my $sections = () = $makefile =~ m/\0+/g;
562	die "$0: $name contains no README copies" if $sections < 1;
563	die "$0: $name contains discontiguous README copies" if $sections > 1;
564	$makefile =~ s/\0+/join "", &generate_nmake_1/se;
565
566	$makefile =~ s{(cd \$\(PODDIR\) && del /f [^\n]+).*?(pod2html)}
567	{"$1\n" . &generate_nmake_2."\n\t $2"}se;
568	$makefile;
569	}
570
571	# shut up used only once warning
572	do_dmake = do_dmake = \&do_nmake;
573
574	sub do_perlpod {
575	my $name = shift;
576	my $pod = join '', @_;
577
578	unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
579	(?:\s+[a-z]{4,}.*\n # fooo
580	\|=head.*\n # =head foo
581	\|\s*\n # blank line
582	)+
583	}
584	{$1 . join "", &generate_perlpod}mxe) {
585	die "$0: Failed to insert ammendments in do_perlpod";
586	}
587	$pod;
588	}
589
590	sub do_podmak {
591	my $name = shift;
592	my $body = join '', @_;
593	foreach my $variable qw(pod man html tex) {
594	die "$0: could not find $variable in $name"
595	unless $body =~ s{\n\U$variable\E = (?:[^\n]\\\n)[^\n]*}
596	{"\n" . generate_pod_mak ($variable)}se;
597	}
598	$body;
599	}
600
601	sub do_vms {
602	my $name = shift;
603	my $makefile = join '', @_;
604	die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
605	$makefile =~ s/\npod\d* =[^\n]*/\0/gs;
606	my $sections = () = $makefile =~ m/\0+/g;
607	die "$0: $name contains no pod assignments" if $sections < 1;
608	die "$0: $name contains $sections discontigous pod assignments"
609	if $sections > 1;
610	$makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_1/se;
611
612	die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
613
614	# Looking for rules like this
615	# [.lib.pod]perl.pod : [.pod]perl.pod
616	# @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
617	# Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod]
618
619	$makefile =~ s/\n\Q[.lib.pod]\Eperl[^\n\.]*\.pod[^\n]+\n
620	[^\n]+\n # Another line
621	[^\n]+\Q[.lib.pod]\E\n # ends [.lib.pod]
622	/\0/gsx;
623	$sections = () = $makefile =~ m/\0+/g;
624	die "$0: $name contains no copy rules" if $sections < 1;
625	die "$0: $name contains $sections discontigous copy rules"
626	if $sections > 1;
627	$makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_2/se;
628	$makefile;
629	}
630
631	# Do stuff
632
633	my $built;
634	while (my ($target, $name) = each %Targets) {
635	next unless $Build{$target};
636	$built++;
637	if ($target eq "toc") {
638	&output_perltoc;
639	next;
640	}
641	print "Now processing $name\n" if $Verbose;
642	open THING, $name or die "Can't open $name: $!";
643	my @orig = <THING>;
644	my $orig = join '', @orig;
645	close THING;
646	my @new = do {
647	no strict 'refs';
648	&{"do_$target"}($target, @orig);
649	};
650	my $new = join '', @new;
651	if ($new eq $orig) {
652	print "Was not modified\n" if $Verbose;
653	next;
654	}
655	rename $name, "$name.old" or die "$0: Can't rename $name to $name.old: $!";
656	open THING, ">$name" or die "$0: Can't open $name for writing: $!";
657	print THING $new or die "$0: print to $name failed: $!";
658	close THING or die die "$0: close $name failed: $!";
659	}
660
661	warn "$0: was not instructed to build anything\n" unless $built;