This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Note changes to perlvar in perldelta
[perl5.git] / pod / buildtoc
CommitLineData
41630250
JH
1#!/usr/bin/perl -w
2
3use strict;
d092c3cd 4use vars qw($masterpodfile %Build %Targets $Verbose $Quiet $Up %Ignore
b0b6bf2b 5 @Master %Readmes %Pods %Aux %Readmepods %Pragmata %Modules
344af494 6 %Copies %Generated);
41630250
JH
7use File::Spec;
8use File::Find;
9use FindBin;
10use Text::Tabs;
11use Text::Wrap;
12use Getopt::Long;
6d664f07 13use Carp;
41630250
JH
14
15no locale;
16
17$Up = File::Spec->updir;
0b01631d 18$masterpodfile = File::Spec->catfile($Up, "pod.lst");
41630250
JH
19
20# Generate any/all of these files
21# --verbose gives slightly more output
d092c3cd 22# --quiet suppresses routine warnings
41630250
JH
23# --build-all tries to build everything
24# --build-foo updates foo as follows
25# --showfiles shows the files to be changed
26
27%Targets
28 = (
29 toc => "perltoc.pod",
30 manifest => File::Spec->catdir($Up, "MANIFEST"),
31 perlpod => "perl.pod",
0b01631d
CB
32 vms => File::Spec->catfile($Up, "vms", "descrip_mms.template"),
33 nmake => File::Spec->catfile($Up, "win32", "Makefile"),
34 dmake => File::Spec->catfile($Up, "win32", "makefile.mk"),
35 podmak => File::Spec->catfile($Up, "win32", "pod.mak"),
41630250 36 # plan9 => File::Spec->catdir($Up, "plan9", "mkfile"),
0b01631d 37 unix => File::Spec->catfile($Up, "Makefile.SH"),
8537f021 38 # TODO: add roffitall
41630250
JH
39 );
40
41{
42 my @files = keys %Targets;
43 my $filesopts = join(" | ", map { "--build-$_" } "all", sort @files);
44 my $showfiles;
45 die <<__USAGE__
46$0: Usage: $0 [--verbose] [--showfiles] $filesopts
47__USAGE__
48 unless @ARGV
49 && GetOptions (verbose => \$Verbose,
d092c3cd 50 quiet => \$Quiet,
41630250
JH
51 showfiles => \$showfiles,
52 map {+"build-$_", \$Build{$_}} @files, 'all');
53 # Set them all to true
54 @Build{@files} = @files if ($Build{all});
55 if ($showfiles) {
56 print
57 join(" ",
58 sort { lc $a cmp lc $b }
59 map {
60 my ($v, $d, $f) = File::Spec->splitpath($_);
61 my @d;
62 @d = defined $d ? File::Spec->splitdir($d) : ();
63 shift @d if @d;
64 File::Spec->catfile(@d ?
65 (@d == 1 && $d[0] eq '' ? () : @d)
66 : "pod", $f);
67 } @Targets{grep { $_ ne 'all' && $Build{$_} } keys %Build}),
68 "\n";
69 exit(0);
70 }
71}
72
73# Don't copy these top level READMEs
74%Ignore
75 = (
41630250
JH
76 micro => 1,
77# vms => 1,
78 );
79
80if ($Verbose) {
81 print "I'm building $_\n" foreach grep {$Build{$_}} keys %Build;
82}
83
84chdir $FindBin::Bin or die "$0: Can't chdir $FindBin::Bin: $!";
85
86open MASTER, $masterpodfile or die "$0: Can't open $masterpodfile: $!";
87
b0b6bf2b
AT
88my ($delta_source, $delta_target);
89
41630250
JH
90foreach (<MASTER>) {
91 next if /^\#/;
92
93 # At least one upper case letter somewhere in the first group
8927c9d8 94 if (/^(\S+)\s(.*)/ && $1 =~ tr/h//) {
41630250
JH
95 # it's a heading
96 my $flags = $1;
8927c9d8 97 $flags =~ tr/h//d;
41630250 98 my %flags = (header => 1);
8927c9d8
NC
99 $flags{toc_omit} = 1 if $flags =~ tr/o//d;
100 $flags{aux} = 1 if $flags =~ tr/a//d;
41630250
JH
101 die "$0: Unknown flag found in heading line: $_" if length $flags;
102 push @Master, [\%flags, $2];
103
104 } elsif (/^(\S*)\s+(\S+)\s+(.*)/) {
105 # it's a section
106 my ($flags, $filename, $desc) = ($1, $2, $3);
107
108 my %flags = (indent => 0);
109 $flags{indent} = $1 if $flags =~ s/(\d+)//;
b0b6bf2b 110 $flags{toc_omit} = 1 if $flags =~ tr/o//d;
41630250 111 $flags{aux} = 1 if $flags =~ tr/a//d;
b0b6bf2b
AT
112
113 if ($flags =~ tr/D//d) {
37ee6528 114 $flags{manifest_omit} = 1;
b0b6bf2b
AT
115 $delta_source = "$filename.pod";
116 }
117 if ($flags =~ tr/d//d) {
37ee6528 118 $flags{perlpod_omit} = 1;
b0b6bf2b
AT
119 $delta_target = "$filename.pod";
120 }
344af494 121 $Generated{"$filename.pod"}++ if $flags =~ tr/g//d;
b0b6bf2b 122
41630250
JH
123 if ($flags =~ tr/r//d) {
124 my $readme = $filename;
125 $readme =~ s/^perl//;
126 $Readmepods{$filename} = $Readmes{$readme} = $desc;
127 $flags{readme} = 1;
128 } elsif ($flags{aux}) {
129 $Aux{$filename} = $desc;
130 } else {
131 $Pods{$filename} = $desc;
132 }
133 die "$0: Unknown flag found in section line: $_" if length $flags;
134 push @Master, [\%flags, $filename, $desc];
135 } elsif (/^$/) {
136 push @Master, undef;
137 } else {
138 die "$0: Malformed line: $_" if $1 =~ tr/A-Z//;
139 }
140}
b0b6bf2b
AT
141if (defined $delta_source) {
142 if (defined $delta_target) {
143 # This way round so that keys can act as a MANIFEST skip list
144 # Targets will aways be in the pod directory. Currently we can only cope
dd0cfdaa 145 # with sources being in the same directory.
b0b6bf2b
AT
146 $Copies{$delta_target} = $delta_source;
147 } else {
148 die "$0: delta source defined but not target";
149 }
150} elsif (defined $delta_target) {
151 die "$0: delta target defined but not target";
152}
41630250
JH
153
154close MASTER;
155
156# Sanity cross check
157{
158 my (%disk_pods, @disk_pods);
159 my (@manipods, %manipods);
160 my (@manireadmes, %manireadmes);
161 my (@perlpods, %perlpods);
162 my (%our_pods);
163
164 # Convert these to a list of filenames.
165 foreach (keys %Pods, keys %Readmepods) {
166 $our_pods{"$_.pod"}++;
167 }
168
169 # None of these filenames will be boolean false
170 @disk_pods = glob("*.pod");
171 @disk_pods{@disk_pods} = @disk_pods;
172
b0b6bf2b
AT
173 # Things we copy from won't be in perl.pod
174 # Things we copy to won't be in MANIFEST
b0b6bf2b 175
41630250
JH
176 open(MANI, "../MANIFEST") || die "$0: opening ../MANIFEST failed: $!";
177 while (<MANI>) {
178 if (m!^pod/([^.]+\.pod)\s+!i) {
179 push @manipods, $1;
180 } elsif (m!^README\.(\S+)\s+!i) {
181 next if $Ignore{$1};
182 push @manireadmes, "perl$1.pod";
183 }
184 }
185 close(MANI);
186 @manipods{@manipods} = @manipods;
187 @manireadmes{@manireadmes} = @manireadmes;
188
189 open(PERLPOD, "perl.pod") || die "$0: opening perl.pod failed: $!\n";
190 while (<PERLPOD>) {
191 if (/^For ease of access, /../^\(If you're intending /) {
192 if (/^\s+(perl\S*)\s+\w/) {
193 push @perlpods, "$1.pod";
194 }
195 }
196 }
197 close(PERLPOD);
198 die "$0: could not find the pod listing of perl.pod\n"
199 unless @perlpods;
200 @perlpods{@perlpods} = @perlpods;
201
202 foreach my $i (sort keys %disk_pods) {
203 warn "$0: $i exists but is unknown by buildtoc\n"
204 unless $our_pods{$i};
205 warn "$0: $i exists but is unknown by ../MANIFEST\n"
344af494 206 if !$manipods{$i} && !$manireadmes{$i} && !$Copies{$i} && !$Generated{$i};
41630250 207 warn "$0: $i exists but is unknown by perl.pod\n"
81e1aac7 208 if !$perlpods{$i} && !exists $Copies{$i};
41630250 209 }
577f3cc6 210 my @BuildTargets = grep {defined} @Targets{grep $_ ne 'all', keys %Build};
78fb583c
RB
211 my %BuildFiles;
212 @BuildFiles{@BuildTargets} = @BuildTargets;
81e1aac7 213
41630250
JH
214 foreach my $i (sort keys %our_pods) {
215 warn "$0: $i is known by buildtoc but does not exist\n"
78fb583c 216 unless $disk_pods{$i} or $BuildFiles{$i};
41630250
JH
217 }
218 foreach my $i (sort keys %manipods) {
219 warn "$0: $i is known by ../MANIFEST but does not exist\n"
220 unless $disk_pods{$i};
344af494
NC
221 warn "$0: $i is known by ../MANIFEST but is marked as generated\n"
222 if $Generated{$i};
41630250
JH
223 }
224 foreach my $i (sort keys %perlpods) {
225 warn "$0: $i is known by perl.pod but does not exist\n"
78fb583c 226 unless $disk_pods{$i} or $BuildFiles{$i};
41630250
JH
227 }
228}
229
0b01631d 230# Find all the modules
41630250
JH
231{
232 my @modpods;
233 find \&getpods => qw(../lib ../ext);
234
235 sub getpods {
236 if (/\.p(od|m)$/) {
237 my $file = $File::Find::name;
238 return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
239 return if $file =~ m!(?:^|/)t/!;
240 return if $file =~ m!lib/Attribute/Handlers/demo/!;
241 return if $file =~ m!lib/Net/FTP/.+\.pm!; # Hi, Graham! :-)
242 return if $file =~ m!lib/Math/BigInt/t/!;
243 return if $file =~ m!/Devel/PPPort/[Hh]arness|lib/Devel/Harness!i;
244 return if $file =~ m!XS/(?:APItest|Typemap)!;
be6d6286
HS
245 my $pod = $file;
246 return if $pod =~ s/pm$/pod/ && -e $pod;
41630250
JH
247 die "$0: tut $File::Find::name" if $file =~ /TUT/;
248 unless (open (F, "< $_\0")) {
249 warn "$0: bogus <$file>: $!";
250 system "ls", "-l", $file;
251 }
252 else {
253 my $line;
254 while ($line = <F>) {
255 if ($line =~ /^=head1\s+NAME\b/) {
256 push @modpods, $file;
257 #warn "GOOD $file\n";
0b01631d 258 close F;
41630250
JH
259 return;
260 }
261 }
0b01631d 262 close F;
d092c3cd 263 warn "$0: $file: cannot find =head1 NAME\n" unless $Quiet;
41630250
JH
264 }
265 }
266 }
267
268 die "$0: no pods" unless @modpods;
269
270 my %done;
271 for (@modpods) {
272 #($name) = /(\w+)\.p(m|od)$/;
273 my $name = path2modname($_);
274 if ($name =~ /^[a-z]/) {
275 $Pragmata{$name} = $_;
276 } else {
277 if ($done{$name}++) {
278 # warn "already did $_\n";
279 next;
280 }
281 $Modules{$name} = $_;
282 }
283 }
284}
285
8537f021 286# OK. Now a lot of ancillary function definitions follow
41630250
JH
287# Main program returns at "Do stuff"
288
289sub path2modname {
290 local $_ = shift;
291 s/\.p(m|od)$//;
292 s-.*?/(lib|ext)/--;
293 s-/-::-g;
294 s/(\w+)::\1/$1/;
295 return $_;
296}
297
298sub output ($);
299
300sub output_perltoc {
301 open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!";
302
671313d0 303 local $/ = '';
41630250
JH
304
305 ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
306
97f32038
JH
307 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
308 # This file is autogenerated by buildtoc from all the other pods.
309 # Edit those files and run buildtoc --build-toc to effect changes.
97f32038 310
41630250
JH
311 =head1 NAME
312
313 perltoc - perl documentation table of contents
314
315 =head1 DESCRIPTION
316
317 This page provides a brief table of contents for the rest of the Perl
318 documentation set. It is meant to be scanned quickly or grepped
319 through to locate the proper section you're looking for.
320
321 =head1 BASIC DOCUMENTATION
322
323EOPOD2B
324#' make emacs happy
325
326 # All the things in the master list that happen to be pod filenames
327 podset(map {"$_->[1].pod"} grep {defined $_ && @$_ == 3 && !$_->[0]{toc_omit}} @Master);
328
329
330 ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
331
332
333
334 =head1 PRAGMA DOCUMENTATION
335
336EOPOD2B
337
338 podset(sort values %Pragmata);
339
340 ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
341
342
343
344 =head1 MODULE DOCUMENTATION
345
346EOPOD2B
347
348 podset( @Modules{ sort keys %Modules } );
349
350 $_= <<"EOPOD2B";
351
352
353 =head1 AUXILIARY DOCUMENTATION
354
355 Here should be listed all the extra programs' documentation, but they
356 don't all have manual pages yet:
357
358 =over 4
359
360EOPOD2B
361
362 $_ .= join "\n", map {"\t=item $_\n"} sort keys %Aux;
363 $_ .= <<"EOPOD2B" ;
364
365 =back
366
367 =head1 AUTHOR
368
369 Larry Wall <F<larry\@wall.org>>, with the help of oodles
370 of other folks.
371
372
373EOPOD2B
374
375 s/^\t//gm;
376 output $_;
377 output "\n"; # flush $LINE
0b01631d 378 close OUT;
41630250
JH
379}
380
381# Below are all the auxiliary routines for generating perltoc.pod
382
383my ($inhead1, $inhead2, $initem);
384
385sub podset {
386 local @ARGV = @_;
387 my $pod;
388
0b01631d
CB
389 return unless scalar(@ARGV);
390
41630250 391 while(<>) {
16114dde 392 tr/\015//d;
41630250
JH
393 if (s/^=head1 (NAME)\s*/=head2 /) {
394 $pod = path2modname($ARGV);
395 unhead1();
396 output "\n \n\n=head2 ";
397 $_ = <>;
767650bc
NC
398 # Remove svn keyword expansions from the Perl FAQ
399 s/ \(\$Revision: \d+ \$\)//g;
41630250
JH
400 if ( /^\s*$pod\b/ ) {
401 s/$pod\.pm/$pod/; # '.pm' in NAME !?
402 output $_;
403 } else {
404 s/^/$pod, /;
405 output $_;
406 }
407 next;
408 }
409 if (s/^=head1 (.*)/=item $1/) {
410 unhead2();
411 output "=over 4\n\n" unless $inhead1;
412 $inhead1 = 1;
413 output $_; nl(); next;
414 }
415 if (s/^=head2 (.*)/=item $1/) {
416 unitem();
417 output "=over 4\n\n" unless $inhead2;
418 $inhead2 = 1;
419 output $_; nl(); next;
420 }
421 if (s/^=item ([^=].*)/$1/) {
422 next if $pod eq 'perldiag';
423 s/^\s*\*\s*$// && next;
424 s/^\s*\*\s*//;
425 s/\n/ /g;
426 s/\s+$//;
427 next if /^[\d.]+$/;
428 next if $pod eq 'perlmodlib' && /^ftp:/;
429 ##print "=over 4\n\n" unless $initem;
430 output ", " if $initem;
431 $initem = 1;
432 s/\.$//;
433 s/^-X\b/-I<X>/;
434 output $_; next;
435 }
436 if (s/^=cut\s*\n//) {
437 unhead1();
438 next;
439 }
440 }
441}
442
443sub unhead1 {
444 unhead2();
445 if ($inhead1) {
446 output "\n\n=back\n\n";
447 }
448 $inhead1 = 0;
449}
450
451sub unhead2 {
452 unitem();
453 if ($inhead2) {
454 output "\n\n=back\n\n";
455 }
456 $inhead2 = 0;
457}
458
459sub unitem {
460 if ($initem) {
461 output "\n\n";
462 ##print "\n\n=back\n\n";
463 }
464 $initem = 0;
465}
466
467sub nl {
468 output "\n";
469}
470
471my $NEWLINE = 0; # how many newlines have we seen recently
472my $LINE; # what remains to be printed
473
474sub output ($) {
475 for (split /(\n)/, shift) {
476 if ($_ eq "\n") {
477 if ($LINE) {
478 print OUT wrap('', '', $LINE);
479 $LINE = '';
480 }
481 if (($NEWLINE) < 2) {
482 print OUT;
483 $NEWLINE++;
484 }
485 }
486 elsif (/\S/ && length) {
487 $LINE .= $_;
488 $NEWLINE = 0;
489 }
490 }
491}
492
493# End of original buildtoc. From here on are routines to generate new sections
494# for and inplace edit other files
495
496sub generate_perlpod {
497 my @output;
498 my $maxlength = 0;
499 foreach (@Master) {
500 my $flags = $_->[0];
501 next if $flags->{aux};
b0b6bf2b 502 next if $flags->{perlpod_omit};
41630250
JH
503
504 if (@$_ == 2) {
505 # Heading
506 push @output, "=head2 $_->[1]\n";
507 } elsif (@$_ == 3) {
508 # Section
509 my $start = " " x (4 + $flags->{indent}) . $_->[1];
510 $maxlength = length $start if length ($start) > $maxlength;
511 push @output, [$start, $_->[2]];
512 } elsif (@$_ == 0) {
513 # blank line
514 push @output, "\n";
515 } else {
516 die "$0: Illegal length " . scalar @$_;
517 }
518 }
519 # want at least 2 spaces padding
520 $maxlength += 2;
521 $maxlength = ($maxlength + 3) & ~3;
522 # sprintf gives $1.....$2 where ... are spaces:
523 return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
524 @output);
525}
526
527
528sub generate_manifest {
529 # Annyoingly unexpand doesn't consider it good form to replace a single
530 # space before a tab with a tab
531 # Annoyingly (2) it returns read only values.
532 my @temp = unexpand (map {sprintf "%-32s%s\n", @$_} @_);
533 map {s/ \t/\t\t/g; $_} @temp;
534}
535sub generate_manifest_pod {
b0b6bf2b 536 generate_manifest map {["pod/$_.pod", $Pods{$_}]}
3dc608da 537 sort grep {!$Copies{"$_.pod"}} grep {!$Generated{"$_.pod"}} keys %Pods;
41630250
JH
538}
539sub generate_manifest_readme {
dd0cfdaa
NC
540 generate_manifest sort {$a->[0] cmp $b->[0]}
541 ["README.vms", "Notes about installing the VMS port"],
542 map {["README.$_", $Readmes{$_}]} keys %Readmes;
41630250
JH
543}
544
545sub generate_roffitall {
546 (map ({"\t\$maindir/$_.1\t\\"}sort keys %Pods),
547 "\t\t\\",
548 map ({"\t\$maindir/$_.1\t\\"}sort keys %Aux),
549 "\t\t\\",
550 map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata),
551 "\t\t\\",
552 map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules),
553 )
554}
555
556sub generate_descrip_mms_1 {
557 local $Text::Wrap::columns = 150;
558 my $count = 0;
559 my @lines = map {"pod" . $count++ . " = $_"}
bae7ea06 560 split /\n/, wrap('', '', join " ", map "[.lib.pods]$_.pod",
41630250
JH
561 sort keys %Pods, keys %Readmepods);
562 @lines, "pod = " . join ' ', map {"\$(pod$_)"} 0 .. $count - 1;
563}
564
565sub generate_descrip_mms_2 {
dd0cfdaa
NC
566 map {<<"SNIP"}
567[.lib.pods]$_.pod : [.pod]$_.pod
568 \@ If F\$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
569 Copy/NoConfirm/Log \$(MMS\$SOURCE) [.lib.pods]
41630250
JH
570SNIP
571 sort keys %Pods, keys %Readmepods;
572}
573
db34a22a
NC
574sub generate_descrip_mms_3 {
575 map qq{\t- If F\$Search("[.pod]$_").nes."" Then Delete/NoConfirm/Log [.pod]$_;*},
576 sort keys %Generated, keys %Copies;
577}
578
41630250 579sub generate_nmake_1 {
b0b6bf2b
AT
580 # XXX Fix this with File::Spec
581 (map {sprintf "\tcopy ..\\README.%-8s ..\\pod\\perl$_.pod\n", $_}
582 sort keys %Readmes),
583 (map {"\tcopy ..\\pod\\$Copies{$_} ..\\pod\\$_\n"} sort keys %Copies);
41630250
JH
584}
585
586# This doesn't have a trailing newline
587sub generate_nmake_2 {
588 # Spot the special case
589 local $Text::Wrap::columns = 76;
590 my $line = wrap ("\t ", "\t ",
9e64a656 591 join " ", sort keys %Copies, keys %Generated,
dd0cfdaa 592 map {"perl$_.pod"} keys %Readmes);
41630250 593 $line =~ s/$/ \\/mg;
b14c7f9a 594 $line =~ s/ \\$//;
41630250
JH
595 $line;
596}
597
598sub generate_pod_mak {
599 my $variable = shift;
600 my @lines;
601 my $line = join "\\\n", "\U$variable = ",
602 map {"\t$_.$variable\t"} sort keys %Pods;
603 # Special case
604 $line =~ s/.*perltoc.html.*\n//m;
605 $line;
606}
607
6d664f07
NC
608sub verify_contiguous {
609 my ($name, $content, $what) = @_;
610 my $sections = () = $content =~ m/\0+/g;
611 croak("$0: $name contains no $what") if $sections < 1;
612 croak("$0: $name contains discontiguous $what") if $sections > 1;
613}
614
41630250
JH
615sub do_manifest {
616 my $name = shift;
617 my @manifest =
618 grep {! m!^pod/[^.]+\.pod.*\n!}
619 grep {! m!^README\.(\S+)! || $Ignore{$1}} @_;
620 # Dictionary order - fold and handle non-word chars as nothing
621 map { $_->[0] }
622 sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] }
6578b326 623 map { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] }
41630250
JH
624 @manifest,
625 &generate_manifest_pod(),
626 &generate_manifest_readme();
627}
628
629sub do_nmake {
630 my $name = shift;
631 my $makefile = join '', @_;
632 die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
633 $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
6d664f07 634 verify_contiguous($name, $makefile, 'README copies');
b0b6bf2b
AT
635 # Now remove the other copies that follow
636 1 while $makefile =~ s/\0\tcopy .*\n/\0/gm;
637 $makefile =~ s/\0+/join ("", &generate_nmake_1)/se;
41630250 638
b14c7f9a
SH
639 $makefile =~ s{(-cd \$\(PODDIR\) && del /f[^\n]+).*?(-cd \.\.\\utils && del /f)}
640 {"$1\n" . &generate_nmake_2."\n\t$2"}se;
41630250
JH
641 $makefile;
642}
643
644# shut up used only once warning
645*do_dmake = *do_dmake = \&do_nmake;
646
647sub do_perlpod {
648 my $name = shift;
649 my $pod = join '', @_;
650
651 unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
652 (?:\s+[a-z]{4,}.*\n # fooo
653 |=head.*\n # =head foo
654 |\s*\n # blank line
655 )+
656 }
657 {$1 . join "", &generate_perlpod}mxe) {
8537f021 658 die "$0: Failed to insert amendments in do_perlpod";
41630250
JH
659 }
660 $pod;
661}
662
663sub do_podmak {
664 my $name = shift;
665 my $body = join '', @_;
d525b9bc 666 foreach my $variable (qw(pod man html tex)) {
41630250
JH
667 die "$0: could not find $variable in $name"
668 unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*}
669 {"\n" . generate_pod_mak ($variable)}se;
670 }
671 $body;
672}
673
674sub do_vms {
675 my $name = shift;
676 my $makefile = join '', @_;
677 die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
678 $makefile =~ s/\npod\d* =[^\n]*/\0/gs;
6d664f07 679 verify_contiguous($name, $makefile, 'pod assignments');
41630250
JH
680 $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_1/se;
681
682 die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
683
684# Looking for rules like this
bae7ea06
NC
685# [.lib.pods]perl.pod : [.pod]perl.pod
686# @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
687# Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
41630250 688
bae7ea06 689 $makefile =~ s/\n\Q[.lib.pods]\Eperl[^\n\.]*\.pod[^\n]+\n
41630250 690 [^\n]+\n # Another line
bae7ea06 691 [^\n]+\Q[.lib.pods]\E\n # ends [.lib.pods]
41630250 692 /\0/gsx;
6d664f07 693 verify_contiguous($name, $makefile, 'copy rules');
41630250 694 $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_2/se;
db34a22a
NC
695
696# Looking for rules like this:
697# - If F$Search("[.pod]perldelta.pod").nes."" Then Delete/NoConfirm/Log [.pod]perldelta.pod;*
698 $makefile =~ s!(?:\t- If F\$Search\("\[\.pod\]perl[a-z]+\Q.pod").nes."" Then Delete/NoConfirm/Log [.pod]perl\E[a-z]+\.pod;\*\n)+!\0!sg;
6d664f07 699 verify_contiguous($name, $makefile, 'delete rules');
db34a22a
NC
700 $makefile =~ s/\0+/join "\n", &generate_descrip_mms_3, ''/se;
701
41630250
JH
702 $makefile;
703}
704
0dfdcd8a
NC
705sub do_unix {
706 my $name = shift;
707 my $makefile_SH = join '', @_;
708 die "$0: $name contains NUL bytes" if $makefile_SH =~ /\0/;
709
7eb47696
NC
710 $makefile_SH =~ s{^(perltoc_pod_prereqs = extra.pods).*}
711 {join ' ', $1, map "pod/$_",
712 sort keys %Copies, grep {!/perltoc/} keys %Generated
713 }mge;
8e7bc40f 714
37ee6528
FR
715# pod/perl511delta.pod: pod/perldelta.pod
716# cd pod && $(LNS) perldelta.pod perl511delta.pod
8e7bc40f
NC
717
718 $makefile_SH =~ s!(
719pod/perl[a-z0-9_]+\.pod: pod/perl[a-z0-9_]+\.pod
e0be038f 720 \$\(LNS\) perl[a-z0-9_]+\.pod pod/perl[a-z0-9_]+\.pod
8e7bc40f 721)+!\0!gm;
0dfdcd8a 722
6d664f07 723 verify_contiguous($name, $makefile_SH, 'copy rules');
0dfdcd8a 724
8e7bc40f
NC
725 my @copy_rules = map "
726pod/$_: pod/$Copies{$_}
e0be038f 727 \$(LNS) $Copies{$_} pod/$_
8e7bc40f 728", keys %Copies;
0dfdcd8a 729
8e7bc40f 730 $makefile_SH =~ s/\0+/join '', @copy_rules/se;
0dfdcd8a
NC
731 $makefile_SH;
732
733}
734
41630250
JH
735# Do stuff
736
737my $built;
738while (my ($target, $name) = each %Targets) {
e94c1c05 739 print "Working on target $target\n" if $Verbose;
41630250
JH
740 next unless $Build{$target};
741 $built++;
742 if ($target eq "toc") {
671313d0 743 print "Now processing $name\n" if $Verbose;
41630250 744 &output_perltoc;
671313d0 745 print "Finished\n" if $Verbose;
41630250
JH
746 next;
747 }
748 print "Now processing $name\n" if $Verbose;
749 open THING, $name or die "Can't open $name: $!";
2187fa19 750 binmode THING;
41630250
JH
751 my @orig = <THING>;
752 my $orig = join '', @orig;
753 close THING;
754 my @new = do {
755 no strict 'refs';
756 &{"do_$target"}($target, @orig);
757 };
758 my $new = join '', @new;
759 if ($new eq $orig) {
760 print "Was not modified\n" if $Verbose;
761 next;
762 }
9b6e0960 763 my $mode = (stat $name)[2] // die "$0: Can't stat $name: $!";
41630250
JH
764 rename $name, "$name.old" or die "$0: Can't rename $name to $name.old: $!";
765 open THING, ">$name" or die "$0: Can't open $name for writing: $!";
2187fa19 766 binmode THING;
41630250 767 print THING $new or die "$0: print to $name failed: $!";
e1020413 768 close THING or die "$0: close $name failed: $!";
9b6e0960 769 chmod $mode & 0777, $name or die "$0: can't chmod $mode $name: $!";
41630250
JH
770}
771
772warn "$0: was not instructed to build anything\n" unless $built;