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