buildtoc revision 1.6
1#!/usr/bin/perl -w 2 3use strict; 4use vars qw($masterpodfile %Build %Targets $Verbose $Up %Ignore 5 @Master %Readmes %Pods %Aux %Readmepods %Pragmata %Modules); 6use File::Spec; 7use File::Find; 8use FindBin; 9use Text::Tabs; 10use Text::Wrap; 11use Getopt::Long; 12 13no 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 75if ($Verbose) { 76 print "I'm building $_\n" foreach grep {$Build{$_}} keys %Build; 77} 78 79chdir $FindBin::Bin or die "$0: Can't chdir $FindBin::Bin: $!"; 80 81open MASTER, $masterpodfile or die "$0: Can't open $masterpodfile: $!"; 82 83foreach (<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 124close 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 my $pod = $file; 207 return if $pod =~ s/pm$/pod/ && -e $pod; 208 die "$0: tut $File::Find::name" if $file =~ /TUT/; 209 unless (open (F, "< $_\0")) { 210 warn "$0: bogus <$file>: $!"; 211 system "ls", "-l", $file; 212 } 213 else { 214 my $line; 215 while ($line = <F>) { 216 if ($line =~ /^=head1\s+NAME\b/) { 217 push @modpods, $file; 218 #warn "GOOD $file\n"; 219 return; 220 } 221 } 222 warn "$0: $file: cannot find =head1 NAME\n"; 223 } 224 } 225 } 226 227 die "$0: no pods" unless @modpods; 228 229 my %done; 230 for (@modpods) { 231 #($name) = /(\w+)\.p(m|od)$/; 232 my $name = path2modname($_); 233 if ($name =~ /^[a-z]/) { 234 $Pragmata{$name} = $_; 235 } else { 236 if ($done{$name}++) { 237 # warn "already did $_\n"; 238 next; 239 } 240 $Modules{$name} = $_; 241 } 242 } 243} 244 245# OK. Now a lot of ancillay function definitions follow 246# Main program returns at "Do stuff" 247 248sub path2modname { 249 local $_ = shift; 250 s/\.p(m|od)$//; 251 s-.*?/(lib|ext)/--; 252 s-/-::-g; 253 s/(\w+)::\1/$1/; 254 return $_; 255} 256 257sub output ($); 258 259sub output_perltoc { 260 open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!"; 261 262 $/ = ''; 263 264 ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_); 265 266 # !!!!!!! DO NOT EDIT THIS FILE !!!!!!! 267 # This file is autogenerated by buildtoc from all the other pods. 268 # Edit those files and run buildtoc --build-toc to effect changes. 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 282EOPOD2B 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 295EOPOD2B 296 297 podset(sort values %Pragmata); 298 299 ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_); 300 301 302 303 =head1 MODULE DOCUMENTATION 304 305EOPOD2B 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 319EOPOD2B 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 332EOPOD2B 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 341my ($inhead1, $inhead2, $initem); 342 343sub podset { 344 local @ARGV = @_; 345 my $pod; 346 347 while(<>) { 348 tr/\015//d; 349 if (s/^=head1 (NAME)\s*/=head2 /) { 350 $pod = path2modname($ARGV); 351 unhead1(); 352 output "\n \n\n=head2 "; 353 $_ = <>; 354 if ( /^\s*$pod\b/ ) { 355 s/$pod\.pm/$pod/; # '.pm' in NAME !? 356 output $_; 357 } else { 358 s/^/$pod, /; 359 output $_; 360 } 361 next; 362 } 363 if (s/^=head1 (.*)/=item $1/) { 364 unhead2(); 365 output "=over 4\n\n" unless $inhead1; 366 $inhead1 = 1; 367 output $_; nl(); next; 368 } 369 if (s/^=head2 (.*)/=item $1/) { 370 unitem(); 371 output "=over 4\n\n" unless $inhead2; 372 $inhead2 = 1; 373 output $_; nl(); next; 374 } 375 if (s/^=item ([^=].*)/$1/) { 376 next if $pod eq 'perldiag'; 377 s/^\s*\*\s*$// && next; 378 s/^\s*\*\s*//; 379 s/\n/ /g; 380 s/\s+$//; 381 next if /^[\d.]+$/; 382 next if $pod eq 'perlmodlib' && /^ftp:/; 383 ##print "=over 4\n\n" unless $initem; 384 output ", " if $initem; 385 $initem = 1; 386 s/\.$//; 387 s/^-X\b/-I<X>/; 388 output $_; next; 389 } 390 if (s/^=cut\s*\n//) { 391 unhead1(); 392 next; 393 } 394 } 395} 396 397sub unhead1 { 398 unhead2(); 399 if ($inhead1) { 400 output "\n\n=back\n\n"; 401 } 402 $inhead1 = 0; 403} 404 405sub unhead2 { 406 unitem(); 407 if ($inhead2) { 408 output "\n\n=back\n\n"; 409 } 410 $inhead2 = 0; 411} 412 413sub unitem { 414 if ($initem) { 415 output "\n\n"; 416 ##print "\n\n=back\n\n"; 417 } 418 $initem = 0; 419} 420 421sub nl { 422 output "\n"; 423} 424 425my $NEWLINE = 0; # how many newlines have we seen recently 426my $LINE; # what remains to be printed 427 428sub output ($) { 429 for (split /(\n)/, shift) { 430 if ($_ eq "\n") { 431 if ($LINE) { 432 print OUT wrap('', '', $LINE); 433 $LINE = ''; 434 } 435 if (($NEWLINE) < 2) { 436 print OUT; 437 $NEWLINE++; 438 } 439 } 440 elsif (/\S/ && length) { 441 $LINE .= $_; 442 $NEWLINE = 0; 443 } 444 } 445} 446 447# End of original buildtoc. From here on are routines to generate new sections 448# for and inplace edit other files 449 450sub generate_perlpod { 451 my @output; 452 my $maxlength = 0; 453 foreach (@Master) { 454 my $flags = $_->[0]; 455 next if $flags->{aux}; 456 457 if (@$_ == 2) { 458 # Heading 459 push @output, "=head2 $_->[1]\n"; 460 } elsif (@$_ == 3) { 461 # Section 462 my $start = " " x (4 + $flags->{indent}) . $_->[1]; 463 $maxlength = length $start if length ($start) > $maxlength; 464 push @output, [$start, $_->[2]]; 465 } elsif (@$_ == 0) { 466 # blank line 467 push @output, "\n"; 468 } else { 469 die "$0: Illegal length " . scalar @$_; 470 } 471 } 472 # want at least 2 spaces padding 473 $maxlength += 2; 474 $maxlength = ($maxlength + 3) & ~3; 475 # sprintf gives $1.....$2 where ... are spaces: 476 return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_} 477 @output); 478} 479 480 481sub generate_manifest { 482 # Annyoingly unexpand doesn't consider it good form to replace a single 483 # space before a tab with a tab 484 # Annoyingly (2) it returns read only values. 485 my @temp = unexpand (map {sprintf "%-32s%s\n", @$_} @_); 486 map {s/ \t/\t\t/g; $_} @temp; 487} 488sub generate_manifest_pod { 489 generate_manifest map {["pod/$_.pod", $Pods{$_}]} sort keys %Pods; 490} 491sub generate_manifest_readme { 492 generate_manifest map {["README.$_", $Readmes{$_}]} sort keys %Readmes; 493} 494 495sub generate_roffitall { 496 (map ({"\t\$maindir/$_.1\t\\"}sort keys %Pods), 497 "\t\t\\", 498 map ({"\t\$maindir/$_.1\t\\"}sort keys %Aux), 499 "\t\t\\", 500 map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata), 501 "\t\t\\", 502 map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules), 503 ) 504} 505 506sub generate_descrip_mms_1 { 507 local $Text::Wrap::columns = 150; 508 my $count = 0; 509 my @lines = map {"pod" . $count++ . " = $_"} 510 split /\n/, wrap('', '', join " ", map "[.lib.pod]$_.pod", 511 sort keys %Pods, keys %Readmepods); 512 @lines, "pod = " . join ' ', map {"\$(pod$_)"} 0 .. $count - 1; 513} 514 515sub generate_descrip_mms_2 { 516 map {sprintf <<'SNIP', $_, $_ eq 'perlvms' ? 'vms' : 'pod', $_} 517[.lib.pod]%s.pod : [.%s]%s.pod 518 @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] 519 Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod] 520SNIP 521 sort keys %Pods, keys %Readmepods; 522} 523 524sub generate_nmake_1 { 525 map {sprintf "\tcopy ..\\README.%-8s .\\perl$_.pod\n", $_} 526 sort keys %Readmes; 527} 528 529# This doesn't have a trailing newline 530sub generate_nmake_2 { 531 # Spot the special case 532 local $Text::Wrap::columns = 76; 533 my $line = wrap ("\t ", "\t ", 534 join " ", sort map {"perl$_.pod"} "vms", keys %Readmes); 535 $line =~ s/$/ \\/mg; 536 $line; 537} 538 539sub generate_pod_mak { 540 my $variable = shift; 541 my @lines; 542 my $line = join "\\\n", "\U$variable = ", 543 map {"\t$_.$variable\t"} sort keys %Pods; 544 # Special case 545 $line =~ s/.*perltoc.html.*\n//m; 546 $line; 547} 548 549sub do_manifest { 550 my $name = shift; 551 my @manifest = 552 grep {! m!^pod/[^.]+\.pod.*\n!} 553 grep {! m!^README\.(\S+)! || $Ignore{$1}} @_; 554 # Dictionary order - fold and handle non-word chars as nothing 555 map { $_->[0] } 556 sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] } 557 map { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] } 558 @manifest, 559 &generate_manifest_pod(), 560 &generate_manifest_readme(); 561} 562 563sub do_nmake { 564 my $name = shift; 565 my $makefile = join '', @_; 566 die "$0: $name contains NUL bytes" if $makefile =~ /\0/; 567 $makefile =~ s/^\tcopy \.\.\\README.*\n/\0/gm; 568 my $sections = () = $makefile =~ m/\0+/g; 569 die "$0: $name contains no README copies" if $sections < 1; 570 die "$0: $name contains discontiguous README copies" if $sections > 1; 571 $makefile =~ s/\0+/join "", &generate_nmake_1/se; 572 573 $makefile =~ s{(cd \$\(PODDIR\) && del /f [^\n]+).*?(pod2html)} 574 {"$1\n" . &generate_nmake_2."\n\t $2"}se; 575 $makefile; 576} 577 578# shut up used only once warning 579*do_dmake = *do_dmake = \&do_nmake; 580 581sub do_perlpod { 582 my $name = shift; 583 my $pod = join '', @_; 584 585 unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n) 586 (?:\s+[a-z]{4,}.*\n # fooo 587 |=head.*\n # =head foo 588 |\s*\n # blank line 589 )+ 590 } 591 {$1 . join "", &generate_perlpod}mxe) { 592 die "$0: Failed to insert ammendments in do_perlpod"; 593 } 594 $pod; 595} 596 597sub do_podmak { 598 my $name = shift; 599 my $body = join '', @_; 600 foreach my $variable qw(pod man html tex) { 601 die "$0: could not find $variable in $name" 602 unless $body =~ s{\n\U$variable\E = (?:[^\n]*\\\n)*[^\n]*} 603 {"\n" . generate_pod_mak ($variable)}se; 604 } 605 $body; 606} 607 608sub do_vms { 609 my $name = shift; 610 my $makefile = join '', @_; 611 die "$0: $name contains NUL bytes" if $makefile =~ /\0/; 612 $makefile =~ s/\npod\d* =[^\n]*/\0/gs; 613 my $sections = () = $makefile =~ m/\0+/g; 614 die "$0: $name contains no pod assignments" if $sections < 1; 615 die "$0: $name contains $sections discontigous pod assignments" 616 if $sections > 1; 617 $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_1/se; 618 619 die "$0: $name contains NUL bytes" if $makefile =~ /\0/; 620 621# Looking for rules like this 622# [.lib.pod]perl.pod : [.pod]perl.pod 623# @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod] 624# Copy/NoConfirm/Log $(MMS$SOURCE) [.lib.pod] 625 626 $makefile =~ s/\n\Q[.lib.pod]\Eperl[^\n\.]*\.pod[^\n]+\n 627 [^\n]+\n # Another line 628 [^\n]+\Q[.lib.pod]\E\n # ends [.lib.pod] 629 /\0/gsx; 630 $sections = () = $makefile =~ m/\0+/g; 631 die "$0: $name contains no copy rules" if $sections < 1; 632 die "$0: $name contains $sections discontigous copy rules" 633 if $sections > 1; 634 $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_2/se; 635 $makefile; 636} 637 638# Do stuff 639 640my $built; 641while (my ($target, $name) = each %Targets) { 642 next unless $Build{$target}; 643 $built++; 644 if ($target eq "toc") { 645 &output_perltoc; 646 next; 647 } 648 print "Now processing $name\n" if $Verbose; 649 open THING, $name or die "Can't open $name: $!"; 650 my @orig = <THING>; 651 my $orig = join '', @orig; 652 close THING; 653 my @new = do { 654 no strict 'refs'; 655 &{"do_$target"}($target, @orig); 656 }; 657 my $new = join '', @new; 658 if ($new eq $orig) { 659 print "Was not modified\n" if $Verbose; 660 next; 661 } 662 rename $name, "$name.old" or die "$0: Can't rename $name to $name.old: $!"; 663 open THING, ">$name" or die "$0: Can't open $name for writing: $!"; 664 print THING $new or die "$0: print to $name failed: $!"; 665 close THING or die die "$0: close $name failed: $!"; 666} 667 668warn "$0: was not instructed to build anything\n" unless $built; 669