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