[p5sagit/p5-mst-13.2.git] / pod / buildtoc.PL

#!/usr/local/bin/perl

use Config;
use File::Basename qw(&basename &dirname);
use Cwd;

# List explicitly here the variables you want Configure to
# generate.  Metaconfig only looks for shell variables, so you
# have to mention them as if they were shell variables, not
# %Config entries.  Thus you write
#  $startperl
# to ensure Configure will look for $Config{startperl}.

# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
$origdir = cwd;
chdir(dirname($0));
($file = basename($0)) =~ s/\.PL$//;
$file =~ s/\.pl$// if ($^O eq 'os2' or $^O eq 'dos');  # "case-forgiving"
$file =~ s/\.pl$/.com/ if ($^O eq 'VMS');              # "case-forgiving"

open OUT,">$file" or die "Can't create $file: $!";

print "Extracting $file (with variable substitutions)\n";

# In this section, perl variables will be expanded during extraction.
# You can use $Config{...} to use Configure variables.

print OUT <<"!GROK!THIS!";
$Config{'startperl'}
    eval 'exec perl -S \$0 "\$@"'
        if 0;
!GROK!THIS!

# In the following, perl variables are not expanded during extraction.

print OUT <<'!NO!SUBS!';

#
# buildtoc
#
# Build perltoc.pod and sanity check the list of pods against all
# of the MANIFEST, perl.pod, and ourselves.
#

use File::Find;
use Cwd;
use Text::Wrap;

@PODS = glob("*.pod");

sub output ($);

if (-d "pod") {
  die "$0: failed to chdir('pod'): $!\n" unless chdir("pod");
}

@pods = qw(
	   perl perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5
	   perlfaq6 perlfaq7 perlfaq8 perlfaq9 perldelta perldata
	   perlsyn perlop perlre perlrun perlfunc perlvar perlsub
	   perlmod perlmodlib perlmodinstall perlfork perlform perllocale 
	   perlref perlreftut perldsc
	   perllol perlboot perltoot perltootc perlobj perltie perlbot perlipc
	   perldbmfilter perldebug perlnumber perldebguts
	   perldiag perlsec perltrap perlport perlstyle perlpod perlbook
	   perlembed perlapio perlxs perlxstut perlguts perlcall perlcompile
	   perlapi perlintern perlhist
	  );

for (@pods) { s/$/.pod/ }
@pods{@pods} = ();
@PODS{@PODS} = ();

open(MANI, "../MANIFEST") || die "$0: opening ../MANIFEST failed: $!";
while (<MANI>) {
  if (m!^pod/([^.]+\.pod)\s+!i) {
     push @MANIPODS, $1;
  }
}
close(MANI);
@MANIPODS{@MANIPODS} = ();

open(PERLPOD, "perl.pod") || die "$0: opening perl.pod failed: $!\n";
while (<PERLPOD>) {
  if (/^For ease of access, /../^\(If you're intending /) {
	if (/^\s+(perl\w+)\s+Perl /) {
		push @PERLPODS, "$1.pod";
	}
  }
}
close(PERLPOD);
die "$0: could not find the pod listing of perl.pod\n"
  unless @PERLPODS;
@PERLPODS{@PERLPODS} = ();

# Cross-check against ourselves
# Cross-check against the MANIFEST
# Cross-check against the perl.pod

foreach my $i (sort keys %PODS) {
  warn "$0: $i exists but is unknown by buildtoc\n"
	unless exists $pods{$i};
  warn "$0: $i exists but is unknown by ../MANIFEST\n"
	unless exists $MANIPODS{$i};
  warn "$0: $i exists but is unknown by perl.pod\n"
	unless exists $PERLPODS{$i};
}
foreach my $i (sort keys %pods) {
  warn "$0: $i is known by buildtoc but does not exist\n"
	unless exists $PODS{$i};
}
foreach my $i (sort keys %MANIPODS) {
  warn "$0: $i is known by ../MANIFEST but does not exist\n"
	unless exists $PODS{$i};
}
foreach my $i (sort keys %PERLPODS) {
  warn "$0: $i is known by perl.pod but does not exist\n"
	unless exists $PODS{$i};
}

# We are ready to rock.
open(OUT, ">perltoc.pod") || die "$0: creating perltoc.pod failed: $!";

$/ = '';
@ARGV = @pods;

($_= <<EOPOD2B) =~ s/^\t//gm && output($_);

	=head1 NAME

	perltoc - perl documentation table of contents

	=head1 DESCRIPTION

	This page provides a brief table of contents for the rest of the Perl
	documentation set.  It is meant to be scanned quickly or grepped
	through to locate the proper section you're looking for.

	=head1 BASIC DOCUMENTATION

EOPOD2B
#' make emacs happy

podset(@pods);

find \&getpods => qw(../lib ../ext);

sub getpods {
    if (/\.p(od|m)$/) {
	# Skip .pm files that have corresponding .pod files, and Functions.pm.
	return if /(.*)\.pm$/ && -f "$1.pod";
	my $file = $File::Find::name;
	return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself

	die "tut $name" if $file =~ /TUT/;
	unless (open (F, "< $_\0")) {
	    warn "bogus <$file>: $!";
	    system "ls", "-l", $file;
	}
	else {
	    my $line;
	    while ($line = <F>) {
		if ($line =~ /^=head1\s+NAME\b/) {
		    push @modpods, $file;
		    #warn "GOOD $file\n";
		    return;
		}
	    }
	    warn "$0: $file: cannot find =head1 NAME\n";
	}
    }
}

die "no pods" unless @modpods;

for (@modpods) {
    #($name) = /(\w+)\.p(m|od)$/;
    $name = path2modname($_);
    if ($name =~ /^[a-z]/) {
	push @pragmata, $_;
    } else {
	if ($done{$name}++) {
	    # warn "already did $_\n";
	    next;
	}
	push @modules, $_;
	push @modname, $name;
    }
}

($_= <<EOPOD2B) =~ s/^\t//gm && output($_);


	=head1 PRAGMA DOCUMENTATION

EOPOD2B

podset(sort @pragmata);

($_= <<EOPOD2B) =~ s/^\t//gm && output($_);


	=head1 MODULE DOCUMENTATION

EOPOD2B

podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );

