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