4 use vars qw($masterpodfile %Build %Targets $Verbose $Up %Ignore
5 @Master %Readmes %Pods %Aux %Readmepods %Pragmata %Modules);
15 $Up = File::Spec->updir;
16 $masterpodfile = File::Spec->catdir($Up, "pod.lst");
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
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"),
37 my @files = keys %Targets;
38 my $filesopts = join(" | ", map { "--build-$_" } "all", sort @files);
41 $0: Usage: $0 [--verbose] [--showfiles] $filesopts
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});
52 sort { lc $a cmp lc $b }
54 my ($v, $d, $f) = File::Spec->splitpath($_);
56 @d = defined $d ? File::Spec->splitdir($d) : ();
58 File::Spec->catfile(@d ?
59 (@d == 1 && $d[0] eq '' ? () : @d)
61 } @Targets{grep { $_ ne 'all' && $Build{$_} } keys %Build}),
67 # Don't copy these top level READMEs
76 print "I'm building $_\n" foreach grep {$Build{$_}} keys %Build;
79 chdir $FindBin::Bin or die "$0: Can't chdir $FindBin::Bin: $!";
81 open MASTER, $masterpodfile or die "$0: Can't open $masterpodfile: $!";
86 # At least one upper case letter somewhere in the first group
87 if (/^(\S+)\s(.*)/ && $1 =~ tr/A-Z//) {
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];
97 } elsif (/^(\S*)\s+(\S+)\s+(.*)/) {
99 my ($flags, $filename, $desc) = ($1, $2, $3);
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;
110 } elsif ($flags{aux}) {
111 $Aux{$filename} = $desc;
113 $Pods{$filename} = $desc;
115 die "$0: Unknown flag found in section line: $_" if length $flags;
116 push @Master, [\%flags, $filename, $desc];
120 die "$0: Malformed line: $_" if $1 =~ tr/A-Z//;
128 my (%disk_pods, @disk_pods);
129 my (@manipods, %manipods);
130 my (@manireadmes, %manireadmes);
131 my (@perlpods, %perlpods);
134 # Convert these to a list of filenames.
135 foreach (keys %Pods, keys %Readmepods) {
136 $our_pods{"$_.pod"}++;
139 # None of these filenames will be boolean false
140 @disk_pods = glob("*.pod");
141 @disk_pods{@disk_pods} = @disk_pods;
143 open(MANI, "../MANIFEST") || die "$0: opening ../MANIFEST failed: $!";
145 if (m!^pod/([^.]+\.pod)\s+!i) {
147 } elsif (m!^README\.(\S+)\s+!i) {
149 push @manireadmes, "perl$1.pod";
153 @manipods{@manipods} = @manipods;
154 @manireadmes{@manireadmes} = @manireadmes;
156 open(PERLPOD, "perl.pod") || die "$0: opening perl.pod failed: $!\n";
158 if (/^For ease of access, /../^\(If you're intending /) {
159 if (/^\s+(perl\S*)\s+\w/) {
160 push @perlpods, "$1.pod";
165 die "$0: could not find the pod listing of perl.pod\n"
167 @perlpods{@perlpods} = @perlpods;
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};
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};
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};
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};
191 # Find all the mdoules
194 find \&getpods => qw(../lib ../ext);
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;
213 while ($line = <F>) {
214 if ($line =~ /^=head1\s+NAME\b/) {
215 push @modpods, $file;
216 #warn "GOOD $file\n";
220 warn "$0: $file: cannot find =head1 NAME\n";
225 die "$0: no pods" unless @modpods;
229 #($name) = /(\w+)\.p(m|od)$/;
230 my $name = path2modname($_);
231 if ($name =~ /^[a-z]/) {
232 $Pragmata{$name} = $_;
234 if ($done{$name}++) {
235 # warn "already did $_\n";
238 $Modules{$name} = $_;
243 # OK. Now a lot of ancillay function definitions follow
244 # Main program returns at "Do stuff"
258 open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!";
262 ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
266 perltoc - perl documentation table of contents
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.
274 =head1 BASIC DOCUMENTATION
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);
283 ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
287 =head1 PRAGMA DOCUMENTATION
291 podset(sort values %Pragmata);
293 ($_= <<"EOPOD2B") =~ s/^\t//gm && output($_);
297 =head1 MODULE DOCUMENTATION
301 podset( @Modules{ sort keys %Modules } );
306 =head1 AUXILIARY DOCUMENTATION
308 Here should be listed all the extra programs' documentation, but they
309 don't all have manual pages yet:
315 $_ .= join "\n", map {"\t=item $_\n"} sort keys %Aux;
322 Larry Wall <F<larry\@wall.org>>, with the help of oodles
330 output "\n"; # flush $LINE
333 # Below are all the auxiliary routines for generating perltoc.pod
335 my ($inhead1, $inhead2, $initem);
342 if (s/^=head1 (NAME)\s*/=head2 /) {
343 $pod = path2modname($ARGV);
345 output "\n \n\n=head2 ";
347 if ( /^\s*$pod\b/ ) {
348 s/$pod\.pm/$pod/; # '.pm' in NAME !?
356 if (s/^=head1 (.*)/=item $1/) {
358 output "=over 4\n\n" unless $inhead1;
360 output $_; nl(); next;
362 if (s/^=head2 (.*)/=item $1/) {
364 output "=over 4\n\n" unless $inhead2;
366 output $_; nl(); next;
368 if (s/^=item ([^=].*)/$1/) {
369 next if $pod eq 'perldiag';
370 s/^\s*\*\s*$// && next;
375 next if $pod eq 'perlmodlib' && /^ftp:/;
376 ##print "=over 4\n\n" unless $initem;
377 output ", " if $initem;
383 if (s/^=cut\s*\n//) {
393 output "\n\n=back\n\n";
401 output "\n\n=back\n\n";
409 ##print "\n\n=back\n\n";
418 my $NEWLINE = 0; # how many newlines have we seen recently
419 my $LINE; # what remains to be printed
422 for (split /(\n)/, shift) {
425 print OUT wrap('', '', $LINE);
428 if (($NEWLINE) < 2) {
433 elsif (/\S/ && length) {
440 # End of original buildtoc. From here on are routines to generate new sections
441 # for and inplace edit other files
443 sub generate_perlpod {
448 next if $flags->{aux};
452 push @output, "=head2 $_->[1]\n";
455 my $start = " " x (4 + $flags->{indent}) . $_->[1];
456 $maxlength = length $start if length ($start) > $maxlength;
457 push @output, [$start, $_->[2]];
462 die "$0: Illegal length " . scalar @$_;
465 # want at least 2 spaces padding
467 $maxlength = ($maxlength + 3) & ~3;
468 # sprintf gives $1.....$2 where ... are spaces:
469 return unexpand (map {ref $_ ? sprintf "%-${maxlength}s%s\n", @$_ : $_}
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;
481 sub generate_manifest_pod {
482 generate_manifest map {["pod/$_.pod", $Pods{$_}]} sort keys %Pods;
484 sub generate_manifest_readme {
485 generate_manifest map {["README.$_", $Readmes{$_}]} sort keys %Readmes;
488 sub generate_roffitall {
489 (map ({"\t\$maindir/$_.1\t\\"}sort keys %Pods),
491 map ({"\t\$maindir/$_.1\t\\"}sort keys %Aux),
493 map ({"\t\$libdir/$_.3\t\\"}sort keys %Pragmata),
495 map ({"\t\$libdir/$_.3\t\\"}sort keys %Modules),
499 sub generate_descrip_mms_1 {
500 local $Text::Wrap::columns = 150;
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;
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]
514 sort keys %Pods, keys %Readmepods;
517 sub generate_nmake_1 {
518 map {sprintf "\tcopy ..\\README.%-8s .\\perl$_.pod\n", $_}
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);
532 sub generate_pod_mak {
533 my $variable = shift;
535 my $line = join "\\\n", "\U$variable = ",
536 map {"\t$_.$variable\t"} sort keys %Pods;
538 $line =~ s/.*perltoc.html.*\n//m;
545 grep {! m!^pod/[^.]+\.pod.*\n!}
546 grep {! m!^README\.(\S+)! || $Ignore{$1}} @_;
547 # Dictionary order - fold and handle non-word chars as nothing
549 sort { $a->[1] cmp $b->[1] || $a->[0] cmp $b->[0] }
550 map { my $f = lc $_; $f =~ s/[^a-z0-9\s]//g; [ $_, $f ] }
552 &generate_manifest_pod(),
553 &generate_manifest_readme();
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;
566 $makefile =~ s{(cd \$\(PODDIR\) && del /f [^\n]+).*?(pod2html)}
567 {"$1\n" . &generate_nmake_2."\n\t $2"}se;
571 # shut up used only once warning
572 *do_dmake = *do_dmake = \&do_nmake;
576 my $pod = join '', @_;
578 unless ($pod =~ s{(For\ ease\ of\ access,\ .*\n)
579 (?:\s+[a-z]{4,}.*\n # fooo
580 |=head.*\n # =head foo
584 {$1 . join "", &generate_perlpod}mxe) {
585 die "$0: Failed to insert ammendments in do_perlpod";
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;
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"
610 $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_1/se;
612 die "$0: $name contains NUL bytes" if $makefile =~ /\0/;
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]
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]
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"
627 $makefile =~ s/\0+/join "\n", '', &generate_descrip_mms_2/se;
634 while (my ($target, $name) = each %Targets) {
635 next unless $Build{$target};
637 if ($target eq "toc") {
641 print "Now processing $name\n" if $Verbose;
642 open THING, $name or die "Can't open $name: $!";
644 my $orig = join '', @orig;
648 &{"do_$target"}($target, @orig);
650 my $new = join '', @new;
652 print "Was not modified\n" if $Verbose;
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: $!";
661 warn "$0: was not instructed to build anything\n" unless $built;