This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In pod_lib.pl's get_pod_metadata(), generate lookup hashes directly.
[perl5.git] / pod / buildtoc
CommitLineData
41630250
JH
1#!/usr/bin/perl -w
2
3use strict;
57df8412 4use vars qw(%Build %Targets %Pragmata %Modules $Verbose $Quiet $Test);
41630250
JH
5use File::Spec;
6use File::Find;
7use FindBin;
8use Text::Tabs;
9use Text::Wrap;
10use Getopt::Long;
6d664f07 11use Carp;
41630250
JH
12
13no locale;
bac61051 14require 5.010;
41630250 15
ccbc7283
NC
16# Assumption is that we're either already being run from the top level (*nix,
17# VMS), or have absolute paths in @INC (Win32, pod/Makefile)
d7816c47 18BEGIN {
d5e2eea9 19 my $Top = File::Spec->catdir($FindBin::Bin, File::Spec->updir);
ccbc7283 20 chdir $Top or die "Can't chdir to $Top: $!";
d7816c47 21 require 'Porting/pod_lib.pl';
ad77fdb4 22}
41630250
JH
23
24# Generate any/all of these files
25# --verbose gives slightly more output
d092c3cd 26# --quiet suppresses routine warnings
41630250
JH
27# --build-all tries to build everything
28# --build-foo updates foo as follows
29# --showfiles shows the files to be changed
5733ee18
NC
30# --test exit if perl.pod, pod.lst, MANIFEST are consistent, and regenerated
31# files are up to date, die otherwise.
41630250
JH
32
33%Targets
34 = (
d5e2eea9
NC
35 toc => 'pod/perltoc.pod',
36 manifest => 'MANIFEST',
37 perlpod => 'pod/perl.pod',
38 vms => 'vms/descrip_mms.template',
39 nmake => 'win32/Makefile',
40 dmake => 'win32/makefile.mk',
41 podmak => 'win32/pod.mak',
42 # plan9 => 'plan9/mkfile'),
43 unix => 'Makefile.SH',
8537f021 44 # TODO: add roffitall
41630250
JH
45 );
46
d0f3b1ad
DM
47# process command-line switches
48
41630250
JH
49{
50 my @files = keys %Targets;
51 my $filesopts = join(" | ", map { "--build-$_" } "all", sort @files);
52 my $showfiles;
9dce16cd 53 my %build_these;
41630250
JH
54 die <<__USAGE__
55$0: Usage: $0 [--verbose] [--showfiles] $filesopts
56__USAGE__
57 unless @ARGV
58 && GetOptions (verbose => \$Verbose,
d092c3cd 59 quiet => \$Quiet,
41630250 60 showfiles => \$showfiles,
d89d11bb 61 test => \$Test,
9dce16cd
NC
62 map {+"build-$_", \$build_these{$_}} @files, 'all');
63 if ($build_these{all}) {
64 %Build = %Targets;
65 } else {
66 while (my ($file, $want) = each %build_these) {
67 $Build{$file} = $Targets{$file} if $want;
68 }
69 }
41630250 70 if ($showfiles) {
cb9cdbd1 71 print join(" ", sort { lc $a cmp lc $b } values %Build), "\n";
41630250
JH
72 exit(0);
73 }
74}
75
41630250 76if ($Verbose) {
d0f3b1ad 77 print "I will be building $_\n" foreach keys %Build;
41630250
JH
78}
79
57df8412
NC
80my $state = get_pod_metadata(values %Build);
81
82if ($Test) {
5733ee18
NC
83 delete $Build{toc};
84 printf "1..%d\n", 1 + scalar keys %Build;
57df8412
NC
85 if (@{$state->{inconsistent}}) {
86 print "not ok 1\n";
87 die @{$state->{inconsistent}};
d89d11bb
TC
88 }
89 print "ok 1\n";
41630250 90}
57df8412
NC
91else {
92 warn @{$state->{inconsistent}} if @{$state->{inconsistent}};
93}
94
41630250 95
0b01631d 96# Find all the modules
15e75242 97if ($Build{toc}) {
41630250 98 my @modpods;
f37610d8 99 find \&getpods => 'lib';
41630250
JH
100
101 sub getpods {
102 if (/\.p(od|m)$/) {
103 my $file = $File::Find::name;
d5e2eea9 104 return if $file =~ qr!/lib/Pod/Functions.pm\z!; # Used only by pod itself
41630250
JH
105 return if $file =~ m!(?:^|/)t/!;
106 return if $file =~ m!lib/Attribute/Handlers/demo/!;
107 return if $file =~ m!lib/Net/FTP/.+\.pm!; # Hi, Graham! :-)
108 return if $file =~ m!lib/Math/BigInt/t/!;
109 return if $file =~ m!/Devel/PPPort/[Hh]arness|lib/Devel/Harness!i;
110 return if $file =~ m!XS/(?:APItest|Typemap)!;
be6d6286
HS
111 my $pod = $file;
112 return if $pod =~ s/pm$/pod/ && -e $pod;
bac61051 113 unless (open my $f, '<', $_) {
41630250
JH
114 warn "$0: bogus <$file>: $!";
115 system "ls", "-l", $file;
116 }
117 else {
118 my $line;
bac61051 119 while ($line = <$f>) {
41630250
JH
120 if ($line =~ /^=head1\s+NAME\b/) {
121 push @modpods, $file;
41630250
JH
122 return;
123 }
124 }
3533364a 125 warn "$0: NOTE: cannot find '=head1 NAME' in:\n $file\n" unless $Quiet;
41630250
JH
126 }
127 }
128 }
129
ce9f0d31 130 my_die "Can't find any pods!\n" unless @modpods;
41630250
JH
131
132 my %done;
133 for (@modpods) {
11eb54fe
NC
134 my $name = $_;
135 $name =~ s/\.p(m|od)$//;
136 $name =~ s-.*?/lib/--;
137 $name =~ s-/-::-g;
3eb77e4b
NC
138 next if $done{$name}++;
139
41630250
JH
140 if ($name =~ /^[a-z]/) {
141 $Pragmata{$name} = $_;
142 } else {
41630250
JH
143 $Modules{$name} = $_;
144 }
145 }
146}
147
8537f021 148# OK. Now a lot of ancillary function definitions follow
41630250
JH
149# Main program returns at "Do stuff"
150
d871876a
NC
151my $OUT;
152
02cc404a 153sub do_toc {
d5e2eea9 154 my $filename = shift;
41630250 155
c0f8aaaa 156 ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;
41630250 157
97f32038
JH
158 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
159 # This file is autogenerated by buildtoc from all the other pods.
160 # Edit those files and run buildtoc --build-toc to effect changes.
97f32038 161
41630250
JH
162 =head1 NAME
163
164 perltoc - perl documentation table of contents
165
166 =head1 DESCRIPTION
167
168 This page provides a brief table of contents for the rest of the Perl
169 documentation set. It is meant to be scanned quickly or grepped
170 through to locate the proper section you're looking for.
171
172 =head1 BASIC DOCUMENTATION
173
174EOPOD2B
175#' make emacs happy
176
177 # All the things in the master list that happen to be pod filenames
57df8412 178 foreach (grep {defined $_ && @$_ == 3 && !$_->[0]{toc_omit}} @{$state->{master}}) {
f37610d8 179 podset(@$_);
84f07fb2 180 }
41630250
JH
181
182
c0f8aaaa 183 ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;
41630250
JH
184
185
186
187 =head1 PRAGMA DOCUMENTATION
188
189EOPOD2B
190
84f07fb2
NC
191 foreach (sort keys %Pragmata) {
192 podset($_, $Pragmata{$_});
193 }
41630250 194
c0f8aaaa 195 ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;
41630250
JH
196
197
198
199 =head1 MODULE DOCUMENTATION
200
201EOPOD2B
202
84f07fb2
NC
203 foreach (sort keys %Modules) {
204 podset($_, $Modules{$_});
205 }
41630250
JH
206
207 $_= <<"EOPOD2B";
208
209
210 =head1 AUXILIARY DOCUMENTATION
211
212 Here should be listed all the extra programs' documentation, but they
213 don't all have manual pages yet:
214
215 =over 4
216
217EOPOD2B
218
57df8412 219 $_ .= join "\n", map {"\t=item $_\n"} sort keys %{$state->{aux}};
41630250
JH
220 $_ .= <<"EOPOD2B" ;
221
222 =back
223
224 =head1 AUTHOR
225
226 Larry Wall <F<larry\@wall.org>>, with the help of oodles
227 of other folks.
228
229
230EOPOD2B
231
232 s/^\t//gm;
c0f8aaaa 233 $OUT .= "$_\n";
d871876a 234
39440e4b 235 $OUT =~ s/\n\s+\n/\n\n/gs;
f20404e1 236 $OUT =~ s/\n{3,}/\n\n/g;
b8ce93b8
NC
237
238 $OUT =~ s/([^\n]+)/wrap('', '', $1)/ge;
239
02cc404a 240 return $OUT;
41630250
JH
241}
242
243# Below are all the auxiliary routines for generating perltoc.pod
244
245my ($inhead1, $inhead2, $initem);
246
247sub podset {
84f07fb2 248 my ($pod, $file) = @_;
41630250 249
536d7404
NC
250 local $/ = '';
251
ce9f0d31 252 open my $fh, '<', $file or my_die "Can't open file '$file' for $pod: $!";
0b01631d 253
84f07fb2 254 while(<$fh>) {
16114dde 255 tr/\015//d;
41630250 256 if (s/^=head1 (NAME)\s*/=head2 /) {
41630250 257 unhead1();
c0f8aaaa 258 $OUT .= "\n\n=head2 ";
84f07fb2 259 $_ = <$fh>;
767650bc
NC
260 # Remove svn keyword expansions from the Perl FAQ
261 s/ \(\$Revision: \d+ \$\)//g;
32ebae07 262 if ( /^\s*\Q$pod\E\b/ ) {
41630250 263 s/$pod\.pm/$pod/; # '.pm' in NAME !?
41630250
JH
264 } else {
265 s/^/$pod, /;
41630250 266 }
41630250 267 }
1fa7865d 268 elsif (s/^=head1 (.*)/=item $1/) {
41630250 269 unhead2();
c0f8aaaa 270 $OUT .= "=over 4\n\n" unless $inhead1;
41630250 271 $inhead1 = 1;
1fa7865d 272 $_ .= "\n";
41630250 273 }
1fa7865d 274 elsif (s/^=head2 (.*)/=item $1/) {
41630250 275 unitem();
c0f8aaaa 276 $OUT .= "=over 4\n\n" unless $inhead2;
41630250 277 $inhead2 = 1;
1fa7865d 278 $_ .= "\n";
41630250 279 }
1fa7865d 280 elsif (s/^=item ([^=].*)/$1/) {
41630250
JH
281 next if $pod eq 'perldiag';
282 s/^\s*\*\s*$// && next;
283 s/^\s*\*\s*//;
284 s/\n/ /g;
285 s/\s+$//;
286 next if /^[\d.]+$/;
287 next if $pod eq 'perlmodlib' && /^ftp:/;
c0f8aaaa 288 $OUT .= ", " if $initem;
41630250
JH
289 $initem = 1;
290 s/\.$//;
291 s/^-X\b/-I<X>/;
41630250 292 }
1fa7865d
NC
293 else {
294 unhead1() if /^=cut\s*\n/;
41630250
JH
295 next;
296 }
1fa7865d 297 $OUT .= $_;
41630250
JH
298 }
299}
300
301sub unhead1 {
302 unhead2();
303 if ($inhead1) {
c0f8aaaa 304 $OUT .= "\n\n=back\n\n";
41630250
JH
305 }
306 $inhead1 = 0;
307}
308
309sub unhead2 {
310 unitem();
311 if ($inhead2) {
c0f8aaaa 312 $OUT .= "\n\n=back\n\n";
41630250
JH
313 }
314 $inhead2 = 0;
315}
316
317sub unitem {
318 if ($initem) {
c0f8aaaa 319 $OUT .= "\n\n";
41630250
JH
320 }
321 $initem = 0;
322}
323
41630250
JH
324# End of original buildtoc. From here on are routines to generate new sections
325# for and inplace edit other files
326
327sub generate_perlpod {
328 my @output;
329 my $maxlength = 0;
57df8412 330 foreach (@{$state->{master}}) {
41630250
JH
331 my $flags = $_->[0];
332 next if $flags->{aux};
b0b6bf2b 333 next if $flags->{perlpod_omit};
41630250
JH
334
335 if (@$_ == 2) {
336 # Heading
337 push @output, "=head2 $_->[1]\n";
1721346e 338 } elsif (@$_ == 5) {
41630250 339 # Section
1721346e 340 my $start = " " x (4 + $flags->{indent}) . $_->[4];
41630250 341 $maxlength = length $start if length ($start) > $maxlength;
1721346e 342 push @output, [$start, $_->[3]];
41630250
JH
343 } elsif (@$_ == 0) {
344 # blank line
345 push @output, "\n";
346 } else {
ce9f0d31 347 my_die "Illegal length " . scalar @$_;
41630250
JH
348 }
349 }
350 # want at least 2 spaces padding
351 $maxlength += 2;
352 $maxlength = ($maxlength + 3) & ~3;
353 # sprintf gives $1.....$2 where ... are spaces:
354 return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
355 @output);
356}
357
358
359sub generate_manifest {
c69ca1d4 360 # Annoyingly, unexpand doesn't consider it good form to replace a single
41630250
JH
361 # space before a tab with a tab
362 # Annoyingly (2) it returns read only values.
453d7764 363 my @temp = unexpand (map {sprintf "%-32s%s", @$_} @_);
41630250
JH
364 map {s/ \t/\t\t/g; $_} @temp;
365}
366sub generate_manifest_pod {
57df8412 367 generate_manifest map {["pod/$_.pod", $state->{pods}{$_}]}
1721346e 368 sort grep {
57df8412
NC
369 !$state->{copies}{"$_.pod"} && !$state->{generated}{"$_.pod"} && !-e "$_.pod"
370 } keys %{$state->{pods}};
41630250
JH
371}
372sub generate_manifest_readme {
dd0cfdaa
NC
373 generate_manifest sort {$a->[0] cmp $b->[0]}
374 ["README.vms", "Notes about installing the VMS port"],
57df8412 375 map {["README.$_", $state->{readmes}{$_}]} keys %{$state->{readmes}};
41630250
JH
376}
377
378sub generate_roffitall {
57df8412 379 (map ({"\t\$maindir/$_.1\t\\"}sort keys %{$state->{pods}}),
41630250 380 "\t\t\\",
57df8412 381 map ({"\t\$maindir/$_.1\t\\"}sort keys %{$state->{aux}}),
41630250
JH
382 "\t\t\\",
383 map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata),
384 "\t\t\\",
385 map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules),
386 )
387}
388
41630250 389sub generate_nmake_1 {
b0b6bf2b
AT
390 # XXX Fix this with File::Spec
391 (map {sprintf "\tcopy ..\\README.%-8s ..\\pod\\perl$_.pod\n", $_}
57df8412
NC
392 sort keys %{$state->{readmes}}),
393 (map {"\tcopy ..\\pod\\$state->{copies}{$_} ..\\pod\\$_\n"} sort keys %{$state->{copies}});
41630250
JH
394}
395
396# This doesn't have a trailing newline
397sub generate_nmake_2 {
398 # Spot the special case
399 local $Text::Wrap::columns = 76;
400 my $line = wrap ("\t ", "\t ",
57df8412
NC
401 join " ", sort keys %{$state->{copies}}, keys %{$state->{generated}},
402 map {"perl$_.pod"} keys %{$state->{readmes}});
41630250 403 $line =~ s/$/ \\/mg;
b14c7f9a 404 $line =~ s/ \\$//;
41630250
JH
405 $line;
406}
407
408sub generate_pod_mak {
409 my $variable = shift;
410 my @lines;
68a9cf1a 411 my $line = "\U$variable = " . join "\t\\\n\t",
57df8412 412 map {"$_.$variable"} sort grep { $_ !~ m{/} } keys %{$state->{pods}};
41630250
JH
413 # Special case
414 $line =~ s/.*perltoc.html.*\n//m;
415 $line;
416}
417
6d664f07
NC
418sub verify_contiguous {
419 my ($name, $content, $what) = @_;
420 my $sections = () = $content =~ m/\0+/g;
421 croak("$0: $name contains no $what") if $sections < 1;
422 croak("$0: $name contains discontiguous $what") if $sections > 1;
423}
424
41630250 425sub do_manifest {
131a60d2 426 my ($name, $prev) = @_;
41630250 427 my @manifest =
453d7764 428 grep {! m!^pod/[^.]+\.pod.*!}
57df8412 429 grep {! m!^README\.(\S+)! || $state->{ignore}{$1}} split "\n", $prev;
453d7764
NC
430 join "\n", (
431 # Dictionary order - fold and handle non-word chars as nothing
432 map { $_->[0] }
433 sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] }
434 map { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] }
435 @manifest,
436 &generate_manifest_pod(),
437 &generate_manifest_readme()), '';
41630250
JH
438}
439
440sub do_nmake {
131a60d2 441 my ($name, $makefile) = @_;
41630250 442 $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
6d664f07 443 verify_contiguous($name, $makefile, 'README copies');
b0b6bf2b
AT
444 # Now remove the other copies that follow
445 1 while $makefile =~ s/\0\tcopy .*\n/\0/gm;
446 $makefile =~ s/\0+/join ("", &generate_nmake_1)/se;
41630250 447
b14c7f9a
SH
448 $makefile =~ s{(-cd \$\(PODDIR\) && del /f[^\n]+).*?(-cd \.\.\\utils && del /f)}
449 {"$1\n" . &generate_nmake_2."\n\t$2"}se;
41630250
JH
450 $makefile;
451}
452
453# shut up used only once warning
454*do_dmake = *do_dmake = \&do_nmake;
455
456sub do_perlpod {
131a60d2 457 my ($name, $pod) = @_;
41630250
JH
458
459 unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
460 (?:\s+[a-z]{4,}.*\n # fooo
461 |=head.*\n # =head foo
462 |\s*\n # blank line
463 )+
464 }
465 {$1 . join "", &generate_perlpod}mxe) {
ce9f0d31 466 my_die "Failed to insert amendments in do_perlpod";
41630250
JH
467 }
468 $pod;
469}
470
471sub do_podmak {
131a60d2 472 my ($name, $body) = @_;
d525b9bc 473 foreach my $variable (qw(pod man html tex)) {
ce9f0d31 474 my_die "could not find $variable in $name"
41630250
JH
475 unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*}
476 {"\n" . generate_pod_mak ($variable)}se;
477 }
478 $body;
479}
480
481sub do_vms {
131a60d2 482 my ($name, $makefile) = @_;
41630250 483
600dcb9e
CB
484# Looking for the macro defining the current perldelta:
485#PERLDELTA_CURRENT = [.pod]perl5139delta.pod
486
487 $makefile =~ s/\nPERLDELTA_CURRENT\s+=\s+\Q[.pod]perl\E\d+delta\.pod\n
488 /\0/sx;
489 verify_contiguous($name, $makefile, 'current perldelta macro');
57df8412 490 $makefile =~ s/\0+/join "\n", '', "PERLDELTA_CURRENT = [.pod]$state->{delta_target}", ''/se;
600dcb9e 491
41630250
JH
492 $makefile;
493}
494
0dfdcd8a 495sub do_unix {
131a60d2 496 my ($name, $makefile_SH) = @_;
0dfdcd8a 497
7eb47696
NC
498 $makefile_SH =~ s{^(perltoc_pod_prereqs = extra.pods).*}
499 {join ' ', $1, map "pod/$_",
57df8412 500 sort keys %{$state->{copies}}, grep {!/perltoc/} keys %{$state->{generated}}
7eb47696 501 }mge;
8e7bc40f 502
37ee6528
FR
503# pod/perl511delta.pod: pod/perldelta.pod
504# cd pod && $(LNS) perldelta.pod perl511delta.pod
8e7bc40f
NC
505
506 $makefile_SH =~ s!(
507pod/perl[a-z0-9_]+\.pod: pod/perl[a-z0-9_]+\.pod
e0be038f 508 \$\(LNS\) perl[a-z0-9_]+\.pod pod/perl[a-z0-9_]+\.pod
8e7bc40f 509)+!\0!gm;
0dfdcd8a 510
6d664f07 511 verify_contiguous($name, $makefile_SH, 'copy rules');
0dfdcd8a 512
8e7bc40f 513 my @copy_rules = map "
57df8412
NC
514pod/$_: pod/$state->{copies}{$_}
515 \$(LNS) $state->{copies}{$_} pod/$_
516", keys %{$state->{copies}};
0dfdcd8a 517
8e7bc40f 518 $makefile_SH =~ s/\0+/join '', @copy_rules/se;
0dfdcd8a
NC
519 $makefile_SH;
520
521}
522
41630250
JH
523# Do stuff
524
525my $built;
526while (my ($target, $name) = each %Targets) {
e94c1c05 527 print "Working on target $target\n" if $Verbose;
41630250
JH
528 next unless $Build{$target};
529 $built++;
02cc404a 530 my ($orig, $mode);
41630250 531 print "Now processing $name\n" if $Verbose;
02cc404a
NC
532 if ($target ne "toc") {
533 local $/;
ad77fdb4 534 my $thing = open_or_die($name);
bac61051
NC
535 binmode $thing;
536 $orig = <$thing>;
ce9f0d31 537 my_die "$name contains NUL bytes" if $orig =~ /\0/;
02cc404a
NC
538 }
539
131a60d2 540 my $new = do {
41630250 541 no strict 'refs';
131a60d2 542 &{"do_$target"}($target, $orig);
41630250 543 };
02cc404a
NC
544
545 if (defined $orig) {
546 if ($new eq $orig) {
5733ee18
NC
547 if ($Test) {
548 printf "ok %d # $name is up to date\n", $built + 1;
549 } elsif ($Verbose) {
550 print "Was not modified\n";
551 }
552 next;
553 } elsif ($Test) {
554 printf "not ok %d # $name is up to date\n", $built + 1;
02cc404a
NC
555 next;
556 }
ce9f0d31
DM
557 $mode = (stat $name)[2] // my_die "Can't stat $name: $!";
558 rename $name, "$name.old" or my_die "Can't rename $name to $name.old: $!";
41630250 559 }
02cc404a 560
ce9f0d31 561 open my $thing, '>', $name or my_die "Can't open $name for writing: $!";
bac61051 562 binmode $thing;
ce9f0d31
DM
563 print $thing $new or my_die "print to $name failed: $!";
564 close $thing or my_die "close $name failed: $!";
02cc404a 565 if (defined $mode) {
ce9f0d31 566 chmod $mode & 0777, $name or my_die "can't chmod $mode $name: $!";
02cc404a 567 }
41630250
JH
568}
569
5733ee18 570warn "$0: was not instructed to build anything\n" unless $built || $Test;