This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
OS/400 PASE port
[perl5.git] / pod / buildtoc.PL
1 #!/usr/local/bin/perl
2
3 use Config;
4 use File::Basename qw(&basename &dirname);
5 use Cwd;
6
7 # List explicitly here the variables you want Configure to
8 # generate.  Metaconfig only looks for shell variables, so you
9 # have to mention them as if they were shell variables, not
10 # %Config entries.  Thus you write
11 #  $startperl
12 # to ensure Configure will look for $Config{startperl}.
13
14 # This forces PL files to create target in same directory as PL file.
15 # This is so that make depend always knows where to find PL derivatives.
16 $origdir = cwd;
17 chdir(dirname($0));
18 ($file = basename($0)) =~ s/\.PL$//;
19 $file =~ s/\.pl$// if ($^O eq 'os2' or $^O eq 'dos');  # "case-forgiving"
20 $file =~ s/\.pl$/.com/ if ($^O eq 'VMS');              # "case-forgiving"
21
22 open OUT,">$file" or die "Can't create $file: $!";
23
24 print "Extracting $file (with variable substitutions)\n";
25
26 # In this section, perl variables will be expanded during extraction.
27 # You can use $Config{...} to use Configure variables.
28
29 print OUT <<"!GROK!THIS!";
30 $Config{'startperl'}
31     eval 'exec perl -S \$0 "\$@"'
32         if 0;
33 !GROK!THIS!
34
35 # In the following, perl variables are not expanded during extraction.
36
37 print OUT <<'!NO!SUBS!';
38
39 #
40 # buildtoc
41 #
42 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
43 # This file is autogenerated by buildtoc.PL.
44 # Edit that file and run it to effect changes.
45 #
46 # Builds perltoc.pod and sanity checks the list of pods against all
47 # of the MANIFEST, perl.pod, and ourselves.
48 #
49
50 use File::Find;
51 use Cwd;
52 use Text::Wrap;
53
54 @PODS = glob("*.pod");
55
56 sub output ($);
57
58 if (-d "pod") {
59   die "$0: failed to chdir('pod'): $!\n" unless chdir("pod");
60 }
61
62 @ARCHPODS = qw(
63     perlaix     
64     perlapollo
65     perlamiga          
66     perlbeos
67     perlbs2000
68     perlce
69     perlcygwin          
70     perldgux             
71     perldos             
72     perlepoc             
73     perlfreebsd             
74     perlhpux            
75     perlhurd            
76     perlirix            
77     perlmachten         
78     perlmacos
79     perlmint
80     perlmpeix
81     perlnetware             
82     perlos2             
83     perlos390           
84     perlos400           
85     perlqnx
86     perlplan9
87     perlsolaris
88     perltru64
89     perluts
90     perlvmesa
91     perlvms             
92     perlvos             
93     perlwin32           
94           );
95
96 @CJKPODS = qw(
97     perlcn
98     perljp
99     perlko
100     perltw
101           );
102
103 @pods = 
104   (
105     qw(
106
107     perl
108     perlintro
109     perlfaq
110     perltoc
111     perlbook
112
113     perlsyn
114     perldata
115     perlop
116     perlsub
117     perlfunc
118     perlreftut
119     perldsc
120     perlrequick
121     perlpod
122     perlpodspec
123     perlstyle
124     perltrap
125
126     perlrun
127     perldiag
128     perllexwarn
129     perldebtut
130     perldebug
131
132     perlvar
133     perllol
134     perlopentut
135     perlpacktut
136     perlretut
137
138     perlre
139     perlref
140
141     perlform
142
143     perlboot
144     perltoot
145     perltooc
146     perlobj
147     perlbot
148     perltie
149
150     perlipc
151     perlfork
152     perlnumber
153
154     perlthrtut
155     perlothrtut
156
157     perlport
158     perllocale
159     perluniintro
160     perlunicode
161     perlebcdic
162
163     perlsec
164
165     perlmod
166     perlmodinstall
167     perlmodlib
168     perlmodstyle
169     perlnewmod
170
171     perlfaq1            
172     perlfaq2            
173     perlfaq3            
174     perlfaq4            
175     perlfaq5            
176     perlfaq6            
177     perlfaq7            
178     perlfaq8            
179     perlfaq9            
180
181     perlcompile        
182
183     perlembed          
184     perldebguts         
185     perlxstut           
186     perlxs              
187     perlclib            
188     perlguts            
189     perlcall            
190     perlutil            
191     perlfilter          
192     perldbmfilter       
193     perlapi             
194     perlintern          
195     perliol            
196     perlapio            
197     perltodo            
198     perlhack            
199
200     perlhist           
201     perldelta           
202     perl572delta         
203     perl571delta         
204     perl570delta         
205     perl561delta         
206     perl56delta         
207     perl5005delta       
208     perl5004delta       
209
210     ),
211
212     @ARCHPODS,
213
214   );
215
216 for (@ARCHPODS) { s/$/.pod/ }
217 @ARCHPODS{@ARCHPODS} = ();
218
219 for (@CJKPODS) { s/$/.pod/ }
220 @CJKPODS{@CJKPODS} = ();
221
222 for (@pods) { s/$/.pod/ }
223 @pods{@pods} = ();
224 @PODS{@PODS} = ();
225
226 open(MANI, "../MANIFEST") || die "$0: opening ../MANIFEST failed: $!";
227 while (<MANI>) {
228   if (m!^pod/([^.]+\.pod)\s+!i) {
229      push @MANIPODS, $1;
230   }
231 }
232 close(MANI);
233 @MANIPODS{@MANIPODS} = ();
234
235 open(PERLPOD, "perl.pod") || die "$0: opening perl.pod failed: $!\n";
236 while (<PERLPOD>) {
237   if (/^For ease of access, /../^\(If you're intending /) {
238         if (/^\s+(perl\S*)\s+\w/) {
239                 push @PERLPODS, "$1.pod";
240         }
241   }
242 }
243 close(PERLPOD);
244 die "$0: could not find the pod listing of perl.pod\n"
245   unless @PERLPODS;
246 @PERLPODS{@PERLPODS} = ();
247
248 # Delete the CJK because we cannot mix their encodings.
249 delete @PERLPODS{@CJKPODS};
250 delete @PODS{@CJKPODS};
251 delete @pods{@CJKPODS};
252
253 # Cross-check against ourselves
254 # Cross-check against the MANIFEST
255 # Cross-check against the perl.pod
256
257 foreach my $i (sort keys %PODS) {
258   warn "$0: $i exists but is unknown by buildtoc\n"
259         unless exists $pods{$i};
260   warn "$0: $i exists but is unknown by ../MANIFEST\n"
261         if !exists $MANIPODS{$i} && !exists $ARCHPODS{$i} && !exists $CJKPODS{$i};
262   warn "$0: $i exists but is unknown by perl.pod\n"
263         unless exists $PERLPODS{$i};
264 }
265 foreach my $i (sort keys %pods) {
266   warn "$0: $i is known by buildtoc but does not exist\n"
267         unless exists $PODS{$i};
268 }
269 foreach my $i (sort keys %MANIPODS) {
270   warn "$0: $i is known by ../MANIFEST but does not exist\n"
271         unless exists $PODS{$i};
272 }
273 foreach my $i (sort keys %PERLPODS) {
274   warn "$0: $i is known by perl.pod but does not exist\n"
275         unless exists $PODS{$i};
276 }
277
278 # We are ready to rock.
279 open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!";
280
281 $/ = '';
282 @ARGV = @pods;
283
284 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
285
286         =head1 NAME
287
288         perltoc - perl documentation table of contents
289
290         =head1 DESCRIPTION
291
292         This page provides a brief table of contents for the rest of the Perl
293         documentation set.  It is meant to be scanned quickly or grepped
294         through to locate the proper section you're looking for.
295
296         =head1 BASIC DOCUMENTATION
297
298 EOPOD2B
299 #' make emacs happy
300
301 podset(@pods);
302
303 find \&getpods => qw(../lib ../ext);
304
305 sub getpods {
306     if (/\.p(od|m)$/) {
307         my $file = $File::Find::name;
308         return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
309         return if $file =~ m!lib/Attribute/Handlers/demo/!;
310         return if $file =~ m!lib/Net/FTP/.+\.pm!; # Hi, Graham! :-)
311         return if $file =~ m!lib/Math/BigInt/t/!;
312         return if $file =~ m!/Devel/PPPort/[Hh]arness|lib/Devel/Harness!i;
313         return if $file =~ m!XS/(?:APItest|Typemap)!;
314         die "tut $name" if $file =~ /TUT/;
315         unless (open (F, "< $_\0")) {
316             warn "bogus <$file>: $!";
317             system "ls", "-l", $file;
318         }
319         else {
320             my $line;
321             while ($line = <F>) {
322                 if ($line =~ /^=head1\s+NAME\b/) {
323                     push @modpods, $file;
324                     #warn "GOOD $file\n";
325                     return;
326                 }
327             }
328             warn "$0: $file: cannot find =head1 NAME\n";
329         }
330     }
331 }
332
333 die "no pods" unless @modpods;
334
335 for (@modpods) {
336     #($name) = /(\w+)\.p(m|od)$/;
337     $name = path2modname($_);
338     if ($name =~ /^[a-z]/) {
339         push @pragmata, $_;
340     } else {
341         if ($done{$name}++) {
342             # warn "already did $_\n";
343             next;
344         }
345         push @modules, $_;
346         push @modname, $name;
347     }
348 }
349
350 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
351
352
353
354         =head1 PRAGMA DOCUMENTATION
355
356 EOPOD2B
357
358 podset(sort @pragmata);
359
360 ($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
361
362
363
364         =head1 MODULE DOCUMENTATION
365
366 EOPOD2B
367
368 podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
369
370 ($_= <<EOPOD2B) =~ s/^\t//gm;
371
372
373         =head1 AUXILIARY DOCUMENTATION
374
375         Here should be listed all the extra programs' documentation, but they
376         don't all have manual pages yet:
377
378         =over 4
379
380         =item a2p
381
382         =item s2p
383
384         =item find2perl
385
386         =item h2ph
387
388         =item c2ph
389
390         =item h2xs
391
392         =item xsubpp
393
394         =item pod2man
395
396         =item wrapsuid
397
398         =back
399
400         =head1 AUTHOR
401
402         Larry Wall <F<larry\@wall.org>>, with the help of oodles
403         of other folks.
404
405
406 EOPOD2B
407 output $_;
408 output "\n";                    # flush $LINE
409 exit;
410
411 sub podset {
412     local @ARGV = @_;
413
414     while(<>) {
415         if (s/^=head1 (NAME)\s*/=head2 /) {
416             $pod = path2modname($ARGV);
417             unhead1();
418             output "\n \n\n=head2 ";
419             $_ = <>;
420             if ( /^\s*$pod\b/ ) {
421                 s/$pod\.pm/$pod/;       # '.pm' in NAME !?
422                 output $_;
423             } else {
424                 s/^/$pod, /;
425                 output $_;
426             }
427             next;
428         }
429         if (s/^=head1 (.*)/=item $1/) {
430             unhead2();
431             output "=over 4\n\n" unless $inhead1;
432             $inhead1 = 1;
433             output $_; nl(); next;
434         }
435         if (s/^=head2 (.*)/=item $1/) {
436             unitem();
437             output "=over 4\n\n" unless $inhead2;
438             $inhead2 = 1;
439             output $_; nl(); next;
440         }
441         if (s/^=item ([^=].*)/$1/) {
442             next if $pod eq 'perldiag';
443             s/^\s*\*\s*$// && next;
444             s/^\s*\*\s*//;
445             s/\n/ /g;
446             s/\s+$//;
447             next if /^[\d.]+$/;
448             next if $pod eq 'perlmodlib' && /^ftp:/;
449             ##print "=over 4\n\n" unless $initem;
450             output ", " if $initem;
451             $initem = 1;
452             s/\.$//;
453             s/^-X\b/-I<X>/;
454             output $_; next;
455         }
456         if (s/^=cut\s*\n//) {
457             unhead1();
458             next;
459         }
460     }
461 }
462
463 sub path2modname {
464     local $_ = shift;
465     s/\.p(m|od)$//;
466     s-.*?/(lib|ext)/--;
467     s-/-::-g;
468     s/(\w+)::\1/$1/;
469     return $_;
470 }
471
472 sub unhead1 {
473     unhead2();
474     if ($inhead1) {
475         output "\n\n=back\n\n";
476     }
477     $inhead1 = 0;
478 }
479
480 sub unhead2 {
481     unitem();
482     if ($inhead2) {
483         output "\n\n=back\n\n";
484     }
485     $inhead2 = 0;
486 }
487
488 sub unitem {
489     if ($initem) {
490         output "\n\n";
491         ##print "\n\n=back\n\n";
492     }
493     $initem = 0;
494 }
495
496 sub nl {
497     output "\n";
498 }
499
500 my $NEWLINE;    # how many newlines have we seen recently
501 my $LINE;       # what remains to be printed
502
503 sub output ($) {
504     for (split /(\n)/, shift) {
505         if ($_ eq "\n") {
506             if ($LINE) {
507                 print OUT wrap('', '', $LINE);
508                 $LINE = '';
509             }
510             if ($NEWLINE < 2) {
511                 print OUT;
512                 $NEWLINE++;
513             }
514         }
515         elsif (/\S/ && length) {
516             $LINE .= $_;
517             $NEWLINE = 0;
518         }
519     }
520 }
521
522 !NO!SUBS!
523
524 close OUT or die "Can't close $file: $!";
525 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
526 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
527 chdir $origdir;