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