pod/buildtoc

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use vars qw(%Build %Targets %Pragmata %Modules $Verbose $Quiet $Test);
   5 use File::Spec;
   6 use File::Find;
   7 use FindBin;
   8 use Text::Tabs;
   9 use Text::Wrap;
  10 use Getopt::Long;
  11 use Carp;
  12
  13 no locale;
  14 require 5.010;
  15
  16 # Assumption is that we're either already being run from the top level (*nix,
  17 # VMS), or have absolute paths in @INC (Win32, pod/Makefile)
  18 BEGIN {
  19   my $Top = File::Spec->catdir($FindBin::Bin, File::Spec->updir);
  20   chdir $Top or die "Can't chdir to $Top: $!";
  21   require 'Porting/pod_lib.pl';
  22 }
  23
  24 # Generate any/all of these files
  25 # --verbose gives slightly more output
  26 # --quiet suppresses routine warnings
  27 # --build-all tries to build everything
  28 # --build-foo updates foo as follows
  29 # --showfiles shows the files to be changed
  30 # --test exit if perl.pod, pod.lst, MANIFEST are consistent, and regenerated
  31 #   files are up to date, die otherwise.
  32
  33 %Targets
  34   = (
  35      toc => 'pod/perltoc.pod',
  36      manifest => 'MANIFEST',
  37      perlpod => 'pod/perl.pod',
  38      vms => 'vms/descrip_mms.template',
  39      nmake => 'win32/Makefile',
  40      dmake => 'win32/makefile.mk',
  41      podmak => 'win32/pod.mak',
  42      # plan9 =>  'plan9/mkfile'),
  43      unix => 'Makefile.SH',
  44      # TODO: add roffitall
  45     );
  46
  47 # process command-line switches
  48
  49 {
  50   my @files = keys %Targets;
  51   my $filesopts = join(" | ", map { "--build-$_" } "all", sort @files);
  52   my $showfiles;
  53   my %build_these;
  54   die <<__USAGE__
  55 $0: Usage: $0 [--verbose] [--showfiles] $filesopts
  56 __USAGE__
  57   unless @ARGV
  58         && GetOptions (verbose => \$Verbose,
  59                        quiet => \$Quiet,
  60                        showfiles => \$showfiles,
  61                        test => \$Test,
  62                        map {+"build-$_", \$build_these{$_}} @files, 'all');
  63   if ($build_these{all}) {
  64     %Build = %Targets;
  65   } else {
  66     while (my ($file, $want) = each %build_these) {
  67       $Build{$file} = $Targets{$file} if $want;
  68     }
  69   }
  70   if ($showfiles) {
  71       print join(" ", sort { lc $a cmp lc $b } values %Build), "\n";
  72       exit(0);
  73   }
  74 }
  75
  76 if ($Verbose) {
  77   print "I will be building $_\n" foreach keys %Build;
  78 }
  79
  80 my $state = get_pod_metadata(values %Build);
  81
  82 if ($Test) {
  83     delete $Build{toc};
  84     printf "1..%d\n", 1 + scalar keys %Build;
  85     if (@{$state->{inconsistent}}) {
  86         print "not ok 1\n";
  87         die @{$state->{inconsistent}};
  88     }
  89     print "ok 1\n";
  90 }
  91 else {
  92     warn @{$state->{inconsistent}} if @{$state->{inconsistent}};
  93 }
  94
  95
  96 # Find all the modules
  97 if ($Build{toc}) {
  98   my @modpods;
  99   find \&getpods => 'lib';
 100
 101   sub getpods {
 102     if (/\.p(od|m)$/) {
 103       my $file = $File::Find::name;
 104       return if $file =~ qr!/lib/Pod/Functions.pm\z!; # Used only by pod itself
 105       return if $file =~ m!(?:^|/)t/!;
 106       return if $file =~ m!lib/Attribute/Handlers/demo/!;
 107       return if $file =~ m!lib/Net/FTP/.+\.pm!; # Hi, Graham! :-)
 108       return if $file =~ m!lib/Math/BigInt/t/!;
 109       return if $file =~ m!/Devel/PPPort/[Hh]arness|lib/Devel/Harness!i;
 110       return if $file =~ m!XS/(?:APItest|Typemap)!;
 111       my $pod = $file;
 112       return if $pod =~ s/pm$/pod/ && -e $pod;
 113       unless (open my $f, '<', $_) {
 114         warn "$0: bogus <$file>: $!";
 115         system "ls", "-l", $file;
 116       }
 117       else {
 118         my $line;
 119         while ($line = <$f>) {
 120           if ($line =~ /^=head1\s+NAME\b/) {
 121             push @modpods, $file;
 122             return;
 123           }
 124         }
 125         warn "$0: NOTE: cannot find '=head1 NAME' in:\n  $file\n" unless $Quiet;
 126       }
 127     }
 128   }
 129
 130   my_die "Can't find any pods!\n" unless @modpods;
 131
 132   my %done;
 133   for (@modpods) {
 134     my $name = $_;
 135     $name =~ s/\.p(m|od)$//;
 136     $name =~ s-.*?/lib/--;
 137     $name =~ s-/-::-g;
 138     next if $done{$name}++;
 139
 140     if ($name =~ /^[a-z]/) {
 141       $Pragmata{$name} = $_;
 142     } else {
 143       $Modules{$name} = $_;
 144     }
 145   }
 146 }
 147
 148 # OK. Now a lot of ancillary function definitions follow
 149 # Main program returns at "Do stuff"
 150
 151 my $OUT;
 152
 153 sub do_toc {
 154   my $filename = shift;
 155
 156   ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;
 157
 158         # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 159         # This file is autogenerated by buildtoc from all the other pods.
 160         # Edit those files and run buildtoc --build-toc to effect changes.
 161
 162         =head1 NAME
 163
 164         perltoc - perl documentation table of contents
 165
 166         =head1 DESCRIPTION
 167
 168         This page provides a brief table of contents for the rest of the Perl
 169         documentation set.  It is meant to be scanned quickly or grepped
 170         through to locate the proper section you're looking for.
 171
 172         =head1 BASIC DOCUMENTATION
 173
 174 EOPOD2B
 175 #' make emacs happy
 176
 177   # All the things in the master list that happen to be pod filenames
 178   foreach (grep {defined $_ && @$_ == 3 && !$_->[0]{toc_omit}} @{$state->{master}}) {
 179     podset(@$_);
 180   }
 181
 182
 183   ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;
 184
 185
 186
 187         =head1 PRAGMA DOCUMENTATION
 188
 189 EOPOD2B
 190
 191   foreach (sort keys %Pragmata) {
 192     podset($_, $Pragmata{$_});
 193   }
 194
 195   ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;
 196
 197
 198
 199         =head1 MODULE DOCUMENTATION
 200
 201 EOPOD2B
 202
 203   foreach (sort keys %Modules) {
 204     podset($_, $Modules{$_});
 205   }
 206
 207   $_= <<"EOPOD2B";
 208
 209
 210         =head1 AUXILIARY DOCUMENTATION
 211
 212         Here should be listed all the extra programs' documentation, but they
 213         don't all have manual pages yet:
 214
 215         =over 4
 216
 217 EOPOD2B
 218
 219   $_ .=  join "\n", map {"\t=item $_\n"} sort keys %{$state->{aux}};
 220   $_ .= <<"EOPOD2B" ;
 221
 222         =back
 223
 224         =head1 AUTHOR
 225
 226         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 227         of other folks.
 228
 229
 230 EOPOD2B
 231
 232   s/^\t//gm;
 233   $OUT .= "$_\n";
 234
 235   $OUT =~ s/\n\s+\n/\n\n/gs;
 236   $OUT =~ s/\n{3,}/\n\n/g;
 237
 238   $OUT =~ s/([^\n]+)/wrap('', '', $1)/ge;
 239
 240   return $OUT;
 241 }
 242
 243 # Below are all the auxiliary routines for generating perltoc.pod
 244
 245 my ($inhead1, $inhead2, $initem);
 246
 247 sub podset {
 248     my ($pod, $file) = @_;
 249
 250     local $/ = '';
 251
 252     open my $fh, '<', $file or my_die "Can't open file '$file' for $pod: $!";
 253
 254     while(<$fh>) {
 255         tr/\015//d;
 256         if (s/^=head1 (NAME)\s*/=head2 /) {
 257             unhead1();
 258             $OUT .= "\n\n=head2 ";
 259             $_ = <$fh>;
 260             # Remove svn keyword expansions from the Perl FAQ
 261             s/ \(\$Revision: \d+ \$\)//g;
 262             if ( /^\s*\Q$pod\E\b/ ) {
 263                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 264             } else {
 265                 s/^/$pod, /;
 266             }
 267         }
 268         elsif (s/^=head1 (.*)/=item $1/) {
 269             unhead2();
 270             $OUT .= "=over 4\n\n" unless $inhead1;
 271             $inhead1 = 1;
 272             $_ .= "\n";
 273         }
 274         elsif (s/^=head2 (.*)/=item $1/) {
 275             unitem();
 276             $OUT .= "=over 4\n\n" unless $inhead2;
 277             $inhead2 = 1;
 278             $_ .= "\n";
 279         }
 280         elsif (s/^=item ([^=].*)/$1/) {
 281             next if $pod eq 'perldiag';
 282             s/^\s*\*\s*$// && next;
 283             s/^\s*\*\s*//;
 284             s/\n/ /g;
 285             s/\s+$//;
 286             next if /^[\d.]+$/;
 287             next if $pod eq 'perlmodlib' && /^ftp:/;
 288             $OUT .= ", " if $initem;
 289             $initem = 1;
 290             s/\.$//;
 291             s/^-X\b/-I<X>/;
 292         }
 293         else {
 294             unhead1() if /^=cut\s*\n/;
 295             next;
 296         }
 297         $OUT .= $_;
 298     }
 299 }
 300
 301 sub unhead1 {
 302     unhead2();
 303     if ($inhead1) {
 304         $OUT .= "\n\n=back\n\n";
 305     }
 306     $inhead1 = 0;
 307 }
 308
 309 sub unhead2 {
 310     unitem();
 311     if ($inhead2) {
 312         $OUT .= "\n\n=back\n\n";
 313     }
 314     $inhead2 = 0;
 315 }
 316
 317 sub unitem {
 318     if ($initem) {
 319         $OUT .= "\n\n";
 320     }
 321     $initem = 0;
 322 }
 323
 324 # End of original buildtoc. From here on are routines to generate new sections
 325 # for and inplace edit other files
 326
 327 sub generate_perlpod {
 328   my @output;
 329   my $maxlength = 0;
 330   foreach (@{$state->{master}}) {
 331     my $flags = $_->[0];
 332     next if $flags->{aux};
 333     next if $flags->{perlpod_omit};
 334
 335     if (@$_ == 2) {
 336       # Heading
 337       push @output, "=head2 $_->[1]\n";
 338     } elsif (@$_ == 5) {
 339       # Section
 340       my $start = " " x (4 + $flags->{indent}) . $_->[4];
 341       $maxlength = length $start if length ($start) > $maxlength;
 342       push @output, [$start, $_->[3]];
 343     } elsif (@$_ == 0) {
 344       # blank line
 345       push @output, "\n";
 346     } else {
 347       my_die "Illegal length " . scalar @$_;
 348     }
 349   }
 350   # want at least 2 spaces padding
 351   $maxlength += 2;
 352   $maxlength = ($maxlength + 3) & ~3;
 353   # sprintf gives $1.....$2 where ... are spaces:
 354   return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
 355                    @output);
 356 }
 357
 358
 359 sub generate_manifest {
 360   # Annoyingly, unexpand doesn't consider it good form to replace a single
 361   # space before a tab with a tab
 362   # Annoyingly (2) it returns read only values.
 363   my @temp = unexpand (map {sprintf "%-32s%s", @$_} @_);
 364   map {s/ \t/\t\t/g; $_} @temp;
 365 }
 366 sub generate_manifest_pod {
 367   generate_manifest map {["pod/$_.pod", $state->{pods}{$_}]}
 368     sort grep {
 369         !$state->{copies}{"$_.pod"} && !$state->{generated}{"$_.pod"} && !-e "$_.pod"
 370     } keys %{$state->{pods}};
 371 }
 372 sub generate_manifest_readme {
 373   generate_manifest sort {$a->[0] cmp $b->[0]}
 374     ["README.vms", "Notes about installing the VMS port"],
 375       map {["README.$_", $state->{readmes}{$_}]} keys %{$state->{readmes}};
 376 }
 377
 378 sub generate_roffitall {
 379   (map ({"\t\$maindir/$_.1\t\\"}sort keys %{$state->{pods}}),
 380    "\t\t\\",
 381    map ({"\t\$maindir/$_.1\t\\"}sort keys %{$state->{aux}}),
 382    "\t\t\\",
 383    map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata),
 384    "\t\t\\",
 385    map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules),
 386   )
 387 }
 388
 389 sub generate_nmake_1 {
 390   # XXX Fix this with File::Spec
 391   (map {sprintf "\tcopy ..\\README.%-8s ..\\pod\\perl$_.pod\n", $_}
 392     sort keys %{$state->{readmes}}),
 393       (map {"\tcopy ..\\pod\\$state->{copies}{$_} ..\\pod\\$_\n"} sort keys %{$state->{copies}});
 394 }
 395
 396 # This doesn't have a trailing newline
 397 sub generate_nmake_2 {
 398   # Spot the special case
 399   local $Text::Wrap::columns = 76;
 400   my $line = wrap ("\t    ", "\t    ",
 401                    join " ", sort keys %{$state->{copies}}, keys %{$state->{generated}},
 402                                   map {"perl$_.pod"} keys %{$state->{readmes}});
 403   $line =~ s/$/ \\/mg;
 404   $line =~ s/ \\$//;
 405   $line;
 406 }
 407
 408 sub generate_pod_mak {
 409   my $variable = shift;
 410   my @lines;
 411   my $line = "\U$variable = " . join "\t\\\n\t",
 412     map {"$_.$variable"} sort grep { $_ !~ m{/} } keys %{$state->{pods}};
 413   # Special case
 414   $line =~ s/.*perltoc.html.*\n//m;
 415   $line;
 416 }
 417
 418 sub verify_contiguous {
 419   my ($name, $content, $what) = @_;
 420   my $sections = () = $content =~ m/\0+/g;
 421   croak("$0: $name contains no $what") if $sections < 1;
 422   croak("$0: $name contains discontiguous $what") if $sections > 1;
 423 }
 424
 425 sub do_manifest {
 426   my ($name, $prev) = @_;
 427   my @manifest =
 428     grep {! m!^pod/[^.]+\.pod.*!}
 429       grep {! m!^README\.(\S+)! || $state->{ignore}{$1}} split "\n", $prev;
 430   join "\n", (
 431               # Dictionary order - fold and handle non-word chars as nothing
 432               map  { $_->[0] }
 433               sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] }
 434               map  { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] }
 435               @manifest,
 436               &generate_manifest_pod(),
 437               &generate_manifest_readme()), '';
 438 }
 439
 440 sub do_nmake {
 441   my ($name, $makefile) = @_;
 442   $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
 443   verify_contiguous($name, $makefile, 'README copies');
 444   # Now remove the other copies that follow
 445   1 while $makefile =~ s/\0\tcopy .*\n/\0/gm;
 446   $makefile =~ s/\0+/join ("", &generate_nmake_1)/se;
 447
 448   $makefile =~ s{(-cd \$\(PODDIR\) && del /f[^\n]+).*?(-cd \.\.\\utils && del /f)}
 449     {"$1\n" . &generate_nmake_2."\n\t$2"}se;
 450   $makefile;
 451 }
 452
 453 # shut up used only once warning
 454 *do_dmake = *do_dmake = \&do_nmake;
 455
 456 sub do_perlpod {
 457   my ($name, $pod) = @_;
 458
 459   unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
 460                     (?:\s+[a-z]{4,}.*\n #   fooo
 461                     |=head.*\n          # =head foo
 462                     |\s*\n              # blank line
 463                    )+
 464                   }
 465           {$1 . join "", &generate_perlpod}mxe) {
 466     my_die "Failed to insert amendments in do_perlpod";
 467   }
 468   $pod;
 469 }
 470
 471 sub do_podmak {
 472   my ($name, $body) = @_;
 473   foreach my $variable (qw(pod man html tex)) {
 474     my_die "could not find $variable in $name"
 475       unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*}
 476         {"\n" . generate_pod_mak ($variable)}se;
 477   }
 478   $body;
 479 }
 480
 481 sub do_vms {
 482   my ($name, $makefile) = @_;
 483
 484 # Looking for the macro defining the current perldelta:
 485 #PERLDELTA_CURRENT = [.pod]perl5139delta.pod
 486
 487   $makefile =~ s/\nPERLDELTA_CURRENT\s+=\s+\Q[.pod]perl\E\d+delta\.pod\n
 488                     /\0/sx;
 489   verify_contiguous($name, $makefile, 'current perldelta macro');
 490   $makefile =~ s/\0+/join "\n", '', "PERLDELTA_CURRENT = [.pod]$state->{delta_target}", ''/se;
 491
 492   $makefile;
 493 }
 494
 495 sub do_unix {
 496   my ($name, $makefile_SH) = @_;
 497
 498   $makefile_SH =~ s{^(perltoc_pod_prereqs = extra.pods).*}
 499                    {join ' ', $1, map "pod/$_",
 500                         sort keys %{$state->{copies}}, grep {!/perltoc/} keys %{$state->{generated}}
 501                     }mge;
 502
 503 # pod/perl511delta.pod: pod/perldelta.pod
 504 #       cd pod && $(LNS) perldelta.pod perl511delta.pod
 505
 506   $makefile_SH =~ s!(
 507 pod/perl[a-z0-9_]+\.pod: pod/perl[a-z0-9_]+\.pod
 508         \$\(LNS\) perl[a-z0-9_]+\.pod pod/perl[a-z0-9_]+\.pod
 509 )+!\0!gm;
 510
 511   verify_contiguous($name, $makefile_SH, 'copy rules');
 512
 513   my @copy_rules = map "
 514 pod/$_: pod/$state->{copies}{$_}
 515         \$(LNS) $state->{copies}{$_} pod/$_
 516 ", keys %{$state->{copies}};
 517
 518   $makefile_SH =~ s/\0+/join '', @copy_rules/se;
 519   $makefile_SH;
 520
 521 }
 522
 523 # Do stuff
 524
 525 my $built;
 526 while (my ($target, $name) = each %Targets) {
 527   print "Working on target $target\n" if $Verbose;
 528   next unless $Build{$target};
 529   $built++;
 530   my ($orig, $mode);
 531   print "Now processing $name\n" if $Verbose;
 532   if ($target ne "toc") {
 533     local $/;
 534     my $thing = open_or_die($name);
 535     binmode $thing;
 536     $orig = <$thing>;
 537     my_die "$name contains NUL bytes" if $orig =~ /\0/;
 538   }
 539
 540   my $new = do {
 541     no strict 'refs';
 542     &{"do_$target"}($target, $orig);
 543   };
 544
 545   if (defined $orig) {
 546     if ($new eq $orig) {
 547       if ($Test) {
 548         printf "ok %d # $name is up to date\n", $built + 1;
 549       } elsif ($Verbose) {
 550         print "Was not modified\n";
 551       }
 552       next;
 553     } elsif ($Test) {
 554       printf "not ok %d # $name is up to date\n", $built + 1;
 555       next;
 556     }
 557     $mode = (stat $name)[2] // my_die "Can't stat $name: $!";
 558     rename $name, "$name.old" or my_die "Can't rename $name to $name.old: $!";
 559   }
 560
 561   open my $thing, '>', $name or my_die "Can't open $name for writing: $!";
 562   binmode $thing;
 563   print $thing $new or my_die "print to $name failed: $!";
 564   close $thing or my_die "close $name failed: $!";
 565   if (defined $mode) {
 566     chmod $mode & 0777, $name or my_die "can't chmod $mode $name: $!";
 567   }
 568 }
 569
 570 warn "$0: was not instructed to build anything\n" unless $built || $Test;