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