pod/buildtoc

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