path: root/pod/buildtoc

#!/usr/bin/perl -w

use strict;
use vars qw(%Build %Targets %Pragmata %Modules $Verbose $Quiet $Test);
use File::Spec;
use File::Find;
use FindBin;
use Text::Tabs;
use Text::Wrap;
use Getopt::Long;
use Carp;

no locale;
require 5.010;

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

# Generate any/all of these files
# --verbose gives slightly more output
# --quiet suppresses routine warnings
# --build-all tries to build everything
# --build-foo updates foo as follows
# --showfiles shows the files to be changed
# --test exit if perl.pod, pod.lst, MANIFEST are consistent, and regenerated
#   files are up to date, die otherwise.

%Targets
  = (
     toc => 'pod/perltoc.pod',
     manifest => 'MANIFEST',
     perlpod => 'pod/perl.pod',
     vms => 'vms/descrip_mms.template',
     nmake => 'win32/Makefile',
     dmake => 'win32/makefile.mk',
     podmak => 'win32/pod.mak',
     # plan9 =>  'plan9/mkfile'),
     unix => 'Makefile.SH',
     # TODO: add roffitall
    );

# process command-line switches

{
  my @files = keys %Targets;
  my $filesopts = join(" | ", map { "--build-$_" } "all", sort @files);
  my $showfiles;
  my %build_these;
  die <<__USAGE__
$0: Usage: $0 [--verbose] [--showfiles] $filesopts
__USAGE__
  unless @ARGV
	&& GetOptions (verbose => \$Verbose,
		       quiet => \$Quiet,
		       showfiles => \$showfiles,
		       test => \$Test,
		       map {+"build-$_", \$build_these{$_}} @files, 'all');
  if ($build_these{all}) {
    %Build = %Targets;
  } else {
    while (my ($file, $want) = each %build_these) {
      $Build{$file} = $Targets{$file} if $want;
    }
  }
  if ($showfiles) {
      print join(" ", sort { lc $a cmp lc $b } values %Build), "\n";
      exit(0);
  }
}

if ($Verbose) {
  print "I will be building $_\n" foreach keys %Build;
}

my $state = get_pod_metadata(values %Build);

if ($Test) {
    delete $Build{toc};
    printf "1..%d\n", 1 + scalar keys %Build;
    if (@{$state->{inconsistent}}) {
        print "not ok 1\n";
        die @{$state->{inconsistent}};
    }
    print "ok 1\n";
}
else {
    warn @{$state->{inconsistent}} if @{$state->{inconsistent}};
}


# Find all the modules
if ($Build{toc}) {
  my @modpods;
  find \&getpods => 'lib';

  sub getpods {
    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;
      }
    }
  }

  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} = $_;
    }
  }
}

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

my $OUT;

sub do_toc {
  my $filename = shift;

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

  return $OUT;
}

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

# 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 (@{$state->{master}}) {
    my $flags = $_->[0];
    next if $flags->{aux};
    next if $flags->{perlpod_omit};

    if (@$_ == 2) {
      # Heading
      push @output, "=head2 $_->[1]\n";
    } elsif (@$_ == 5) {
      # Section
      my $start = " " x (4 + $flags->{indent}) . $_->[4];
      $maxlength = length $start if length ($start) > $maxlength;
      push @output, [$start, $_->[3]];
    } elsif (@$_ == 0) {
      # blank line
      push @output, "\n";
    } else {
      my_die "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 {
  # Annoyingly, 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", @$_} @_);
  map {s/ \t/\t\t/g; $_} @temp;
}
sub generate_manifest_pod {
  generate_manifest map {["pod/$_.pod", $state->{pods}{$_}]}
    sort grep {
        !$state->{copies}{"$_.pod"} && !$state->{generated}{"$_.pod"} && !-e "$_.pod"
    } keys %{$state->{pods}};
}
sub generate_manifest_readme {
  generate_manifest sort {$a->[0] cmp $b->[0]}
    ["README.vms", "Notes about installing the VMS port"],
      map {["README.$_", $state->{readmes}{$_}]} keys %{$state->{readmes}};
}

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),
  )
}

sub generate_nmake_1 {
  # XXX Fix this with File::Spec
  (map {sprintf "\tcopy ..\\README.%-8s ..\\pod\\perl$_.pod\n", $_}
    sort keys %{$state->{readmes}}),
      (map {"\tcopy ..\\pod\\$state->{copies}{$_} ..\\pod\\$_\n"} sort keys %{$state->{copies}});
}

