This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Refactor buildtoc's use of File::Find::find() to converge with installman's.
[perl5.git] / pod / buildtoc
1 #!/usr/bin/perl -w
2
3 use strict;
4 use vars qw(%Found $Quiet);
5 use File::Spec;
6 use File::Find;
7 use FindBin;
8 use Text::Wrap;
9 use Getopt::Long;
10
11 no locale;
12
13 # Assumption is that we're either already being run from the top level (*nix,
14 # VMS), or have absolute paths in @INC (Win32, pod/Makefile)
15 BEGIN {
16   my $Top = File::Spec->catdir($FindBin::Bin, File::Spec->updir);
17   chdir $Top or die "Can't chdir to $Top: $!";
18   require 'Porting/pod_lib.pl';
19 }
20
21 die "$0: Usage: $0 [--quiet]\n"
22     unless GetOptions (quiet => \$Quiet) && !@ARGV;
23
24 my $state = get_pod_metadata(0, sub { warn @_ if @_ }, 'pod/perltoc.pod');
25
26 # Find all the modules
27 # manpages not to be installed
28 my %do_not_install = map { ($_ => 1) }
29     qw(Pod::Functions XS::APItest XS::Typemap);
30
31 my %done;
32 find({no_chdir => 1,
33       wanted => sub {
34           if (/\.p(od|m)$/) {
35               return if m!(?:^|/)t/!;
36               return if m!lib/Net/FTP/.+\.pm!; # Hi, Graham! :-)
37               return if s!\.pm\z!.pod! && -e $_;
38               s!\.pod\z!!;
39               s!\Alib/!!;
40               s!/!::!g;
41               my_die("Duplicate files for $_, '$done{$_}' and '$File::Find::name'")
42                   if exists $done{$_};
43               $done{$_} = $File::Find::name;
44
45               return if $do_not_install{$_};
46               return if is_duplicate_pod($File::Find::name);
47
48               $Found{/\A[a-z]/ ? 'PRAGMA' : 'MODULE'}{$_} = $File::Find::name;
49           }
50       }}, 'lib');
51
52 my_die "Can't find any pods!\n" unless %done;
53
54 # Accumulating everything into a lexical before writing to disk dates from the
55 # time when this script also provided the functionality of regen/pod_rules.pl
56 # and this code was in a subroutine do_toc(). In turn, the use of a file scoped
57 # lexical instead of a parameter or return value is because the code dates back
58 # further still, and used *only* to create pod/perltoc.pod by printing direct
59
60 my $OUT;
61 my $roffitall;
62
63 ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;
64
65         # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
66         # This file is autogenerated by buildtoc from all the other pods.
67         # Edit those files and run $0 to effect changes.
68
69         =head1 NAME
70
71         perltoc - perl documentation table of contents
72
73         =head1 DESCRIPTION
74
75         This page provides a brief table of contents for the rest of the Perl
76         documentation set.  It is meant to be scanned quickly or grepped
77         through to locate the proper section you're looking for.
78
79         =head1 BASIC DOCUMENTATION
80
81 EOPOD2B
82
83 # All the things in the master list that happen to be pod filenames
84 foreach (grep {!$_->[2]{toc_omit}} @{$state->{master}}) {
85     $roffitall .= "    \$mandir/$_->[0].1 \\\n";
86     podset($_->[0], $_->[1]);
87 }
88
89 foreach my $type (qw(PRAGMA MODULE)) {
90     ($_= <<"EOPOD2B") =~ s/^\t//gm and $OUT .= $_;
91
92
93
94         =head1 $type DOCUMENTATION
95
96 EOPOD2B
97
98     foreach my $name (sort keys %{$Found{$type}}) {
99         $roffitall .= "    \$libdir/$name.3 \\\n";
100         podset($name, $Found{$type}{$name});
101     }
102 }
103
104 $_= <<"EOPOD2B";
105
106
107         =head1 AUXILIARY DOCUMENTATION
108
109         Here should be listed all the extra programs' documentation, but they
110         don't all have manual pages yet:
111
112         =over 4
113
114 EOPOD2B
115
116 $_ .=  join "\n", map {"\t=item $_\n"} @{$state->{aux}};
117 $_ .= <<"EOPOD2B" ;
118
119         =back
120
121         =head1 AUTHOR
122
123         Larry Wall <F<larry\@wall.org>>, with the help of oodles
124         of other folks.
125
126
127 EOPOD2B
128
129 s/^\t//gm;
130 $OUT .= "$_\n";
131
132 $OUT =~ s/\n\s+\n/\n\n/gs;
133 $OUT =~ s/\n{3,}/\n\n/g;
134
135 $OUT =~ s/([^\n]+)/wrap('', '', $1)/ge;
136
137 write_or_die('pod/perltoc.pod', $OUT);
138
139 write_or_die('pod/roffitall', <<'EOH' . $roffitall . <<'EOT');
140 #!/bin/sh
141 #
142 # Usage: roffitall [-nroff|-psroff|-groff]
143 #
144 # Authors: Tom Christiansen, Raphael Manfredi
145
146 me=roffitall
147 tmp=.
148
149 if test -f ../config.sh; then
150         . ../config.sh
151 fi
152
153 mandir=$installman1dir
154 libdir=$installman3dir
155
156 test -d $mandir || mandir=/usr/new/man/man1
157 test -d $libdir || libdir=/usr/new/man/man3
158
159 case "$1" in
160 -nroff) cmd="nroff -man"; ext='txt';;
161 -psroff) cmd="psroff -t"; ext='ps';;
162 -groff) cmd="groff -man"; ext='ps';;
163 *)
164         echo "Usage: roffitall [-nroff|-psroff|-groff]" >&2
165         exit 1
166         ;;
167 esac
168
169 toroff=`
170         echo            \
171 EOH
172     | perl -ne 'map { -r && print "$_ " } split'`
173
174     # Bypass internal shell buffer limit -- can't use case
175     if perl -e '$a = shift; exit($a =~ m|/|)' $toroff; then
176         echo "$me: empty file list -- did you run install?" >&2
177         exit 1
178     fi
179
180     #psroff -t -man -rC1 -rD1 -rF1 > $tmp/PerlDoc.ps 2>$tmp/PerlTOC.raw
181     #nroff -man -rC1 -rD1 -rF1 > $tmp/PerlDoc.txt 2>$tmp/PerlTOC.nr.raw
182
183     # First, create the raw data
184     run="$cmd -rC1 -rD1 -rF1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw"
185     echo "$me: running $run"
186     eval $run $toroff
187
188     #Now create the TOC
189     echo "$me: parsing TOC"
190     perl rofftoc $tmp/PerlTOC.$ext.raw > $tmp/PerlTOC.tmp.man
191     run="$cmd $tmp/PerlTOC.tmp.man >$tmp/PerlTOC.$ext"
192     echo "$me: running $run"
193     eval $run
194
195     # Finally, recreate the Doc, without the blank page 0
196     run="$cmd -rC1 -rD1 >$tmp/PerlDoc.$ext 2>$tmp/PerlTOC.$ext.raw"
197     echo "$me: running $run"
198     eval $run $toroff
199     rm -f $tmp/PerlTOC.tmp.man $tmp/PerlTOC.$ext.raw
200     echo "$me: leaving you with $tmp/PerlDoc.$ext and $tmp/PerlTOC.$ext"
201 EOT
202
203 exit(0);
204
205 # Below are all the auxiliary routines for generating perltoc.pod
206
207 my ($inhead1, $inhead2, $initem);
208
209 sub podset {
210     my ($pod, $file) = @_;
211
212     open my $fh, '<', $file or my_die "Can't open file '$file' for $pod: $!";
213
214     local *_;
215     my $found_pod;
216     while (<$fh>) {
217         if (/^=head1\s+NAME\b/) {
218             ++$found_pod;
219             last;
220         }
221     }
222
223     unless ($found_pod) {
224         warn "$0: NOTE: cannot find '=head1 NAME' in:\n  $file\n" unless $Quiet;
225         return;
226     }
227
228     seek $fh, 0, 0 or my_die "Can't rewind file '$file': $!";
229     local $/ = '';
230
231     while(<$fh>) {
232         tr/\015//d;
233         if (s/^=head1 (NAME)\s*/=head2 /) {
234             unhead1();
235             $OUT .= "\n\n=head2 ";
236             $_ = <$fh>;
237             # Remove svn keyword expansions from the Perl FAQ
238             s/ \(\$Revision: \d+ \$\)//g;
239             if ( /^\s*\Q$pod\E\b/ ) {
240                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
241             } else {
242                 s/^/$pod, /;
243             }
244         }
245         elsif (s/^=head1 (.*)/=item $1/) {
246             unhead2();
247             $OUT .= "=over 4\n\n" unless $inhead1;
248             $inhead1 = 1;
249             $_ .= "\n";
250         }
251         elsif (s/^=head2 (.*)/=item $1/) {
252             unitem();
253             $OUT .= "=over 4\n\n" unless $inhead2;
254             $inhead2 = 1;
255             $_ .= "\n";
256         }
257         elsif (s/^=item ([^=].*)/$1/) {
258             next if $pod eq 'perldiag';
259             s/^\s*\*\s*$// && next;
260             s/^\s*\*\s*//;
261             s/\n/ /g;
262             s/\s+$//;
263             next if /^[\d.]+$/;
264             next if $pod eq 'perlmodlib' && /^ftp:/;
265             $OUT .= ", " if $initem;
266             $initem = 1;
267             s/\.$//;
268             s/^-X\b/-I<X>/;
269         }
270         else {
271             unhead1() if /^=cut\s*\n/;
272             next;
273         }
274         $OUT .= $_;
275     }
276 }
277
278 sub unhead1 {
279     unhead2();
280     if ($inhead1) {
281         $OUT .= "\n\n=back\n\n";
282     }
283     $inhead1 = 0;
284 }
285
286 sub unhead2 {
287     unitem();
288     if ($inhead2) {
289         $OUT .= "\n\n=back\n\n";
290     }
291     $inhead2 = 0;
292 }
293
294 sub unitem {
295     if ($initem) {
296         $OUT .= "\n\n";
297     }
298     $initem = 0;
299 }
300
301 # Local variables:
302 # cperl-indent-level: 4
303 # indent-tabs-mode: nil
304 # End:
305 #
306 # ex: set ts=8 sts=4 sw=4 et: