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 = path2modname($_);
 303     if ($name =~ /^[a-z]/) {
 304       $Pragmata{$name} = $_;
 305     } else {
 306       if ($done{$name}++) {
 307         next;
 308       }
 309       $Modules{$name} = $_;
 310     }
 311   }
 312 }
 313
 314 # OK. Now a lot of ancillary function definitions follow
 315 # Main program returns at "Do stuff"
 316
 317 sub path2modname {
 318     local $_ = shift;
 319     s/\.p(m|od)$//;
 320     s-.*?/lib/--;
 321     s-/-::-g;
 322     s/(\w+)::\1/$1/;
 323     return $_;
 324 }
 325
 326 sub output ($);
 327
 328 sub output_perltoc {
 329   my $filename = shift;
 330   open OUT, '>', $filename or die "$0: creating $filename failed: $!";
 331
 332   local $/ = '';
 333
 334   ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
 335
 336         # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 337         # This file is autogenerated by buildtoc from all the other pods.
 338         # Edit those files and run buildtoc --build-toc to effect changes.
 339
 340         =head1 NAME
 341
 342         perltoc - perl documentation table of contents
 343
 344         =head1 DESCRIPTION
 345
 346         This page provides a brief table of contents for the rest of the Perl
 347         documentation set.  It is meant to be scanned quickly or grepped
 348         through to locate the proper section you're looking for.
 349
 350         =head1 BASIC DOCUMENTATION
 351
 352 EOPOD2B
 353 #' make emacs happy
 354
 355   # All the things in the master list that happen to be pod filenames
 356   foreach (grep {defined $_ && @$_ == 3 && !$_->[0]{toc_omit}} @Master) {
 357     podset($_->[1], abs_from_top("pod/$_->[1].pod"));
 358   }
 359
 360
 361   ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
 362
 363
 364
 365         =head1 PRAGMA DOCUMENTATION
 366
 367 EOPOD2B
 368
 369   foreach (sort keys %Pragmata) {
 370     podset($_, $Pragmata{$_});
 371   }
 372
 373   ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
 374
 375
 376
 377         =head1 MODULE DOCUMENTATION
 378
 379 EOPOD2B
 380
 381   foreach (sort keys %Modules) {
 382     podset($_, $Modules{$_});
 383   }
 384
 385   $_= <<"EOPOD2B";
 386
 387
 388         =head1 AUXILIARY DOCUMENTATION
 389
 390         Here should be listed all the extra programs' documentation, but they
 391         don't all have manual pages yet:
 392
 393         =over 4
 394
 395 EOPOD2B
 396
 397   $_ .=  join "\n", map {"\t=item $_\n"} sort keys %Aux;
 398   $_ .= <<"EOPOD2B" ;
 399
 400         =back
 401
 402         =head1 AUTHOR
 403
 404         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 405         of other folks.
 406
 407
 408 EOPOD2B
 409
 410   s/^\t//gm;
 411   output $_;
 412   output "\n";                    # flush $LINE
 413   close OUT;
 414 }
 415
 416 # Below are all the auxiliary routines for generating perltoc.pod
 417
 418 my ($inhead1, $inhead2, $initem);
 419
 420 sub podset {
 421     my ($pod, $file) = @_;
 422
 423     open my $fh, '<', $file or die "Can't open file '$file' for $pod: $!";
 424
 425     while(<$fh>) {
 426         tr/\015//d;
 427         if (s/^=head1 (NAME)\s*/=head2 /) {
 428             unhead1();
 429             output "\n\n=head2 ";
 430             $_ = <$fh>;
 431             # Remove svn keyword expansions from the Perl FAQ
 432             s/ \(\$Revision: \d+ \$\)//g;
 433             if ( /^\s*\Q$pod\E\b/ ) {
 434                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 435                 output $_;
 436             } else {
 437                 s/^/$pod, /;
 438                 output $_;
 439             }
 440             next;
 441         }
 442         if (s/^=head1 (.*)/=item $1/) {
 443             unhead2();
 444             output "=over 4\n\n" unless $inhead1;
 445             $inhead1 = 1;
 446             output $_; nl(); next;
 447         }
 448         if (s/^=head2 (.*)/=item $1/) {
 449             unitem();
 450             output "=over 4\n\n" unless $inhead2;
 451             $inhead2 = 1;
 452             output $_; nl(); next;
 453         }
 454         if (s/^=item ([^=].*)/$1/) {
 455             next if $pod eq 'perldiag';
 456             s/^\s*\*\s*$// && next;
 457             s/^\s*\*\s*//;
 458             s/\n/ /g;
 459             s/\s+$//;
 460             next if /^[\d.]+$/;
 461             next if $pod eq 'perlmodlib' && /^ftp:/;
 462             output ", " if $initem;
 463             $initem = 1;
 464             s/\.$//;
 465             s/^-X\b/-I<X>/;
 466             output $_; next;
 467         }
 468         if (s/^=cut\s*\n//) {
 469             unhead1();
 470             next;
 471         }
 472     }
 473 }
 474
 475 sub unhead1 {
 476     unhead2();
 477     if ($inhead1) {
 478         output "\n\n=back\n\n";
 479     }
 480     $inhead1 = 0;
 481 }
 482
 483 sub unhead2 {
 484     unitem();
 485     if ($inhead2) {
 486         output "\n\n=back\n\n";
 487     }
 488     $inhead2 = 0;
 489 }
 490
 491 sub unitem {
 492     if ($initem) {
 493         output "\n\n";
 494     }
 495     $initem = 0;
 496 }
 497
 498 sub nl {
 499     output "\n";
 500 }
 501
 502 my $NEWLINE = 0;        # how many newlines have we seen recently
 503 my $LINE;               # what remains to be printed
 504
 505 sub output ($) {
 506     for (split /(\n)/, shift) {
 507         if ($_ eq "\n") {
 508             if ($LINE) {
 509                 print OUT wrap('', '', $LINE);
 510                 $LINE = '';
 511             }
 512             if (($NEWLINE) < 2) {
 513                 print OUT;
 514                 $NEWLINE++;
 515             }
 516         }
 517         elsif (/\S/) {
 518             $LINE .= $_;
 519             $NEWLINE = 0;
 520         }
 521     }
 522 }
 523
 524 # End of original buildtoc. From here on are routines to generate new sections
 525 # for and inplace edit other files
 526
 527 sub generate_perlpod {
 528   my @output;
 529   my $maxlength = 0;
 530   foreach (@Master) {
 531     my $flags = $_->[0];
 532     next if $flags->{aux};
 533     next if $flags->{perlpod_omit};
 534
 535     if (@$_ == 2) {
 536       # Heading
 537       push @output, "=head2 $_->[1]\n";
 538     } elsif (@$_ == 3) {
 539       # Section
 540       my $start = " " x (4 + $flags->{indent}) . $_->[1];
 541       $maxlength = length $start if length ($start) > $maxlength;
 542       push @output, [$start, $_->[2]];
 543     } elsif (@$_ == 0) {
 544       # blank line
 545       push @output, "\n";
 546     } else {
 547       die "$0: Illegal length " . scalar @$_;
 548     }
 549   }
 550   # want at least 2 spaces padding
 551   $maxlength += 2;
 552   $maxlength = ($maxlength + 3) & ~3;
 553   # sprintf gives $1.....$2 where ... are spaces:
 554   return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
 555                    @output);
 556 }
 557
 558
 559 sub generate_manifest {
 560   # Annoyingly, unexpand doesn't consider it good form to replace a single
 561   # space before a tab with a tab
 562   # Annoyingly (2) it returns read only values.
 563   my @temp = unexpand (map {sprintf "%-32s%s\n", @$_} @_);
 564   map {s/ \t/\t\t/g; $_} @temp;
 565 }
 566 sub generate_manifest_pod {
 567   generate_manifest map {["pod/$_.pod", $Pods{$_}]}
 568     sort grep {!$Copies{"$_.pod"}} grep {!$Generated{"$_.pod"}} keys %Pods;
 569 }
 570 sub generate_manifest_readme {
 571   generate_manifest sort {$a->[0] cmp $b->[0]}
 572     ["README.vms", "Notes about installing the VMS port"],
 573       map {["README.$_", $Readmes{$_}]} keys %Readmes;
 574 }
 575
 576 sub generate_roffitall {
 577   (map ({"\t\$maindir/$_.1\t\\"}sort keys %Pods),
 578    "\t\t\\",
 579    map ({"\t\$maindir/$_.1\t\\"}sort keys %Aux),
 580    "\t\t\\",
 581    map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata),
 582    "\t\t\\",
 583    map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules),
 584   )
 585 }
 586
 587 sub generate_descrip_mms_1 {
 588   local $Text::Wrap::columns = 150;
 589   my $count = 0;
 590   my @lines = map {"pod" . $count++ . " = $_"}
 591     split /\n/, wrap('', '', join " ", map "[.lib.pods]$_.pod",
 592                      sort keys %Pods, keys %Readmepods);
 593   @lines, "pod = " . join ' ', map {"\$(pod$_)"} 0 .. $count - 1;
 594 }
 595
 596 sub generate_descrip_mms_2 {
 597   map {<<"SNIP"}
 598 [.lib.pods]$_.pod : [.pod]$_.pod
 599         \@ If F\$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
 600         Copy/NoConfirm/Log \$(MMS\$SOURCE) [.lib.pods]
 601 SNIP
 602    sort keys %Pods, keys %Readmepods;
 603 }
 604
 605 sub generate_descrip_mms_3 {
 606   map qq{\t- If F\$Search("[.pod]$_").nes."" Then Delete/NoConfirm/Log [.pod]$_;*},
 607     sort keys %Generated, keys %Copies;
 608 }
 609
 610 sub generate_nmake_1 {
 611   # XXX Fix this with File::Spec
 612   (map {sprintf "\tcopy ..\\README.%-8s ..\\pod\\perl$_.pod\n", $_}
 613     sort keys %Readmes),
 614       (map {"\tcopy ..\\pod\\$Copies{$_} ..\\pod\\$_\n"} sort keys %Copies);
 615 }
 616
 617 # This doesn't have a trailing newline
 618 sub generate_nmake_2 {
 619   # Spot the special case
 620   local $Text::Wrap::columns = 76;
 621   my $line = wrap ("\t    ", "\t    ",
 622                    join " ", sort keys %Copies, keys %Generated,
 623                                   map {"perl$_.pod"} keys %Readmes);
 624   $line =~ s/$/ \\/mg;
 625   $line =~ s/ \\$//;
 626   $line;
 627 }
 628
 629 sub generate_pod_mak {
 630   my $variable = shift;
 631   my @lines;
 632   my $line = join "\\\n", "\U$variable = ",
 633     map {"\t$_.$variable\t"} sort keys %Pods;
 634   # Special case
 635   $line =~ s/.*perltoc.html.*\n//m;
 636   $line;
 637 }
 638
 639 sub verify_contiguous {
 640   my ($name, $content, $what) = @_;
 641   my $sections = () = $content =~ m/\0+/g;
 642   croak("$0: $name contains no $what") if $sections < 1;
 643   croak("$0: $name contains discontiguous $what") if $sections > 1;
 644 }
 645
 646 sub do_manifest {
 647   my $name = shift;
 648   my @manifest =
 649     grep {! m!^pod/[^.]+\.pod.*\n!}
 650       grep {! m!^README\.(\S+)! || $Ignore{$1}} @_;
 651   # Dictionary order - fold and handle non-word chars as nothing
 652   map  { $_->[0] }
 653   sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] }
 654   map  { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] }
 655     @manifest,
 656       &generate_manifest_pod(),
 657         &generate_manifest_readme();
 658 }
 659
 660 sub do_nmake {
 661   my $name = shift;
 662   my $makefile = join '', @_;
 663   die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
 664   $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
 665   verify_contiguous($name, $makefile, 'README copies');
 666   # Now remove the other copies that follow
 667   1 while $makefile =~ s/\0\tcopy .*\n/\0/gm;
 668   $makefile =~ s/\0+/join ("", &generate_nmake_1)/se;
 669
 670   $makefile =~ s{(-cd \$\(PODDIR\) && del /f[^\n]+).*?(-cd \.\.\\utils && del /f)}
 671     {"$1\n" . &generate_nmake_2."\n\t$2"}se;
 672   $makefile;
 673 }
 674
 675 # shut up used only once warning
 676 *do_dmake = *do_dmake = \&do_nmake;
 677
 678 sub do_perlpod {
 679   my $name = shift;
 680   my $pod = join '', @_;
 681
 682   unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
 683                     (?:\s+[a-z]{4,}.*\n #   fooo
 684                     |=head.*\n          # =head foo
 685                     |\s*\n              # blank line
 686                    )+
 687                   }
 688           {$1 . join "", &generate_perlpod}mxe) {
 689     die "$0: Failed to insert amendments in do_perlpod";
 690   }
 691   $pod;
 692 }
 693
 694 sub do_podmak {
 695   my $name = shift;
 696   my $body = join '', @_;
 697   foreach my $variable (qw(pod man html tex)) {
 698     die "$0: could not find $variable in $name"
 699       unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*}
 700         {"\n" . generate_pod_mak ($variable)}se;
 701   }
 702   $body;
 703 }
 704
 705 sub do_vms {
 706   my $name = shift;
 707   my $makefile = join '', @_;
 708   die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
 709   $makefile =~ s/\npod\d* =[^\n]*/\0/gs;
 710   verify_contiguous($name, $makefile, 'pod assignments');
 711   $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_1/se;
 712
 713   die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
 714
 715 # Looking for rules like this
 716 # [.lib.pods]perl.pod : [.pod]perl.pod
 717 #       @ If F$Search("[.lib]pods.dir").eqs."" Then Create/Directory [.lib.pods]
 718 #       Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pods]
 719
 720   $makefile =~ s/\n\Q[.lib.pods]\Eperl[^\n\.]*\.pod[^\n]+\n
 721                  [^\n]+\n       # Another line
 722                  [^\n]+\Q[.lib.pods]\E\n                # ends [.lib.pods]
 723                     /\0/gsx;
 724   verify_contiguous($name, $makefile, 'copy rules');
 725   $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_2/se;
 726
 727 # Looking for rules like this:
 728 #       - If F$Search("[.pod]perldelta.pod").nes."" Then Delete/NoConfirm/Log [.pod]perldelta.pod;*
 729   $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;
 730   verify_contiguous($name, $makefile, 'delete rules');
 731   $makefile =~ s/\0+/join "\n", &generate_descrip_mms_3, ''/se;
 732
 733   $makefile;
 734 }
 735
 736 sub do_unix {
 737   my $name = shift;
 738   my $makefile_SH = join '', @_;
 739   die "$0: $name contains NUL bytes" if $makefile_SH =~ /\0/;
 740
 741   $makefile_SH =~ s{^(perltoc_pod_prereqs = extra.pods).*}
 742                    {join ' ', $1, map "pod/$_",
 743                         sort keys %Copies, grep {!/perltoc/} keys %Generated
 744                     }mge;
 745
 746 # pod/perl511delta.pod: pod/perldelta.pod
 747 #       cd pod && $(LNS) perldelta.pod perl511delta.pod
 748
 749   $makefile_SH =~ s!(
 750 pod/perl[a-z0-9_]+\.pod: pod/perl[a-z0-9_]+\.pod
 751         \$\(LNS\) perl[a-z0-9_]+\.pod pod/perl[a-z0-9_]+\.pod
 752 )+!\0!gm;
 753
 754   verify_contiguous($name, $makefile_SH, 'copy rules');
 755
 756   my @copy_rules = map "
 757 pod/$_: pod/$Copies{$_}
 758         \$(LNS) $Copies{$_} pod/$_
 759 ", keys %Copies;
 760
 761   $makefile_SH =~ s/\0+/join '', @copy_rules/se;
 762   $makefile_SH;
 763
 764 }
 765
 766 # Do stuff
 767
 768 my $built;
 769 while (my ($target, $name) = each %Targets) {
 770   print "Working on target $target\n" if $Verbose;
 771   next unless $Build{$target};
 772   $built++;
 773   if ($target eq "toc") {
 774     print "Now processing $name\n" if $Verbose;
 775     output_perltoc($name);
 776     print "Finished\n" if $Verbose;
 777     next;
 778   }
 779   print "Now processing $name\n" if $Verbose;
 780   open THING, $name or die "Can't open $name: $!";
 781   binmode THING;
 782   my @orig = <THING>;
 783   my $orig = join '', @orig;
 784   close THING;
 785   my @new = do {
 786     no strict 'refs';
 787     &{"do_$target"}($target, @orig);
 788   };
 789   my $new = join '', @new;
 790   if ($new eq $orig) {
 791     print "Was not modified\n" if $Verbose;
 792     next;
 793   }
 794   my $mode = (stat $name)[2] // die "$0: Can't stat $name: $!";
 795   rename $name, "$name.old" or die "$0: Can't rename $name to $name.old: $!";
 796   open THING, ">$name" or die "$0: Can't open $name for writing: $!";
 797   binmode THING;
 798   print THING $new or die "$0: print to $name failed: $!";
 799   close THING or die "$0: close $name failed: $!";
 800   chmod $mode & 0777, $name or die "$0: can't chmod $mode $name: $!";
 801 }
 802
 803 warn "$0: was not instructed to build anything\n" unless $built;