xref: /openbsd-src/gnu/usr.bin/perl/ext/Pod-Functions/Functions_pm.PL (revision d4741794dd2f512d997014f8bd85fbb24d935059) 
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                die "Expected only C<> blocks in paragraph after item at $TL_node->[$i-2][1]{start_line}"
62                    unless $func->[0] eq 'C' && !ref $func->[2];
63                # Everything is plain text (ie $func->[2] is everything)
64                # except for C<-I<X>>. So untangle up to one level of nested <>
65                my $funcname = join '', map {
66                    ref $_ ? $_->[2] : $_
67                } @$func[2..$#$func];
68                $funcname =~ s!(q.?)//!$1/STRING/!;
69                push @{$Kinds{$text}}, $funcname;
70            }
71            if ($text =~ /^!/) {
72                ++$Omit{$_} foreach @{$Kinds{$text}};
73            } else {
74                push @Types, [$text, $item_text];
75            }
76        } else {
77            $item_text =~ s/ .*//;
78            # For now, just remove any metadata about when it was added:
79            $text =~ s/^\+\S+ //;
80            $Flavor{$item_text} = $text;
81            ++$Omit{$item_text} if $text =~ /^!/;
82        }
83    }
84}
85
86# Take the lists of functions for each type group, and invert them to get the
87# type group (or groups) for each function:
88my %Type;
89while (my ($type, $funcs) = each %Kinds) {
90    push @{$Type{$_}}, $type foreach @$funcs;
91}
92
93# We sort __SUB__ after sub, but before substr, but __PACKAGE__ after package,
94# and __END__ after END.
95sub sort_funcs {
96    map { $_->[0] }
97        sort { uc $a->[1] cmp uc $b->[1] || $b->[1] cmp $a->[1] || $a->[0] cmp $b->[0] }
98            map  { my $f = tr/_//dr; [ $_, $f ] }
99                @_;
100}
101
102if ($tap) {
103    foreach my $func (sort_funcs(keys %Flavor)) {
104       ok ( $Type{$func}, "$func is mentioned in at least one category group");
105    }
106    foreach (sort keys %Missing) {
107        # Ignore anything that looks like an alternative for a function we've
108        # already seen;
109        s!(?: [A-Z].*| \(\)|\( LIST \)| /PATTERN/.*)!!;
110        next if $Flavor{$_};
111        if (/^[_a-z]/) {
112            fail( "function '$_' has no summary for Pod::Functions" );
113        } else {
114            fail( "for Pod::Functions" );
115        }
116    }
117    foreach my $kind (sort keys %Kinds) {
118        my $funcs = $Kinds{$kind};
119        ++$test;
120        my $want = join ' ', sort_funcs(@$funcs);
121        is ("@$funcs", $want, "category $kind is correctly sorted" );
122    }
123    done_testing();
124    exit;
125}
126
127# blead will run this with miniperl, hence we can't use autodie
128my $real = 'Functions.pm';
129my $temp = "Functions.$$";
130
131END {
132    return if !defined $temp || !-e $temp;
133    unlink $temp or warn "Can't unlink '$temp': $!";
134}
135
136foreach ($real, $temp) {
137    next if !-e $_;
138    unlink $_ or die "Can't unlink '$_': $!";
139}
140
141open my $fh, '>', $temp or die "Can't open '$temp' for writing: $!";
142print $fh <<'EOT';
143package Pod::Functions;
144use strict;
145
146=head1 NAME
147
148Pod::Functions - Group Perl's functions a la perlfunc.pod
149
150=head1 SYNOPSIS
151
152    use Pod::Functions;
153
154    my @misc_ops = @{ $Kinds{ 'Misc' } };
155    my $misc_dsc = $Type_Description{ 'Misc' };
156
157or
158
159    perl /path/to/lib/Pod/Functions.pm
160
161This will print a grouped list of Perl's functions, like the
162L<perlfunc/"Perl Functions by Category"> section.
163
164=head1 DESCRIPTION
165
166It exports the following variables:
167
168=over 4
169
170=item %Kinds
171
172This holds a hash-of-lists. Each list contains the functions in the category
173the key denotes.
174
175=item %Type
176
177In this hash each key represents a function and the value is the category.
178The category can be a comma separated list.
179
180=item %Flavor
181
182In this hash each key represents a function and the value is a short
183description of that function.
184
185=item %Type_Description
186
187In this hash each key represents a category of functions and the value is
188a short description of that category.
189
190=item @Type_Order
191
192This list of categories is used to produce the same order as the
193L<perlfunc/"Perl Functions by Category"> section.
194
195=back
196
197=cut
198
199our $VERSION = '1.08';
200
201require Exporter;
202
203our @ISA = qw(Exporter);
204our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
205
206our(%Kinds, %Type, %Flavor, %Type_Description, @Type_Order);
207
208foreach (
209EOT
210
211foreach (@Types) {
212    my ($type, $desc) = @$_;
213    $type = "'$type'" if $type =~ /[^A-Za-z]/;
214    $desc =~ s!([\\'])!\\$1!g;
215    printf $fh "    [%-9s  => '%s'],\n", $type, $desc;
216}
217
218print $fh <<'EOT';
219	) {
220    push @Type_Order, $_->[0];
221    $Type_Description{$_->[0]} = $_->[1];
222};
223
224while (<DATA>) {
225    chomp;
226    s/^#.*//;
227    next unless $_;
228    my($name, @data) = split "\t", $_;
229    $Flavor{$name} = pop @data;
230    $Type{$name} = join ',', @data;
231    for my $t (@data) {
232        push @{$Kinds{$t}}, $name;
233    }
234}
235
236close DATA;
237
238my( $typedesc, $list );
239unless (caller) {
240    foreach my $type ( @Type_Order ) {
241	$list = join(", ", sort @{$Kinds{$type}});
242	$typedesc = $Type_Description{$type} . ":";
243	write;
244    }
245}
246
247format =
248
249^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
250    $typedesc
251~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
252    $typedesc
253 ~~  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
254	$list
255.
256
2571;
258
259__DATA__
260EOT
261
262foreach my $func (sort_funcs(keys %Flavor)) {
263    my $desc = $Flavor{$func};
264    die "No types listed for $func" unless $Type{$func};
265    next if $Omit{$func};
266    print $fh join("\t", $func, (sort @{$Type{$func}}), $desc), "\n";
267}
268
269close $fh or die "Can't close '$temp': $!";
270rename $temp, $real or die "Can't rename '$temp' to '$real': $!";
271