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