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         =head1 NAME
 265
 266         perltoc - perl documentation table of contents
 267
 268         =head1 DESCRIPTION
 269
 270         This page provides a brief table of contents for the rest of the Perl
 271         documentation set.  It is meant to be scanned quickly or grepped
 272         through to locate the proper section you're looking for.
 273
 274         =head1 BASIC DOCUMENTATION
 275
 276 EOPOD2B
 277 #' make emacs happy
 278
 279   # All the things in the master list that happen to be pod filenames
 280   podset(map {"$_->[1].pod"} grep {defined $_ && @$_ == 3 && !$_->[0]{toc_omit}} @Master);
 281
 282
 283   ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
 284
 285
 286
 287         =head1 PRAGMA DOCUMENTATION
 288
 289 EOPOD2B
 290
 291   podset(sort values %Pragmata);
 292
 293   ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
 294
 295
 296
 297         =head1 MODULE DOCUMENTATION
 298
 299 EOPOD2B
 300
 301   podset( @Modules{ sort keys %Modules } );
 302
 303   $_= <<"EOPOD2B";
 304
 305
 306         =head1 AUXILIARY DOCUMENTATION
 307
 308         Here should be listed all the extra programs' documentation, but they
 309         don't all have manual pages yet:
 310
 311         =over 4
 312
 313 EOPOD2B
 314
 315   $_ .=  join "\n", map {"\t=item $_\n"} sort keys %Aux;
 316   $_ .= <<"EOPOD2B" ;
 317
 318         =back
 319
 320         =head1 AUTHOR
 321
 322         Larry Wall <F<larry\@wall.org>>, with the help of oodles
 323         of other folks.
 324
 325
 326 EOPOD2B
 327
 328   s/^\t//gm;
 329   output $_;
 330   output "\n";                    # flush $LINE
 331 }
 332
 333 # Below are all the auxiliary routines for generating perltoc.pod
 334
 335 my ($inhead1, $inhead2, $initem);
 336
 337 sub podset {
 338     local @ARGV = @_;
 339     my $pod;
 340
 341     while(<>) {
 342         if (s/^=head1 (NAME)\s*/=head2 /) {
 343             $pod = path2modname($ARGV);
 344             unhead1();
 345             output "\n \n\n=head2 ";
 346             $_ = <>;
 347             if ( /^\s*$pod\b/ ) {
 348                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
 349                 output $_;
 350             } else {
 351                 s/^/$pod, /;
 352                 output $_;
 353             }
 354             next;
 355         }
 356         if (s/^=head1 (.*)/=item $1/) {
 357             unhead2();
 358             output "=over 4\n\n" unless $inhead1;
 359             $inhead1 = 1;
 360             output $_; nl(); next;
 361         }
 362         if (s/^=head2 (.*)/=item $1/) {
 363             unitem();
 364             output "=over 4\n\n" unless $inhead2;
 365             $inhead2 = 1;
 366             output $_; nl(); next;
 367         }
 368         if (s/^=item ([^=].*)/$1/) {
 369             next if $pod eq 'perldiag';
 370             s/^\s*\*\s*$// && next;
 371             s/^\s*\*\s*//;
 372             s/\n/ /g;
 373             s/\s+$//;
 374             next if /^[\d.]+$/;
 375             next if $pod eq 'perlmodlib' && /^ftp:/;
 376             ##print "=over 4\n\n" unless $initem;
 377             output ", " if $initem;
 378             $initem = 1;
 379             s/\.$//;
 380             s/^-X\b/-I<X>/;
 381             output $_; next;
 382         }
 383         if (s/^=cut\s*\n//) {
 384             unhead1();
 385             next;
 386         }
 387     }
 388 }
 389
 390 sub unhead1 {
 391     unhead2();
 392     if ($inhead1) {
 393         output "\n\n=back\n\n";
 394     }
 395     $inhead1 = 0;
 396 }
 397
 398 sub unhead2 {
 399     unitem();
 400     if ($inhead2) {
 401         output "\n\n=back\n\n";
 402     }
 403     $inhead2 = 0;
 404 }
 405
 406 sub unitem {
 407     if ($initem) {
 408         output "\n\n";
 409         ##print "\n\n=back\n\n";
 410     }
 411     $initem = 0;
 412 }
 413
 414 sub nl {
 415     output "\n";
 416 }
 417
 418 my $NEWLINE = 0;        # how many newlines have we seen recently
 419 my $LINE;               # what remains to be printed
 420
 421 sub output ($) {
 422     for (split /(\n)/, shift) {
 423         if ($_ eq "\n") {
 424             if ($LINE) {
 425                 print OUT wrap('', '', $LINE);
 426                 $LINE = '';
 427             }
 428             if (($NEWLINE) < 2) {
 429                 print OUT;
 430                 $NEWLINE++;
 431             }
 432         }
 433         elsif (/\S/ && length) {
 434             $LINE .= $_;
 435             $NEWLINE = 0;
 436         }
 437     }
 438 }
 439
 440 # End of original buildtoc. From here on are routines to generate new sections
 441 # for and inplace edit other files
 442
 443 sub generate_perlpod {
 444   my @output;
 445   my $maxlength = 0;
 446   foreach (@Master) {
 447     my $flags = $_->[0];
 448     next if $flags->{aux};
 449
 450     if (@$_ == 2) {
 451       # Heading
 452       push @output, "=head2 $_->[1]\n";
 453     } elsif (@$_ == 3) {
 454       # Section
 455       my $start = " " x (4 + $flags->{indent}) . $_->[1];
 456       $maxlength = length $start if length ($start) > $maxlength;
 457       push @output, [$start, $_->[2]];
 458     } elsif (@$_ == 0) {
 459       # blank line
 460       push @output, "\n";
 461     } else {
 462       die "$0: Illegal length " . scalar @$_;
 463     }
 464   }
 465   # want at least 2 spaces padding
 466   $maxlength += 2;
 467   $maxlength = ($maxlength + 3) & ~3;
 468   # sprintf gives $1.....$2 where ... are spaces:
 469   return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
 470                    @output);
 471 }
 472
 473
 474 sub generate_manifest {
 475   # Annyoingly unexpand doesn't consider it good form to replace a single
 476   # space before a tab with a tab
 477   # Annoyingly (2) it returns read only values.
 478   my @temp = unexpand (map {sprintf "%-32s%s\n", @$_} @_);
 479   map {s/ \t/\t\t/g; $_} @temp;
 480 }
 481 sub generate_manifest_pod {
 482   generate_manifest map {["pod/$_.pod", $Pods{$_}]} sort keys %Pods;
 483 }
 484 sub generate_manifest_readme {
 485   generate_manifest map {["README.$_", $Readmes{$_}]} sort keys %Readmes;
 486 }
 487
 488 sub generate_roffitall {
 489   (map ({"\t\$maindir/$_.1\t\\"}sort keys %Pods),
 490    "\t\t\\",
 491    map ({"\t\$maindir/$_.1\t\\"}sort keys %Aux),
 492    "\t\t\\",
 493    map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata),
 494    "\t\t\\",
 495    map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules),
 496   )
 497 }
 498
 499 sub generate_descrip_mms_1 {
 500   local $Text::Wrap::columns = 150;
 501   my $count = 0;
 502   my @lines = map {"pod" . $count++ . " = $_"}
 503     split /\n/, wrap('', '', join " ", map "[.lib.pod]$_.pod",
 504                      sort keys %Pods, keys %Readmepods);
 505   @lines, "pod = " . join ' ', map {"\$(pod$_)"} 0 .. $count - 1;
 506 }
 507
 508 sub generate_descrip_mms_2 {
 509   map {sprintf <<'SNIP', $_, $_}
 510 [.lib.pod]%s.pod : [.pod]%s.pod
 511         @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
 512         Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod]
 513 SNIP
 514    sort keys %Pods, keys %Readmepods;
 515 }
 516
 517 sub generate_nmake_1 {
 518   map {sprintf "\tcopy ..\\README.%-8s .\\perl$_.pod\n", $_}
 519     sort keys %Readmes;
 520 }
 521
 522 # This doesn't have a trailing newline
 523 sub generate_nmake_2 {
 524   # Spot the special case
 525   local $Text::Wrap::columns = 76;
 526   my $line = wrap ("\t    ", "\t    ",
 527                    join " ", sort map {"perl$_.pod"} "vms", keys %Readmes);
 528   $line =~ s/$/ \\/mg;
 529   $line;
 530 }
 531
 532 sub generate_pod_mak {
 533   my $variable = shift;
 534   my @lines;
 535   my $line = join "\\\n", "\U$variable = ",
 536     map {"\t$_.$variable\t"} sort keys %Pods;
 537   # Special case
 538   $line =~ s/.*perltoc.html.*\n//m;
 539   $line;
 540 }
 541
 542 sub do_manifest {
 543   my $name = shift;
 544   my @manifest =
 545     grep {! m!^pod/[^.]+\.pod.*\n!}
 546       grep {! m!^README\.(\S+)! || $Ignore{$1}} @_;
 547   # Dictionary order - fold and handle non-word chars as nothing
 548   map  { $_->[0] }
 549   sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] }
 550   map  { my $f = $_; $f =~ s/[^a-z\s]//g; [ $_, $f ] }
 551     @manifest,
 552       &generate_manifest_pod(),
 553         &generate_manifest_readme();
 554 }
 555
 556 sub do_nmake {
 557   my $name = shift;
 558   my $makefile = join '', @_;
 559   die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
 560   $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm;
 561   my $sections = () = $makefile =~ m/\0+/g;
 562   die "$0: $name contains no README copies" if $sections < 1;
 563   die "$0: $name contains discontiguous README copies" if $sections > 1;
 564   $makefile =~ s/\0+/join "", &generate_nmake_1/se;
 565
 566   $makefile =~ s{(cd \$\(PODDIR\) && del /f [^\n]+).*?(pod2html)}
 567     {"$1\n" . &generate_nmake_2."\n\t    $2"}se;
 568   $makefile;
 569 }
 570
 571 # shut up used only once warning
 572 *do_dmake = *do_dmake = \&do_nmake;
 573
 574 sub do_perlpod {
 575   my $name = shift;
 576   my $pod = join '', @_;
 577
 578   unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
 579                     (?:\s+[a-z]{4,}.*\n #   fooo
 580                     |=head.*\n          # =head foo
 581                     |\s*\n              # blank line
 582                    )+
 583                   }
 584           {$1 . join "", &generate_perlpod}mxe) {
 585     die "$0: Failed to insert ammendments in do_perlpod";
 586   }
 587   $pod;
 588 }
 589
 590 sub do_podmak {
 591   my $name = shift;
 592   my $body = join '', @_;
 593   foreach my $variable qw(pod man html tex) {
 594     die "$0: could not find $variable in $name"
 595       unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*}
 596         {"\n" . generate_pod_mak ($variable)}se;
 597   }
 598   $body;
 599 }
 600
 601 sub do_vms {
 602   my $name = shift;
 603   my $makefile = join '', @_;
 604   die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
 605   $makefile =~ s/\npod\d* =[^\n]*/\0/gs;
 606   my $sections = () = $makefile =~ m/\0+/g;
 607   die "$0: $name contains no pod assignments" if $sections < 1;
 608   die "$0: $name contains $sections discontigous pod assignments"
 609     if $sections > 1;
 610   $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_1/se;
 611
 612   die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
 613
 614 # Looking for rules like this
 615 # [.lib.pod]perl.pod : [.pod]perl.pod
 616 #       @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
 617 #       Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod]
 618
 619   $makefile =~ s/\n\Q[.lib.pod]\Eperl[^\n\.]*\.pod[^\n]+\n
 620                  [^\n]+\n       # Another line
 621                  [^\n]+\Q[.lib.pod]\E\n         # ends [.lib.pod]
 622                     /\0/gsx;
 623   $sections = () = $makefile =~ m/\0+/g;
 624   die "$0: $name contains no copy rules" if $sections < 1;
 625   die "$0: $name contains $sections discontigous copy rules"
 626     if $sections > 1;
 627   $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_2/se;
 628   $makefile;
 629 }
 630
 631 # Do stuff
 632
 633 my $built;
 634 while (my ($target, $name) = each %Targets) {
 635   next unless $Build{$target};
 636   $built++;
 637   if ($target eq "toc") {
 638     &output_perltoc;
 639     next;
 640   }
 641   print "Now processing $name\n" if $Verbose;
 642   open THING, $name or die "Can't open $name: $!";
 643   my @orig = <THING>;
 644   my $orig = join '', @orig;
 645   close THING;
 646   my @new = do {
 647     no strict 'refs';
 648     &{"do_$target"}($target, @orig);
 649   };
 650   my $new = join '', @new;
 651   if ($new eq $orig) {
 652     print "Was not modified\n" if $Verbose;
 653     next;
 654   }
 655   rename $name, "$name.old" or die "$0: Can't rename $name to $name.old: $!";
 656   open THING, ">$name" or die "$0: Can't open $name for writing: $!";
 657   print THING $new or die "$0: print to $name failed: $!";
 658   close THING or die die "$0: close $name failed: $!";
 659 }
 660
 661 warn "$0: was not instructed to build anything\n" unless $built;