pod/buildtoc

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