This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix two bugs related to pod files outside of pod/
[perl5.git] / pod / buildtoc
1 #!/usr/bin/perl -w
2
3 use strict;
4 use vars qw(%Found $Quiet %Lengths %MD5s);
5 use File::Spec;
6 use File::Find;
7 use FindBin;
8 use Text::Wrap;
9 use Getopt::Long;
10 use Digest::MD5 'md5';
11
12 no locale;
13
14 # Assumption is that we're either already being run from the top level (*nix,
15 # VMS), or have absolute paths in @INC (Win32, pod/Makefile)
16 BEGIN {
17   my $Top = File::Spec->catdir($FindBin::Bin, File::Spec->updir);
18   chdir $Top or die "Can't chdir to $Top: $!";
19   require 'Porting/pod_lib.pl';
20 }
21
22 die "$0: Usage: $0 [--quiet]\n"
23     unless GetOptions (quiet => \$Quiet) && !@ARGV;
24
25 my $state = get_pod_metadata(0, 'pod/perltoc.pod');
26
27 warn @{$state->{inconsistent}} if @{$state->{inconsistent}};
28
29 # Find all the modules
30 my @modpods;
31 find(sub {
32     if (/\.p(od|m)$/) {
33       my $file = $File::Find::name;
34       return if $file =~ qr!/Pod/Functions.pm\z!; # Used only by pod itself
35       return if $file =~ m!(?:^|/)t/!;
36       return if $file =~ m!lib/Attribute/Handlers/demo/!;
37       return if $file =~ m!lib/Net/FTP/.+\.pm!; # Hi, Graham! :-)
38       return if $file =~ m!lib/Math/BigInt/t/!;
39       return if $file =~ m!/Devel/PPPort/[Hh]arness|lib/Devel/Harness!i;
40       return if $file =~ m!XS/(?:APItest|Typemap)!;
41       my $pod = $file;
42       return if $pod =~ s/pm$/pod/ && -e $pod;
43       unless (open my $f, '<', $_) {
44         warn "$0: bogus <$file>: $!";
45         system "ls", "-l", $file;
46       }
47       else {
48         my $line;
49         while ($line = <$f>) {
50           if ($line =~ /^=head1\s+NAME\b/) {
51             push @modpods, $file;
52             return;
53           }
54         }
55         warn "$0: NOTE: cannot find '=head1 NAME' in:\n  $file\n" unless $Quiet;
56       }
57     }
58   }, 'lib');
59
60 my_die "Can't find any pods!\n" unless @modpods;
61
62 my %done;
63 for (@modpods) {
64     my $name = $_;
65     $name =~ s/\.p(m|od)$//;
66     $name =~ s-\Alib/--;
67     $name =~ s-/-::-g;
68     next if $done{$name}++;
69
70     $Found{$name =~ /^[a-z]/ ? 'PRAGMA' : 'MODULE'}{$name} = $_;
71 }
72
73 # Accumulating everything into a lexical before writing to disk dates from the
74 # time when this script also provided the functionality of regen/pod_rules.pl
75 # and this code was in a subroutine do_toc(). In turn, the use of a file scoped
76 # lexical instead of a parameter or return value is because the code dates back
77 # further still, and used *only* to create pod/perltoc.pod by printing direct
78
79 my $OUT;
80
81 ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;
82
83         # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
84         # This file is autogenerated by buildtoc from all the other pods.
85         # Edit those files and run $0 to effect changes.
86
87         =head1 NAME
88
89         perltoc - perl documentation table of contents
90
91         =head1 DESCRIPTION
92
93         This page provides a brief table of contents for the rest of the Perl
94         documentation set.  It is meant to be scanned quickly or grepped
95         through to locate the proper section you're looking for.
96
97         =head1 BASIC DOCUMENTATION
98
99 EOPOD2B
100
101 # All the things in the master list that happen to be pod filenames
102 foreach (grep {defined $_ && @$_ == 5 && !$_->[0]{toc_omit}} @{$state->{master}}) {
103     podset($_->[4], $_->[2], $_->[1] ne $_->[4]);
104 }
105
106 foreach my $type (qw(PRAGMA MODULE)) {
107     ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;
108
109
110
111         =head1 $type DOCUMENTATION
112
113 EOPOD2B
114
115     foreach my $name (sort keys %{$Found{$type}}) {
116         podset($name, $Found{$type}{$name});
117     }
118 }
119
120 $_= <<"EOPOD2B";
121
122
123         =head1 AUXILIARY DOCUMENTATION
124
125         Here should be listed all the extra programs' documentation, but they
126         don't all have manual pages yet:
127
128         =over 4
129
130 EOPOD2B
131
132 $_ .=  join "\n", map {"\t=item $_\n"} sort keys %{$state->{aux}};
133 $_ .= <<"EOPOD2B" ;
134
135         =back
136
137         =head1 AUTHOR
138
139         Larry Wall <F<larry\@wall.org>>, with the help of oodles
140         of other folks.
141
142
143 EOPOD2B
144
145 s/^\t//gm;
146 $OUT .= "$_\n";
147
148 $OUT =~ s/\n\s+\n/\n\n/gs;
149 $OUT =~ s/\n{3,}/\n\n/g;
150
151 $OUT =~ s/([^\n]+)/wrap('', '', $1)/ge;
152
153 write_or_die('pod/perltoc.pod', $OUT);
154
155 exit(0);
156
157 # Below are all the auxiliary routines for generating perltoc.pod
158
159 my ($inhead1, $inhead2, $initem);
160
161 sub podset {
162     my ($pod, $file, $possibly_duplicated) = @_;
163
164     local $/ = '';
165
166     open my $fh, '<', $file or my_die "Can't open file '$file' for $pod: $!";
167     if ($possibly_duplicated) {
168         # We are a dual-life perl*.pod file, which will have be copied to lib/
169         # by the build process, and hence also found there.
170         ++$Lengths{-s $file};
171         ++$MD5s{md5(slurp_or_die($file))};
172     } elsif (!defined $possibly_duplicated) {
173         # We are a file in lib. Are we a duplicate?
174         # Don't bother calculating the MD5 if there's no intersting file of this
175         # length.
176         return if $Lengths{-s $file} && $MD5s{md5(slurp_or_die($file))};
177     }
178
179     while(<$fh>) {
180         tr/\015//d;
181         if (s/^=head1 (NAME)\s*/=head2 /) {
182             unhead1();
183             $OUT .= "\n\n=head2 ";
184             $_ = <$fh>;
185             # Remove svn keyword expansions from the Perl FAQ
186             s/ \(\$Revision: \d+ \$\)//g;
187             if ( /^\s*\Q$pod\E\b/ ) {
188                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
189             } else {
190                 s/^/$pod, /;
191             }
192         }
193         elsif (s/^=head1 (.*)/=item $1/) {
194             unhead2();
195             $OUT .= "=over 4\n\n" unless $inhead1;
196             $inhead1 = 1;
197             $_ .= "\n";
198         }
199         elsif (s/^=head2 (.*)/=item $1/) {
200             unitem();
201             $OUT .= "=over 4\n\n" unless $inhead2;
202             $inhead2 = 1;
203             $_ .= "\n";
204         }
205         elsif (s/^=item ([^=].*)/$1/) {
206             next if $pod eq 'perldiag';
207             s/^\s*\*\s*$// && next;
208             s/^\s*\*\s*//;
209             s/\n/ /g;
210             s/\s+$//;
211             next if /^[\d.]+$/;
212             next if $pod eq 'perlmodlib' && /^ftp:/;
213             $OUT .= ", " if $initem;
214             $initem = 1;
215             s/\.$//;
216             s/^-X\b/-I<X>/;
217         }
218         else {
219             unhead1() if /^=cut\s*\n/;
220             next;
221         }
222         $OUT .= $_;
223     }
224 }
225
226 sub unhead1 {
227     unhead2();
228     if ($inhead1) {
229         $OUT .= "\n\n=back\n\n";
230     }
231     $inhead1 = 0;
232 }
233
234 sub unhead2 {
235     unitem();
236     if ($inhead2) {
237         $OUT .= "\n\n=back\n\n";
238     }
239     $inhead2 = 0;
240 }
241
242 sub unitem {
243     if ($initem) {
244         $OUT .= "\n\n";
245     }
246     $initem = 0;
247 }
248
249 # Code added in commit 416302502f485afa, but never used.
250 # Probably roffitall should become something that buildtoc generates, instead
251 # of something that we ship in the distribution.
252
253 sub generate_roffitall {
254   (map ({"\t\$maindir/$_.1\t\\"}sort keys %{$state->{pods}}),
255    "\t\t\\",
256    map ({"\t\$maindir/$_.1\t\\"}sort keys %{$state->{aux}}),
257    "\t\t\\",
258    map ({"\t\$libdir/$_.3\t\\"}sort keys %{$Found{PRAGMA}}),
259    "\t\t\\",
260    map ({"\t\$libdir/$_.3\t\\"}sort keys %{$Found{MODULE}}),
261   )
262 }