1#!perl -w
2use strict;
3use Pod::Simple::SimpleTree;
4
5my ($tap, $test, %Missing);
6
7BEGIN {
8    @ARGV = grep { not($_ eq '--tap' and $tap = 1) } @ARGV;
9    if ($tap) {
10        require Test::More;
11        Test::More->import;
12    }
13}
14
15my (%Kinds, %Flavor, @Types);
16my %Omit;
17
18my $p = Pod::Simple::SimpleTree->new;
19$p->accept_targets('Pod::Functions');
20my $tree = $p->parse_file(shift)->root;
21
22foreach my $TL_node (@$tree[2 .. $#$tree]) {
23    next unless $TL_node->[0] eq 'over-text';
24    my $i = 2;
25    while ($i <= $#$TL_node) {
26        if ($TL_node->[$i][0] ne 'item-text') {
27            ++$i;
28            next;
29        }
30
31        my $item_text = $TL_node->[$i][2];
32        die "Confused by $item_text at line $TL_node->[$i][1]{start_line}"
33            if ref $item_text;
34        $item_text =~ s/\s+\z//s;
35
36        if ($TL_node->[$i+1][0] ne 'for'
37           || $TL_node->[$i+1][1]{target} ne 'Pod::Functions') {
38            ++$i;
39            ++$Missing{$item_text} unless $Omit{$item_text};
40            next;
41        }
42        my $data = $TL_node->[$i+1][2];
43        die "Confused by $data at line $TL_node->[$i+1][1]{start_line}"
44            unless ref $data eq 'ARRAY';
45        my $text = $data->[2];
46        die "Confused by $text at line $TL_node->[$i+1][1]{start_line}"
47            if ref $text;
48
49        $i += 2;
50
51        if ($text =~ s/^=//) {
52            # We are in "Perl Functions by Category"
53            die "Expected a paragraph after =item at $TL_node->[$i-2][1]{start_line}"
54                unless $TL_node->[$i][0] eq 'Para';
55            my $para = $TL_node->[$i];
56            # $text is the "type" of the built-in
57            # Anything starting ! is not for inclusion in Pod::Functions
58
59            foreach my $func (@$para[2 .. $#$para]) {
60                next unless ref $func eq 'ARRAY';
61                my $c_node =
62                    $func->[0] eq 'C' && !ref $func->[2] ? $func :
63                    $func->[0] eq 'L' && ref $func->[2]
64                        && $func->[2][0] eq 'C' && !ref $func->[2][2] ? $func->[2] :
65                    die "Expected only C<> blocks in paragraph after item at $TL_node->[$i-2][1]{start_line}";
66                # Everything is plain text (ie $c_node->[2] is everything)
67                # except for C<-I<X>>. So untangle up to one level of nested <>
68                my $funcname = join '', map {
69                    ref $_ ? $_->[2] : $_
70                } @$c_node[2..$#$c_node];
71                $funcname =~ s!(q.?)//!$1/STRING/!;
72                push @{$Kinds{$text}}, $funcname;
73            }
74            if ($text =~ /^!/) {
75                ++$Omit{$_} foreach @{$Kinds{$text}};
76            } else {
77                push @Types, [$text, $item_text];
78            }
79        } else {
80            $item_text =~ s/ .*//;
81            # For now, just remove any metadata about when it was added:
82            $text =~ s/^\+\S+ //;
83            $Flavor{$item_text} = $text;
84            ++$Omit{$item_text} if $text =~ /^!/;
85        }
86    }
87}
88
89# Take the lists of functions for each type group, and invert them to get the
90# type group (or groups) for each function:
91my %Type;
92while (my ($type, $funcs) = each %Kinds) {
93    push @{$Type{$_}}, $type foreach @$funcs;
94}
95
96# We sort __SUB__ after sub, but before substr, but __PACKAGE__ after package,
97# and __END__ after END.  (We create a temporary array of two elements, where
98# the second has the underscores squeezed out, and sort on that element
99# first.)
100sub sort_funcs {
101    map { $_->[0] }
102        sort { uc $a->[1] cmp uc $b->[1]
103               || $b->[1] cmp $a->[1]
104               || $a->[0] =~ /^_/   # here $a and $b are identical when
105                                    # underscores squeezed out; so if $a
106                                    # begins with an underscore, it should
107                                    # sort after $b
108               || $a->[0] cmp $b->[0]
109             } map  { my $f = tr/_//dr; [ $_, $f ] }
110                @_;
111}
112
113if ($tap) {
114    foreach my $func (sort_funcs(keys %Flavor)) {
115       ok ( $Type{$func}, "$func is mentioned in at least one category group");
116    }
117    foreach (sort keys %Missing) {
118        # Ignore anything that looks like an alternative for a function we've
119        # already seen;
120        s!(?: [A-Z].*| \(\)|\( LIST \)| /PATTERN/.*)!!;
121        next if $Flavor{$_};
122        if (/^[_a-z]/) {
123            fail( "function '$_' has no summary for Pod::Functions" );
124        } else {
125            fail( "for Pod::Functions" );
126        }
127    }
128    foreach my $kind (sort keys %Kinds) {
129        my $funcs = $Kinds{$kind};
130        ++$test;
131        my $want = join ' ', sort_funcs(@$funcs);
132        is ("@$funcs", $want, "category $kind is correctly sorted" );
133    }
134    done_testing();
135    exit;
136}
137
138# blead will run this with miniperl, hence we can't use autodie
139my $real = 'Functions.pm';
140my $temp = "Functions.$$";
141
142END {
143    return if !defined $temp || !-e $temp;
144    unlink $temp or warn "Can't unlink '$temp': $!";
145}
146
147foreach ($real, $temp) {
148    next if !-e $_;
149    unlink $_ or die "Can't unlink '$_': $!";
150}
151
152open my $fh, '>', $temp or die "Can't open '$temp' for writing: $!";
153print $fh <<'EOT';
154package Pod::Functions;
155use strict;
156
157=head1 NAME
158
159Pod::Functions - Group Perl's functions a la perlfunc.pod
160
161=head1 SYNOPSIS
162
163    use Pod::Functions;
164
165    my @misc_ops = @{ $Kinds{ 'Misc' } };
166    my $misc_dsc = $Type_Description{ 'Misc' };
167
168or
169
170    perl /path/to/lib/Pod/Functions.pm
171
172This will print a grouped list of Perl's functions, like the
173L<perlfunc/"Perl Functions by Category"> section.
174
175=head1 DESCRIPTION
176
177It exports the following variables:
178
179=over 4
180
181=item %Kinds
182
183This holds a hash-of-lists. Each list contains the functions in the category
184the key denotes.
185
186=item %Type
187
188In this hash each key represents a function and the value is the category.
189The category can be a comma separated list.
190
191=item %Flavor
192
193In this hash each key represents a function and the value is a short
194description of that function.
195
196=item %Type_Description
197
198In this hash each key represents a category of functions and the value is
199a short description of that category.
200
201=item @Type_Order
202
203This list of categories is used to produce the same order as the
204L<perlfunc/"Perl Functions by Category"> section.
205
206=back
207
208=cut
209
210our $VERSION = '1.13';
211
212require Exporter;
213
214our @ISA = qw(Exporter);
215our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
216
217our(%Kinds, %Type, %Flavor, %Type_Description, @Type_Order);
218
219foreach (
220EOT
221
222foreach (@Types) {
223    my ($type, $desc) = @$_;
224    $type = "'$type'" if $type =~ /[^A-Za-z]/;
225    $desc =~ s!([\\'])!\\$1!g;
226    printf $fh "    [%-9s  => '%s'],\n", $type, $desc;
227}
228
229print $fh <<'EOT';
230	) {
231    push @Type_Order, $_->[0];
232    $Type_Description{$_->[0]} = $_->[1];
233};
234
235while (<DATA>) {
236    chomp;
237    s/^#.*//;
238    next unless $_;
239    my($name, @data) = split "\t", $_;
240    $Flavor{$name} = pop @data;
241    $Type{$name} = join ',', @data;
242    for my $t (@data) {
243        push @{$Kinds{$t}}, $name;
244    }
245}
246
247close DATA;
248
249my( $typedesc, $list );
250unless (caller) {
251    foreach my $type ( @Type_Order ) {
252	$list = join(", ", sort @{$Kinds{$type}});
253	$typedesc = $Type_Description{$type} . ":";
254	write;
255    }
256}
257
258format =
259
260^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
261    $typedesc
262~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
263    $typedesc
264 ~~  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
265	$list
266.
267
2681;
269
270__DATA__
271EOT
272
273foreach my $func (sort_funcs(keys %Flavor)) {
274    my $desc = $Flavor{$func};
275    die "No types listed for $func" unless $Type{$func};
276    next if $Omit{$func};
277    print $fh join("\t", $func, (sort @{$Type{$func}}), $desc), "\n";
278}
279
280close $fh or die "Can't close '$temp': $!";
281rename $temp, $real or die "Can't rename '$temp' to '$real': $!";
282