($_= <<EOPOD2B) =~ s/^\t//gm;


	=head1 AUXILIARY DOCUMENTATION

	Here should be listed all the extra programs' documentation, but they
	don't all have manual pages yet:

	=over

	=item a2p

	=item s2p

	=item find2perl

	=item h2ph

	=item c2ph

	=item h2xs

	=item xsubpp

	=item pod2man

	=item wrapsuid

	=back

	=head1 AUTHOR

	Larry Wall <F<larry\@wall.org>>, with the help of oodles
	of other folks.


EOPOD2B
output $_;
output "\n";                    # flush $LINE
exit;

sub podset {
    local @ARGV = @_;

    while(<>) {
	if (s/^=head1 (NAME)\s*/=head2 /) {
	    $pod = path2modname($ARGV);
	    unhead1();
	    output "\n \n\n=head2 ";
	    $_ = <>;
	    if ( /^\s*$pod\b/ ) {
		s/$pod\.pm/$pod/;       # '.pm' in NAME !?
		output $_;
	    } else {
		s/^/$pod, /;
		output $_;
	    }
	    next;
	}
	if (s/^=head1 (.*)/=item $1/) {
	    unhead2();
	    output "=over\n\n" unless $inhead1;
	    $inhead1 = 1;
	    output $_; nl(); next;
	}
	if (s/^=head2 (.*)/=item $1/) {
	    unitem();
	    output "=over\n\n" unless $inhead2;
	    $inhead2 = 1;
	    output $_; nl(); next;
	}
	if (s/^=item ([^=].*)/$1/) {
	    next if $pod eq 'perldiag';
	    s/^\s*\*\s*$// && next;
	    s/^\s*\*\s*//;
	    s/\n/ /g;
	    s/\s+$//;
	    next if /^[\d.]+$/;
	    next if $pod eq 'perlmodlib' && /^ftp:/;
	    ##print "=over\n\n" unless $initem;
	    output ", " if $initem;
	    $initem = 1;
	    s/\.$//;
	    s/^-X\b/-I<X>/;
	    output $_; next;
	}
	if (s/^=cut\s*\n//) {
	    unhead1();
	    next;
	}
    }
}

sub path2modname {
    local $_ = shift;
    s/\.p(m|od)$//;
    s-.*?/(lib|ext)/--;
    s-/-::-g;
    s/(\w+)::\1/$1/;
    return $_;
}

sub unhead1 {
    unhead2();
    if ($inhead1) {
	output "\n\n=back\n\n";
    }
    $inhead1 = 0;
}

sub unhead2 {
    unitem();
    if ($inhead2) {
	output "\n\n=back\n\n";
    }
    $inhead2 = 0;
}

sub unitem {
    if ($initem) {
	output "\n\n";
	##print "\n\n=back\n\n";
    }
    $initem = 0;
}

sub nl {
    output "\n";
}

my $NEWLINE;	# how many newlines have we seen recently
my $LINE;	# what remains to be printed

sub output ($) {
    for (split /(\n)/, shift) {
	if ($_ eq "\n") {
	    if ($LINE) {
		print OUT wrap('', '', $LINE);
		$LINE = '';
	    }
	    if ($NEWLINE < 2) {
		print OUT;
		$NEWLINE++;
	    }
	}
	elsif (/\S/ && length) {
	    $LINE .= $_;
	    $NEWLINE = 0;
	}
    }
}

