#!/usr/bin/perl -w
our ($masterpodfile, %Build, %Targets, $Verbose, $Up, %Ignore
, @Master, %Readmes, %Pods, %Aux, %Readmepods, %Pragmata, %Modules
, %Copies);
use File::Spec;
use File::Find;
use FindBin;
use Text::Tabs;
use Text::Wrap;
use Getopt::Long;
$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 => "kurilatoc.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"),
unix => File::Spec->catdir($Up, "Makefile.SH"),
# TODO: add roffitall
);
do {
my @files = keys %Targets;
my $filesopts = join(" | ", map { "--build-$_" }, @( "all", < sort @files));
my $showfiles;
die <<__USAGE__
$^PROGRAM_NAME: Usage: $^PROGRAM_NAME [--verbose] [--showfiles] $filesopts
__USAGE__
unless (nelems @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 (nelems @d);
File::Spec->catfile((nelems @d)
?? ((nelems @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
= %(
micro => 1,
# vms => 1,
);
if ($Verbose) {
print "I'm building $_\n" foreach grep {%Build{$_}}, keys %Build;
}
chdir $FindBin::Bin or die "$^PROGRAM_NAME: Can't chdir $FindBin::Bin: $^OS_ERROR";
open my $master, "<", $masterpodfile or die "$^PROGRAM_NAME: Can't open $masterpodfile: $^OS_ERROR";
my ($delta_source, $delta_target);
foreach (@( ~< *$master)) {
next if m/^\#/;
# At least one upper case letter somewhere in the first group
if (m/^(\S+)\s(.*)/ && (my $flags = $1) =~ m/h/) {
# it's a heading
$flags =~ s/h//g;
my %flags = %(header => 1);
%flags{+toc_omit} = 1 if $flags =~ s/o//g;
%flags{+aux} = 1 if $flags =~ s/a//g;
die "$^PROGRAM_NAME: Unknown flag found in heading line: $_" if length $flags;
push @Master, \@(\%flags, $2);
} elsif (m/^(\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 =~ s/o//g;
%flags{+aux} = 1 if $flags =~ s/a//g;
if ($flags =~ s/D//g) {
%flags{+perlpod_omit} = 1;
$delta_source = "$filename.pod";
}
if ($flags =~ s/d//g) {
%flags{+manifest_omit} = 1;
$delta_target = "$filename.pod";
}
if ($flags =~ s/r//g) {
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 "$^PROGRAM_NAME: Unknown flag found in section line: $_" if length $flags;
push @Master, \@(\%flags, $filename, $desc);
} elsif (m/^$/) {
push @Master, undef;
} else {
die "$^PROGRAM_NAME: Malformed line: $_" if $1 =~ m/[A-Z]/;
}
}
if (defined $delta_source) {
if (defined $delta_target) {
# This way round so that keys can act as a MANIFEST skip list
# Targets will aways be in the pod directory. Currently we can only cope
# with sources being in the same directory. Fix this and do perlvms.pod
# with this?
%Copies{+$delta_target} = $delta_source;
} else {
die "$^PROGRAM_NAME: delta source defined but not target";
}
} elsif (defined $delta_target) {
die "$^PROGRAM_NAME: delta target defined but not target";
}
close $master;
# Sanity cross check
do {
my (%disk_pods, @disk_pods);
my (@manipods, %manipods);
my (@manireadmes, %manireadmes);
my (@perlpods, %perlpods);
my (%our_pods);
my (%sources);
# 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;
# Things we copy from won't be in perl.pod
# Things we copy to won't be in MANIFEST
%sources{[values %Copies]} = @();
open(my $mani, "<", "../MANIFEST") || die "$^PROGRAM_NAME: opening ../MANIFEST failed: $^OS_ERROR";
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;
my $in_perlpod;
open(my $perlpod, "<", "perl.pod") || die "$^PROGRAM_NAME: opening perl.pod failed: $^OS_ERROR\n";
while ( ~< *$perlpod) {
$in_perlpod ||= m/^For ease of access/;
$in_perlpod &&= ! m/^\(If you're intending /;
if ($in_perlpod) {
if (m/^\s+((?:perl|kurila)\S*)\s+\w/) {
push @perlpods, "$1.pod";
}
}
}
close($perlpod);
die "$^PROGRAM_NAME: could not find the pod listing of perl.pod\n"
unless (nelems @perlpods);
%perlpods{[@perlpods]} = @perlpods;
foreach my $i (sort keys %disk_pods) {
warn "$^PROGRAM_NAME: $i exists but is unknown by buildtoc\n"
unless %our_pods{?$i};
warn "$^PROGRAM_NAME: $i exists but is unknown by ../MANIFEST\n"
if !%manipods{?$i} && !%manireadmes{?$i} && !%Copies{?$i};
warn "$^PROGRAM_NAME: $i exists but is unknown by perl.pod\n"
if !%perlpods{?$i} && !exists %sources{$i};
}
foreach my $i (sort keys %our_pods) {
warn "$^PROGRAM_NAME: $i is known by buildtoc but does not exist\n"
unless %disk_pods{?$i};
}
foreach my $i (sort keys %manipods) {
warn "$^PROGRAM_NAME: $i is known by ../MANIFEST but does not exist\n"
unless %disk_pods{$i};
}
foreach my $i (sort keys %perlpods) {
warn "$^PROGRAM_NAME: $i is known by perl.pod but does not exist\n"
unless %disk_pods{?$i};
}
};
# Find all the mdoules
do {
my @modpods;
find \&getpods => < qw(../lib ../ext);
sub getpods {
if (m/\.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!/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 "$^PROGRAM_NAME: tut $File::Find::name" if $file =~ m/TUT/;
unless (open (my $f, "<", "$_\0")) {
warn "$^PROGRAM_NAME: bogus <$file>: $^OS_ERROR";
system "ls", "-l", $file;
}
else {
my $line;
while ($line = ~< *$f) {
if ($line =~ m/^=head1\s+NAME\b/) {
push @modpods, $file;
#warn "GOOD $file\n";
return;
}
}
warn "$^PROGRAM_NAME: $file: cannot find =head1 NAME\n";
}
}
}
die "$^PROGRAM_NAME: no pods" unless (nelems @modpods);
my %done;
for ( @modpods) {
#($name) = /(\w+)\.p(m|od)$/;
my $name = path2modname($_);
if ($name =~ m/^[a-z]/) {
%Pragmata{+$name} = $_;
} else {
if (%done{+$name}++) {
# warn "already did $_\n";
next;
}
%Modules{+$name} = $_;
}
}
};
# OK. Now a lot of ancillary 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 $_;
}
my $out;
sub output_kurilatoc {
open($out, ">", "kurilatoc.pod") || die "$^PROGRAM_NAME: creating kurilatoc.pod failed: $^OS_ERROR";
local $^INPUT_RECORD_SEPARATOR = '';
($_= <<"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
kurilatoc - kurila documentation table of contents
=head1 DESCRIPTION
This page provides a brief table of contents for the rest of the Perl Kurila
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 $_ && (nelems @$_) == 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 kurilatoc.pod
my ($inhead1, $inhead2, $initem);
sub podset {
local @ARGV = @_;
my $pod;
while( ~< *ARGV) {
s/\015//g;
if (s/^=head1 (NAME)\s*/=head2 /) {
$pod = path2modname($ARGV);
unhead1();
output("\n \n\n=head2 ");
$_ = ~< *ARGV;
# Remove svn keyword expansions from the Perl FAQ
s/ \(\$Revision: \d+ \$\)//g;
if ( m/^\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 m/^[\d.]+$/;
next if $pod eq 'perlmodlib' && m/^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($str) {
for (split m/(\n)/, $str) {
if ($_ eq "\n") {
if ($LINE) {
print $out, wrap('', '', $LINE);
$LINE = '';
}
if (($NEWLINE) +< 2) {
print $out, $_;
$NEWLINE++;
}
}
elsif (m/\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};
next if $flags->{perlpod_omit};
if ((nelems @$_) == 2) {
# Heading
push @output, "=head2 $_->[1]\n";
} elsif ((nelems @$_) == 3) {
# Section
my $start = " " x (4 + $flags->{indent}) . $_->[1];
$maxlength = length $start if length ($start) +> $maxlength;
push @output, \@($start, $_->[2]);
} elsif ((nelems @$_) == 0) {
# blank line
push @output, "\n";
} else {
die "$^PROGRAM_NAME: Illegal length " . scalar nelems @$_;
}
}
# 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{$_})},
grep {!%Copies{"$_.pod"}}, 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 m/\n/, wrap('', '', join " ", map { "[.lib.pods]$_.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.pods]%s.pod : [.%s]%s.pod
@ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
SNIP
sort @( < keys %Pods, < keys %Readmepods);
}
sub generate_nmake_1 { map {sprintf "\tcopy ..\\README.\%-8s ..\\pod\\perl$_.pod\n", $_},
sort keys %Readmes, map {"\tcopy ..\\pod\\%Copies{$_} ..\\pod\\$_\n"}, sort keys %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 %Copies,
< 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/.*kurilatoc.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 "$^PROGRAM_NAME: $name contains NUL bytes" if $makefile =~ m/\0/;
$makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
my $sections = @: $makefile =~ m/\0+/g;
die "$^PROGRAM_NAME: $name contains no README copies" if $sections +< 1;
die "$^PROGRAM_NAME: $name contains discontiguous README copies" if $sections +> 1;
# Now remove the other copies that follow
1 while $makefile =~ s/\0\tcopy .*\n/\0/gm;
$makefile =~ s/\0+/$(join ("", &generate_nmake_1( < @_ )))/s;
$makefile =~ s{(del /f [^\n]+checkpods[^\n]+).*?(pod2html)}
{$("$1\n" . &generate_nmake_2( < @_ )."\n\t $2")}s;
$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( < @_ ))}mx) {
die "$^PROGRAM_NAME: Failed to insert amendments in do_perlpod";
}
$pod;
}
sub do_podmak {
my $name = shift;
my $body = join '', @_;
foreach my $variable (qw(pod man html tex)) {
die "$^PROGRAM_NAME: could not find $variable in $name"
unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*}
{$("\n" . generate_pod_mak ($variable))}s;
}
$body;
}
sub do_vms {
my $name = shift;
my $makefile = join '', @_;
die "$^PROGRAM_NAME: $name contains NUL bytes" if $makefile =~ m/\0/;
$makefile =~ s/\npod\d* =[^\n]*/\0/gs;
my $sections = @: $makefile =~ m/\0+/g;
die "$^PROGRAM_NAME: $name contains no pod assignments" if $sections +< 1;
die "$^PROGRAM_NAME: $name contains $sections discontigous pod assignments"
if $sections +> 1;
$makefile =~ s/\0+/$(join "\n", @( '', < &generate_descrip_mms_1( < @_ )))/s;
die "$^PROGRAM_NAME: $name contains NUL bytes" if $makefile =~ m/\0/;
# Looking for rules like this
# [.lib.pods]perl.pod : [.pod]perl.pod
# @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
# Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
$makefile =~ s/\n\Q[.lib.pods]\Eperl[^\n\.]*\.pod[^\n]+\n
[^\n]+\n # Another line
[^\n]+\Q[.lib.pods]\E\n # ends [.lib.pods]
/\0/gsx;
$sections = @: $makefile =~ m/\0+/g;
die "$^PROGRAM_NAME: $name contains no copy rules" if $sections +< 1;
die "$^PROGRAM_NAME: $name contains $sections discontigous copy rules"
if $sections +> 1;
$makefile =~ s/\0+/$(join "\n", @( '', < &generate_descrip_mms_2( < @_ )))/s;
$makefile;
}
sub do_unix {
my $name = shift;
my $makefile_SH = join '', @_;
die "$^PROGRAM_NAME: $name contains NUL bytes" if $makefile_SH =~ m/\0/;
$makefile_SH =~ s/\n\s+-\@test -f \S+ && cd pod && \$\(LNS\) \S+ \S+ && cd \.\. && echo "\S+" >> extra.pods \# See buildtoc\n/\0/gm;
my $sections = @: $makefile_SH =~ m/\0+/g;
die "$^PROGRAM_NAME: $name contains no copy rules" if $sections +< 1;
die "$^PROGRAM_NAME: $name contains $sections discontigous copy rules"
if $sections +> 1;
my @copy_rules = map "\t-\@test -f pod/%Copies{$_} && cd pod && \$(LNS) %Copies{$_} $_ && cd .. && echo \"pod/$_\" >> extra.pods # See buildtoc",
keys %Copies;
$makefile_SH =~ s/\0+/$(join "\n", @( '', < @copy_rules, ''))/s;
$makefile_SH;
}
# Do stuff
my $built;
while (my @(?$target, ?$name) = @: each %Targets) {
next unless %Build{$target};
$built++;
if ($target eq "toc") {
print\*STDOUT, "Now processing $name\n" if $Verbose;
&output_kurilatoc( < @_ );
print \*STDOUT, "Finished\n" if $Verbose;
next;
}
print\*STDOUT, "Now processing $name\n" if $Verbose;
open my $thing, "<", $name or die "Can't open $name: $^OS_ERROR";
my @orig = @( ~< *$thing );
my $orig = join '', @orig;
close $thing;
my @new = &{"do_$target"}($target, < @orig);
my $new = join '', @new;
if ($new eq $orig) {
print \*STDOUT, "Was not modified\n" if $Verbose;
next;
}
rename $name, "$name.old" or die "$^PROGRAM_NAME: Can't rename $name to $name.old: $^OS_ERROR";
open $thing, ">", "$name" or die "$^PROGRAM_NAME: Can't open $name for writing: $^OS_ERROR";
print $thing, $new or die "$^PROGRAM_NAME: print to $name failed: $^OS_ERROR";
close $thing or die die "$^PROGRAM_NAME: close $name failed: $^OS_ERROR";
}
warn "$^PROGRAM_NAME: was not instructed to build anything\n" unless $built;