pod/buildtoc

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