!NO!SUBS!
Commit	Line	Data
ff45a9ac	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	# Build perltoc.pod and sanity check the list of pods against all
	43	# of the MANIFEST, perl.pod, and ourselves.
	44	#
	45
	46	use File::Find;
	47	use Cwd;
	48	use Text::Wrap;
	49
	50	@PODS = glob("*.pod");
	51
	52	sub output ($);
	53
	54	if (-d "pod") {
	55	die "$0: failed to chdir('pod'): $!\n" unless chdir("pod");
	56	}
	57
	58	@pods = qw(
	59	perl perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5
	60	perlfaq6 perlfaq7 perlfaq8 perlfaq9 perldelta perldata
	61	perlsyn perlop perlre perlrun perlfunc perlvar perlsub
	62	perlmod perlmodlib perlmodinstall perlfork perlform perllocale
	63	perlref perlreftut perldsc
	64	perllol perlboot perltoot perltootc perlobj perltie perlbot perlipc
65	perldbmfilter perldebug perlnumber perldebguts
66	perldiag perlsec perltrap perlport perlstyle perlpod perlbook
67	perlembed perlapio perlxs perlxstut perlguts perlcall perlcompile
68	perlapi perlintern perlhist
69	);
70
71	for (@pods) { s/$/.pod/ }
72	@pods{@pods} = ();
73	@PODS{@PODS} = ();
74
75	open(MANI, "../MANIFEST") \|\| die "$0: opening ../MANIFEST failed: $!";
76	while (<MANI>) {
77	if (m!^pod/([^.]+\.pod)\s+!i) {
78	push @MANIPODS, $1;
79	}
80	}
81	close(MANI);
82	@MANIPODS{@MANIPODS} = ();
83
84	open(PERLPOD, "perl.pod") \|\| die "$0: opening perl.pod failed: $!\n";
85	while (<PERLPOD>) {
86	if (/^For ease of access, /../^\(If you're intending /) {
87	if (/^\s+(perl\w+)\s+Perl /) {
88	push @PERLPODS, "$1.pod";
89	}
90	}
91	}
92	close(PERLPOD);
93	die "$0: could not find the pod listing of perl.pod\n"
94	unless @PERLPODS;
95	@PERLPODS{@PERLPODS} = ();
96
97	# Cross-check against ourselves
98	# Cross-check against the MANIFEST
99	# Cross-check against the perl.pod
100
101	foreach my $i (sort keys %PODS) {
102	warn "$0: $i exists but is unknown by buildtoc\n"
103	unless exists $pods{$i};
104	warn "$0: $i exists but is unknown by ../MANIFEST\n"
105	unless exists $MANIPODS{$i};
106	warn "$0: $i exists but is unknown by perl.pod\n"
107	unless exists $PERLPODS{$i};
108	}
109	foreach my $i (sort keys %pods) {
110	warn "$0: $i is known by buildtoc but does not exist\n"
111	unless exists $PODS{$i};
112	}
113	foreach my $i (sort keys %MANIPODS) {
114	warn "$0: $i is known by ../MANIFEST but does not exist\n"
115	unless exists $PODS{$i};
116	}
117	foreach my $i (sort keys %PERLPODS) {
118	warn "$0: $i is known by perl.pod but does not exist\n"
119	unless exists $PODS{$i};
120	}
121
122	# We are ready to rock.
123	open(OUT, ">perltoc.pod") \|\| die "$0: creating perltoc.pod failed: $!";
124
125	$/ = '';
126	@ARGV = @pods;
127
128	($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
129
130	=head1 NAME
131
132	perltoc - perl documentation table of contents
133
134	=head1 DESCRIPTION
135
136	This page provides a brief table of contents for the rest of the Perl
137	documentation set. It is meant to be scanned quickly or grepped
138	through to locate the proper section you're looking for.
139
140	=head1 BASIC DOCUMENTATION
141
142	EOPOD2B
143	#' make emacs happy
144
145	podset(@pods);
146
147	find \&getpods => qw(../lib ../ext);
148
149	sub getpods {
150	if (/\.p(od\|m)$/) {
151	# Skip .pm files that have corresponding .pod files, and Functions.pm.
152	return if /(.*)\.pm$/ && -f "$1.pod";
153	my $file = $File::Find::name;
154	return if $file eq '../lib/Pod/Functions.pm'; # Used only by pod itself
155
156	die "tut $name" if $file =~ /TUT/;
157	unless (open (F, "< $_\0")) {
158	warn "bogus <$file>: $!";
159	system "ls", "-l", $file;
160	}
161	else {
162	my $line;
163	while ($line = <F>) {
164	if ($line =~ /^=head1\s+NAME\b/) {
165	push @modpods, $file;
166	#warn "GOOD $file\n";
167	return;
168	}
169	}
170	warn "$0: $file: cannot find =head1 NAME\n";
171	}
172	}
173	}
174
175	die "no pods" unless @modpods;
176
177	for (@modpods) {
178	#($name) = /(\w+)\.p(m\|od)$/;
179	$name = path2modname($_);
180	if ($name =~ /^[a-z]/) {
181	push @pragmata, $_;
182	} else {
183	if ($done{$name}++) {
184	# warn "already did $_\n";
185	next;
186	}
187	push @modules, $_;
188	push @modname, $name;
189	}
190	}
191
192	($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
193
194
195
196	=head1 PRAGMA DOCUMENTATION
197
198	EOPOD2B
199
200	podset(sort @pragmata);
201
202	($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
203
204
205
206	=head1 MODULE DOCUMENTATION
207
208	EOPOD2B
209
210	podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
211
212	($_= <<EOPOD2B) =~ s/^\t//gm;
213
214
215	=head1 AUXILIARY DOCUMENTATION
216
217	Here should be listed all the extra programs' documentation, but they
218	don't all have manual pages yet:
219
220	=over
221
222	=item a2p
223
224	=item s2p
225
226	=item find2perl
227
228	=item h2ph
229
230	=item c2ph
231
232	=item h2xs
233
234	=item xsubpp
235
236	=item pod2man
237
238	=item wrapsuid
239
240	=back
241
242	=head1 AUTHOR
243
244	Larry Wall <F<larry\@wall.org>>, with the help of oodles
245	of other folks.
246
247
248	EOPOD2B
249	output $_;
250	output "\n"; # flush $LINE
251	exit;
252
253	sub podset {
254	local @ARGV = @_;
255
256	while(<>) {
257	if (s/^=head1 (NAME)\s*/=head2 /) {
258	$pod = path2modname($ARGV);
259	unhead1();
260	output "\n \n\n=head2 ";
261	$_ = <>;
262	if ( /^\s*$pod\b/ ) {
263	s/$pod\.pm/$pod/; # '.pm' in NAME !?
264	output $_;
265	} else {
266	s/^/$pod, /;
267	output $_;
268	}
269	next;
270	}
271	if (s/^=head1 (.*)/=item $1/) {
272	unhead2();
273	output "=over\n\n" unless $inhead1;
274	$inhead1 = 1;
275	output $_; nl(); next;
276	}
277	if (s/^=head2 (.*)/=item $1/) {
278	unitem();
279	output "=over\n\n" unless $inhead2;
280	$inhead2 = 1;
281	output $_; nl(); next;
282	}
283	if (s/^=item ([^=].*)/$1/) {
284	next if $pod eq 'perldiag';
285	s/^\s\\s*$// && next;
286	s/^\s\\s*//;
287	s/\n/ /g;
288	s/\s+$//;
289	next if /^[\d.]+$/;
290	next if $pod eq 'perlmodlib' && /^ftp:/;
291	##print "=over\n\n" unless $initem;
292	output ", " if $initem;
293	$initem = 1;
294	s/\.$//;
295	s/^-X\b/-I<X>/;
296	output $_; next;
297	}
298	if (s/^=cut\s*\n//) {
299	unhead1();
300	next;
301	}
302	}
303	}
304
305	sub path2modname {
306	local $_ = shift;
307	s/\.p(m\|od)$//;
308	s-.*?/(lib\|ext)/--;
309	s-/-::-g;
310	s/(\w+)::\1/$1/;
311	return $_;
312	}
313
314	sub unhead1 {
315	unhead2();
316	if ($inhead1) {
317	output "\n\n=back\n\n";
318	}
319	$inhead1 = 0;
320	}
321
322	sub unhead2 {
323	unitem();
324	if ($inhead2) {
325	output "\n\n=back\n\n";
326	}
327	$inhead2 = 0;
328	}
329
330	sub unitem {
331	if ($initem) {
332	output "\n\n";
333	##print "\n\n=back\n\n";
334	}
335	$initem = 0;
336	}
337
338	sub nl {
339	output "\n";
340	}
341
342	my $NEWLINE; # how many newlines have we seen recently
343	my $LINE; # what remains to be printed
344
345	sub output ($) {
346	for (split /(\n)/, shift) {
347	if ($_ eq "\n") {
348	if ($LINE) {
349	print OUT wrap('', '', $LINE);
350	$LINE = '';
351	}
352	if ($NEWLINE < 2) {
353	print OUT;
354	$NEWLINE++;
355	}
356	}
357	elsif (/\S/ && length) {
358	$LINE .= $_;
359	$NEWLINE = 0;
360	}
361	}
362	}
363
364	!NO!SUBS!
365