# 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 keys %{$state->{copies}}, keys %{$state->{generated}},
                                  map {"perl$_.pod"} keys %{$state->{readmes}});
  $line =~ s/$/ \\/mg;
  $line =~ s/ \\$//;
  $line;
}

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

sub verify_contiguous {
  my ($name, $content, $what) = @_;
  my $sections = () = $content =~ m/\0+/g;
  croak("$0: $name contains no $what") if $sections < 1;
  croak("$0: $name contains discontiguous $what") if $sections > 1;
}

sub do_manifest {
  my ($name, $prev) = @_;
  my @manifest =
    grep {! m!^pod/[^.]+\.pod.*!}
      grep {! m!^README\.(\S+)! || $state->{ignore}{$1}} split "\n", $prev;
  join "\n", (
	      # 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, $makefile) = @_;
  $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
  verify_contiguous($name, $makefile, 'README copies');
  # Now remove the other copies that follow
  1 while $makefile =~ s/\0\tcopy .*\n/\0/gm;
  $makefile =~ s/\0+/join ("", &generate_nmake_1)/se;

  $makefile =~ s{(-cd \$\(PODDIR\) && del /f[^\n]+).*?(-cd \.\.\\utils && del /f)}
    {"$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, $pod) = @_;

  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) {
    my_die "Failed to insert amendments in do_perlpod";
  }
  $pod;
}

sub do_podmak {
  my ($name, $body) = @_;
  foreach my $variable (qw(pod man html tex)) {
    my_die "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, $makefile) = @_;

# Looking for the macro defining the current perldelta:
#PERLDELTA_CURRENT = [.pod]perl5139delta.pod

  $makefile =~ s/\nPERLDELTA_CURRENT\s+=\s+\Q[.pod]perl\E\d+delta\.pod\n
		    /\0/sx;
  verify_contiguous($name, $makefile, 'current perldelta macro');
  $makefile =~ s/\0+/join "\n", '', "PERLDELTA_CURRENT = [.pod]$state->{delta_target}", ''/se;

  $makefile;
}

sub do_unix {
  my ($name, $makefile_SH) = @_;

  $makefile_SH =~ s{^(perltoc_pod_prereqs = extra.pods).*}
		   {join ' ', $1, map "pod/$_",
                        sort keys %{$state->{copies}}, grep {!/perltoc/} keys %{$state->{generated}}
		    }mge;

# pod/perl511delta.pod: pod/perldelta.pod
# 	cd pod && $(LNS) perldelta.pod perl511delta.pod

  $makefile_SH =~ s!(
pod/perl[a-z0-9_]+\.pod: pod/perl[a-z0-9_]+\.pod
	\$\(LNS\) perl[a-z0-9_]+\.pod pod/perl[a-z0-9_]+\.pod
)+!\0!gm;

  verify_contiguous($name, $makefile_SH, 'copy rules');

  my @copy_rules = map "
pod/$_: pod/$state->{copies}{$_}
	\$(LNS) $state->{copies}{$_} pod/$_
", keys %{$state->{copies}};

  $makefile_SH =~ s/\0+/join '', @copy_rules/se;
  $makefile_SH;

}

# Do stuff

my $built;
while (my ($target, $name) = each %Targets) {
  print "Working on target $target\n" if $Verbose;
  next unless $Build{$target};
  $built++;
  my ($orig, $mode);
  print "Now processing $name\n" if $Verbose;
  if ($target ne "toc") {
    local $/;
    my $thing = open_or_die($name);
    binmode $thing;
    $orig = <$thing>;
    my_die "$name contains NUL bytes" if $orig =~ /\0/;
  }

  my $new = do {
    no strict 'refs';
    &{"do_$target"}($target, $orig);
  };

  if (defined $orig) {
    if ($new eq $orig) {
      if ($Test) {
	printf "ok %d # $name is up to date\n", $built + 1;
      } elsif ($Verbose) {
	print "Was not modified\n";
      }
      next;
    } elsif ($Test) {
      printf "not ok %d # $name is up to date\n", $built + 1;
      next;
    }
    $mode = (stat $name)[2] // my_die "Can't stat $name: $!";
    rename $name, "$name.old" or my_die "Can't rename $name to $name.old: $!";
  }

  open my $thing, '>', $name or my_die "Can't open $name for writing: $!";
  binmode $thing;
  print $thing $new or my_die "print to $name failed: $!";
  close $thing or my_die "close $name failed: $!";
  if (defined $mode) {
    chmod $mode & 0777, $name or my_die "can't chmod $mode $name: $!";
  }
}

warn "$0: was not instructed to build anything\n" unless $built || $Test;