[p5sagit/p5-mst-13.2.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/h//) {
    # it's a heading
    my $flags = $1;
    $flags =~ tr/h//d;
    my %flags = (header => 1);
    $flags{toc_omit} = 1 if $flags =~ tr/o//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)!;
      my $pod = $file;
      return if $pod =~ s/pm$/pod/ && -e $pod;
      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: $!";

  local $/ = '';

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

	# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
	# This file is autogenerated by buildtoc from all the other pods.
	# Edit those files and run buildtoc --build-toc 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
#' 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(<>) {
	tr/\015//d;
	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', $_, $_ eq 'perlvms' ? 'vms' : 'pod', $_}
[.lib.pod]%s.pod : [.%s]%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  { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] }
    @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") {
    print "Now processing $name\n" if $Verbose;
    &output_perltoc;
    print "Finished\n" if $Verbose;
    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	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
8927c9d8	87	if (/^(\S+)\s(.*)/ && $1 =~ tr/h//) {
41630250	88	# it's a heading
41630250	89	my $flags = $1;
8927c9d8	90	$flags =~ tr/h//d;
41630250	91	my %flags = (header => 1);
8927c9d8	92	$flags{toc_omit} = 1 if $flags =~ tr/o//d;
8927c9d8	93	$flags{aux} = 1 if $flags =~ tr/a//d;
41630250	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)!;
be6d6286	206	my $pod = $file;
be6d6286	207	return if $pod =~ s/pm$/pod/ && -e $pod;
41630250	208	die "$0: tut $File::Find::name" if $file =~ /TUT/;
	209	unless (open (F, "< $_\0")) {
	210	warn "$0: bogus <$file>: $!";
	211	system "ls", "-l", $file;
	212	}
	213	else {
	214	my $line;
	215	while ($line = <F>) {
	216	if ($line =~ /^=head1\s+NAME\b/) {
	217	push @modpods, $file;
	218	#warn "GOOD $file\n";
	219	return;
	220	}
	221	}
	222	warn "$0: $file: cannot find =head1 NAME\n";
	223	}
	224	}
	225	}
	226
	227	die "$0: no pods" unless @modpods;
	228
	229	my %done;
	230	for (@modpods) {
	231	#($name) = /(\w+)\.p(m\|od)$/;
	232	my $name = path2modname($_);
	233	if ($name =~ /^[a-z]/) {
	234	$Pragmata{$name} = $_;
	235	} else {
	236	if ($done{$name}++) {
	237	# warn "already did $_\n";
	238	next;
	239	}
	240	$Modules{$name} = $_;
	241	}
	242	}
	243	}
	244
	245	# OK. Now a lot of ancillay function definitions follow
	246	# Main program returns at "Do stuff"
	247
	248	sub path2modname {
	249	local $_ = shift;
	250	s/\.p(m\|od)$//;
	251	s-.*?/(lib\|ext)/--;
	252	s-/-::-g;
	253	s/(\w+)::\1/$1/;
	254	return $_;
	255	}
	256
	257	sub output ($);
	258
	259	sub output_perltoc {
	260	open(OUT, ">perltoc.pod") \|\| die "$0: creating perltoc.pod failed: $!";
	261
671313d0	262	local $/ = '';
41630250	263
	264	($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
	265
97f32038	266	# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
	267	# This file is autogenerated by buildtoc from all the other pods.
	268	# Edit those files and run buildtoc --build-toc to effect changes.
97f32038	269
41630250	270	=head1 NAME
	271
	272	perltoc - perl documentation table of contents
	273
	274	=head1 DESCRIPTION
	275
	276	This page provides a brief table of contents for the rest of the Perl
	277	documentation set. It is meant to be scanned quickly or grepped
	278	through to locate the proper section you're looking for.
	279
	280	=head1 BASIC DOCUMENTATION
	281
	282	EOPOD2B
	283	#' make emacs happy
	284
	285	# All the things in the master list that happen to be pod filenames
	286	podset(map {"$_->[1].pod"} grep {defined $_ && @$_ == 3 && !$_->[0]{toc_omit}} @Master);
	287
	288
	289	($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
	290
	291
	292
	293	=head1 PRAGMA DOCUMENTATION
	294
	295	EOPOD2B
	296
	297	podset(sort values %Pragmata);
	298
	299	($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
	300
	301
	302
	303	=head1 MODULE DOCUMENTATION
	304
	305	EOPOD2B
	306
	307	podset( @Modules{ sort keys %Modules } );
	308
	309	$_= <<"EOPOD2B";
	310
	311
	312	=head1 AUXILIARY DOCUMENTATION
	313
	314	Here should be listed all the extra programs' documentation, but they
	315	don't all have manual pages yet:
	316
	317	=over 4
	318
	319	EOPOD2B
	320
	321	$_ .= join "\n", map {"\t=item $_\n"} sort keys %Aux;
	322	$_ .= <<"EOPOD2B" ;
	323
	324	=back
	325
	326	=head1 AUTHOR
	327
	328	Larry Wall <F<larry\@wall.org>>, with the help of oodles
	329	of other folks.
	330
	331
	332	EOPOD2B
	333
334	s/^\t//gm;
335	output $_;
336	output "\n"; # flush $LINE
337	}
338
339	# Below are all the auxiliary routines for generating perltoc.pod
340
341	my ($inhead1, $inhead2, $initem);
342
343	sub podset {
344	local @ARGV = @_;
345	my $pod;
346
347	while(<>) {
16114dde	348	tr/\015//d;
41630250	349	if (s/^=head1 (NAME)\s*/=head2 /) {
	350	$pod = path2modname($ARGV);
	351	unhead1();
	352	output "\n \n\n=head2 ";
	353	$_ = <>;
	354	if ( /^\s*$pod\b/ ) {
	355	s/$pod\.pm/$pod/; # '.pm' in NAME !?
	356	output $_;
	357	} else {
	358	s/^/$pod, /;
	359	output $_;
	360	}
	361	next;
	362	}
	363	if (s/^=head1 (.*)/=item $1/) {
	364	unhead2();
	365	output "=over 4\n\n" unless $inhead1;
	366	$inhead1 = 1;
	367	output $_; nl(); next;
	368	}
	369	if (s/^=head2 (.*)/=item $1/) {
	370	unitem();
	371	output "=over 4\n\n" unless $inhead2;
	372	$inhead2 = 1;
	373	output $_; nl(); next;
	374	}
	375	if (s/^=item ([^=].*)/$1/) {
	376	next if $pod eq 'perldiag';
	377	s/^\s\\s*$// && next;
	378	s/^\s\\s*//;
	379	s/\n/ /g;
	380	s/\s+$//;
	381	next if /^[\d.]+$/;
	382	next if $pod eq 'perlmodlib' && /^ftp:/;
	383	##print "=over 4\n\n" unless $initem;
	384	output ", " if $initem;
	385	$initem = 1;
	386	s/\.$//;
	387	s/^-X\b/-I<X>/;
	388	output $_; next;
	389	}
	390	if (s/^=cut\s*\n//) {
	391	unhead1();
	392	next;
	393	}
	394	}
	395	}
	396
	397	sub unhead1 {
	398	unhead2();
	399	if ($inhead1) {
	400	output "\n\n=back\n\n";
	401	}
	402	$inhead1 = 0;
	403	}
	404
	405	sub unhead2 {
	406	unitem();
	407	if ($inhead2) {
	408	output "\n\n=back\n\n";
	409	}
	410	$inhead2 = 0;
	411	}
	412
413	sub unitem {
414	if ($initem) {
415	output "\n\n";
416	##print "\n\n=back\n\n";
417	}
418	$initem = 0;
419	}
420
421	sub nl {
422	output "\n";
423	}
424
425	my $NEWLINE = 0; # how many newlines have we seen recently
426	my $LINE; # what remains to be printed
427
428	sub output ($) {
429	for (split /(\n)/, shift) {
430	if ($_ eq "\n") {
431	if ($LINE) {
432	print OUT wrap('', '', $LINE);
433	$LINE = '';
434	}
435	if (($NEWLINE) < 2) {
436	print OUT;
437	$NEWLINE++;
438	}
439	}
440	elsif (/\S/ && length) {
441	$LINE .= $_;
442	$NEWLINE = 0;
443	}
444	}
445	}
446
447	# End of original buildtoc. From here on are routines to generate new sections
448	# for and inplace edit other files
449
450	sub generate_perlpod {
451	my @output;
452	my $maxlength = 0;
453	foreach (@Master) {
454	my $flags = $_->[0];
455	next if $flags->{aux};
456
457	if (@$_ == 2) {
458	# Heading
459	push @output, "=head2 $_->[1]\n";
460	} elsif (@$_ == 3) {
461	# Section
462	my $start = " " x (4 + $flags->{indent}) . $_->[1];
463	$maxlength = length $start if length ($start) > $maxlength;
464	push @output, [$start, $_->[2]];
465	} elsif (@$_ == 0) {
466	# blank line
467	push @output, "\n";
468	} else {
469	die "$0: Illegal length " . scalar @$_;
470	}
471	}
472	# want at least 2 spaces padding
473	$maxlength += 2;
474	$maxlength = ($maxlength + 3) & ~3;
475	# sprintf gives $1.....$2 where ... are spaces:
476	return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
477	@output);
478	}
479
480
481	sub generate_manifest {
482	# Annyoingly unexpand doesn't consider it good form to replace a single
483	# space before a tab with a tab
484	# Annoyingly (2) it returns read only values.
485	my @temp = unexpand (map {sprintf "%-32s%s\n", @$_} @_);
486	map {s/ \t/\t\t/g; $_} @temp;
487	}
488	sub generate_manifest_pod {
489	generate_manifest map {["pod/$_.pod", $Pods{$_}]} sort keys %Pods;
490	}
491	sub generate_manifest_readme {
492	generate_manifest map {["README.$_", $Readmes{$_}]} sort keys %Readmes;
493	}
494
495	sub generate_roffitall {
496	(map ({"\t\$maindir/$_.1\t\\"}sort keys %Pods),
497	"\t\t\\",
498	map ({"\t\$maindir/$_.1\t\\"}sort keys %Aux),
499	"\t\t\\",
500	map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata),
501	"\t\t\\",
502	map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules),
503	)
504	}
505
506	sub generate_descrip_mms_1 {
507	local $Text::Wrap::columns = 150;
508	my $count = 0;
509	my @lines = map {"pod" . $count++ . " = $_"}
510	split /\n/, wrap('', '', join " ", map "[.lib.pod]$_.pod",
511	sort keys %Pods, keys %Readmepods);
512	@lines, "pod = " . join ' ', map {"\$(pod$_)"} 0 .. $count - 1;
513	}
514
515	sub generate_descrip_mms_2 {
ab1db26f	516	map {sprintf <<'SNIP', $_, $_ eq 'perlvms' ? 'vms' : 'pod', $_}
ab1db26f	517	[.lib.pod]%s.pod : [.%s]%s.pod
41630250	518	@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
	519	Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod]
	520	SNIP
	521	sort keys %Pods, keys %Readmepods;
	522	}
	523
	524	sub generate_nmake_1 {
	525	map {sprintf "\tcopy ..\\README.%-8s .\\perl$_.pod\n", $_}
	526	sort keys %Readmes;
	527	}
	528
	529	# This doesn't have a trailing newline
	530	sub generate_nmake_2 {
	531	# Spot the special case
	532	local $Text::Wrap::columns = 76;
	533	my $line = wrap ("\t ", "\t ",
	534	join " ", sort map {"perl$_.pod"} "vms", keys %Readmes);
	535	$line =~ s/$/ \\/mg;
	536	$line;
	537	}
	538
	539	sub generate_pod_mak {
	540	my $variable = shift;
	541	my @lines;
	542	my $line = join "\\\n", "\U$variable = ",
	543	map {"\t$_.$variable\t"} sort keys %Pods;
	544	# Special case
	545	$line =~ s/.perltoc.html.\n//m;
	546	$line;
	547	}
	548
	549	sub do_manifest {
	550	my $name = shift;
	551	my @manifest =
	552	grep {! m!^pod/[^.]+\.pod.*\n!}
	553	grep {! m!^README\.(\S+)! \|\| $Ignore{$1}} @_;
	554	# Dictionary order - fold and handle non-word chars as nothing
	555	map { $_->[0] }
	556	sort { $a->[1] cmp $b->[1] \|\| $a->[0] cmp $b->[0] }
6578b326	557	map { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] }
41630250	558	@manifest,
	559	&generate_manifest_pod(),
	560	&generate_manifest_readme();
	561	}
	562
	563	sub do_nmake {
	564	my $name = shift;
	565	my $makefile = join '', @_;
	566	die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
	567	$makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
	568	my $sections = () = $makefile =~ m/\0+/g;
	569	die "$0: $name contains no README copies" if $sections < 1;
	570	die "$0: $name contains discontiguous README copies" if $sections > 1;
	571	$makefile =~ s/\0+/join "", &generate_nmake_1/se;
	572
	573	$makefile =~ s{(cd \$\(PODDIR\) && del /f [^\n]+).*?(pod2html)}
	574	{"$1\n" . &generate_nmake_2."\n\t $2"}se;
	575	$makefile;
	576	}
	577
	578	# shut up used only once warning
	579	do_dmake = do_dmake = \&do_nmake;
	580
	581	sub do_perlpod {
	582	my $name = shift;
	583	my $pod = join '', @_;
	584
	585	unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
	586	(?:\s+[a-z]{4,}.*\n # fooo
	587	\|=head.*\n # =head foo
	588	\|\s*\n # blank line
	589	)+
	590	}
	591	{$1 . join "", &generate_perlpod}mxe) {
	592	die "$0: Failed to insert ammendments in do_perlpod";
	593	}
	594	$pod;
	595	}
	596
	597	sub do_podmak {
	598	my $name = shift;
	599	my $body = join '', @_;
d525b9bc	600	foreach my $variable (qw(pod man html tex)) {
41630250	601	die "$0: could not find $variable in $name"
	602	unless $body =~ s{\n\U$variable\E = (?:[^\n]\\\n)[^\n]*}
	603	{"\n" . generate_pod_mak ($variable)}se;
	604	}
	605	$body;
	606	}
	607
	608	sub do_vms {
	609	my $name = shift;
	610	my $makefile = join '', @_;
	611	die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
	612	$makefile =~ s/\npod\d* =[^\n]*/\0/gs;
	613	my $sections = () = $makefile =~ m/\0+/g;
	614	die "$0: $name contains no pod assignments" if $sections < 1;
	615	die "$0: $name contains $sections discontigous pod assignments"
	616	if $sections > 1;
	617	$makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_1/se;
	618
	619	die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
	620
	621	# Looking for rules like this
	622	# [.lib.pod]perl.pod : [.pod]perl.pod
	623	# @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
	624	# Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod]
	625
	626	$makefile =~ s/\n\Q[.lib.pod]\Eperl[^\n\.]*\.pod[^\n]+\n
	627	[^\n]+\n # Another line
	628	[^\n]+\Q[.lib.pod]\E\n # ends [.lib.pod]
	629	/\0/gsx;
	630	$sections = () = $makefile =~ m/\0+/g;
	631	die "$0: $name contains no copy rules" if $sections < 1;
	632	die "$0: $name contains $sections discontigous copy rules"
	633	if $sections > 1;
	634	$makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_2/se;
	635	$makefile;
	636	}
	637
	638	# Do stuff
	639
	640	my $built;
	641	while (my ($target, $name) = each %Targets) {
	642	next unless $Build{$target};
	643	$built++;
	644	if ($target eq "toc") {
671313d0	645	print "Now processing $name\n" if $Verbose;
41630250	646	&output_perltoc;
671313d0	647	print "Finished\n" if $Verbose;
41630250	648	next;
	649	}
	650	print "Now processing $name\n" if $Verbose;
	651	open THING, $name or die "Can't open $name: $!";
	652	my @orig = <THING>;
	653	my $orig = join '', @orig;
	654	close THING;
	655	my @new = do {
	656	no strict 'refs';
	657	&{"do_$target"}($target, @orig);
	658	};
	659	my $new = join '', @new;
	660	if ($new eq $orig) {
	661	print "Was not modified\n" if $Verbose;
	662	next;
	663	}
	664	rename $name, "$name.old" or die "$0: Can't rename $name to $name.old: $!";
	665	open THING, ">$name" or die "$0: Can't open $name for writing: $!";
	666	print THING $new or die "$0: print to $name failed: $!";
	667	close THING or die die "$0: close $name failed: $!";
	668	}
	669
	670	warn "$0: was not instructed to build anything\n" unless $built;