This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Cwd 2.14.
[perl5.git] / pod / buildtoc
CommitLineData
41630250
JH
1#!/usr/bin/perl -w
2
3use strict;
4use vars qw($masterpodfile %Build %Targets $Verbose $Up %Ignore
5 @Master %Readmes %Pods %Aux %Readmepods %Pragmata %Modules);
6use File::Spec;
7use File::Find;
8use FindBin;
9use Text::Tabs;
10use Text::Wrap;
11use Getopt::Long;
12
13no 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
75if ($Verbose) {
76 print "I'm building $_\n" foreach grep {$Build{$_}} keys %Build;
77}
78
79chdir $FindBin::Bin or die "$0: Can't chdir $FindBin::Bin: $!";
80
81open MASTER, $masterpodfile or die "$0: Can't open $masterpodfile: $!";
82
83foreach (<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
JH
88 # it's a heading
89 my $flags = $1;
8927c9d8 90 $flags =~ tr/h//d;
41630250 91 my %flags = (header => 1);
8927c9d8
NC
92 $flags{toc_omit} = 1 if $flags =~ tr/o//d;
93 $flags{aux} = 1 if $flags =~ tr/a//d;
41630250
JH
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
124close 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
HS
206 my $pod = $file;
207 return if $pod =~ s/pm$/pod/ && -e $pod;
41630250
JH
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
248sub 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
257sub output ($);
258
259sub output_perltoc {
260 open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!";
261
671313d0 262 local $/ = '';
41630250
JH
263
264 ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
265
97f32038
JH
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
JH
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
282EOPOD2B
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
295EOPOD2B
296
297 podset(sort values %Pragmata);
298
299 ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
300
301
302
303 =head1 MODULE DOCUMENTATION
304
305EOPOD2B
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
319EOPOD2B
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
332EOPOD2B
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
341my ($inhead1, $inhead2, $initem);
342
343sub podset {
344 local @ARGV = @_;
345 my $pod;
346
347 while(<>) {
16114dde 348 tr/\015//d;
41630250
JH
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
397sub unhead1 {
398 unhead2();
399 if ($inhead1) {
400 output "\n\n=back\n\n";
401 }
402 $inhead1 = 0;
403}
404
405sub unhead2 {
406 unitem();
407 if ($inhead2) {
408 output "\n\n=back\n\n";
409 }
410 $inhead2 = 0;
411}
412
413sub unitem {
414 if ($initem) {
415 output "\n\n";
416 ##print "\n\n=back\n\n";
417 }
418 $initem = 0;
419}
420
421sub nl {
422 output "\n";
423}
424
425my $NEWLINE = 0; # how many newlines have we seen recently
426my $LINE; # what remains to be printed
427
428sub 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
450sub 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
481sub 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}
488sub generate_manifest_pod {
489 generate_manifest map {["pod/$_.pod", $Pods{$_}]} sort keys %Pods;
490}
491sub generate_manifest_readme {
492 generate_manifest map {["README.$_", $Readmes{$_}]} sort keys %Readmes;
493}
494
495sub 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
506sub 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
515sub generate_descrip_mms_2 {
ab1db26f
JH
516 map {sprintf <<'SNIP', $_, $_ eq 'perlvms' ? 'vms' : 'pod', $_}
517[.lib.pod]%s.pod : [.%s]%s.pod
41630250
JH
518 @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
519 Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod]
520SNIP
521 sort keys %Pods, keys %Readmepods;
522}
523
524sub 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
530sub 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
539sub 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
549sub 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
JH
558 @manifest,
559 &generate_manifest_pod(),
560 &generate_manifest_readme();
561}
562
563sub 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
581sub 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
597sub do_podmak {
598 my $name = shift;
599 my $body = join '', @_;
d525b9bc 600 foreach my $variable (qw(pod man html tex)) {
41630250
JH
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
608sub 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
640my $built;
641while (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
JH
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
670warn "$0: was not instructed to build anything\n" unless $built;