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