This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0d38aef00315cce6858f36e1b67652a71b5e19a6
[perl5.git] / ext / Pod-Functions / Functions_pm.PL
1 #!perl -w
2 use strict;
3 use Pod::Simple::SimpleTree;
4
5 my ($tap, $test, %Missing);
6
7 @ARGV = grep { not($_ eq '--tap' and $tap = 1) } @ARGV;
8
9 my (%Kinds, %Flavor, @Types);
10 my %Omit;
11
12 my $p = Pod::Simple::SimpleTree->new;
13 $p->accept_targets('Pod::Functions');
14 my $tree = $p->parse_file(shift)->root;
15
16 foreach 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:
82 my %Type;
83 while (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.
89 sub 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
96 if ($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
130 my $real = 'Functions.pm';
131 my $temp = "Functions.$$";
132
133 END {
134     return if !defined $temp || !-e $temp;
135     unlink $temp or warn "Can't unlink '$temp': $!";
136 }
137
138 foreach ($real, $temp) {
139     next if !-e $_;
140     unlink $_ or die "Can't unlink '$_': $!";
141 }
142
143 open my $fh, '>', $temp or die "Can't open '$temp' for writing: $!";
144 print $fh <<'EOT';
145 package Pod::Functions;
146 use strict;
147
148 =head1 NAME
149
150 Pod::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
159 or
160
161     perl /path/to/lib/Pod/Functions.pm
162
163 This will print a grouped list of Perl's functions, like the 
164 L<perlfunc/"Perl Functions by Category"> section.
165
166 =head1 DESCRIPTION
167
168 It exports the following variables:
169
170 =over 4
171
172 =item %Kinds
173
174 This holds a hash-of-lists. Each list contains the functions in the category
175 the key denotes.
176
177 =item %Type
178
179 In this hash each key represents a function and the value is the category.
180 The category can be a comma separated list.
181
182 =item %Flavor
183
184 In this hash each key represents a function and the value is a short 
185 description of that function.
186
187 =item %Type_Description
188
189 In this hash each key represents a category of functions and the value is 
190 a short description of that category.
191
192 =item @Type_Order
193
194 This list of categories is used to produce the same order as the
195 L<perlfunc/"Perl Functions by Category"> section.
196
197 =back
198
199 =cut
200
201 our $VERSION = '1.06';
202
203 require Exporter;
204
205 our @ISA = qw(Exporter);
206 our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
207
208 our(%Kinds, %Type, %Flavor, %Type_Description, @Type_Order);
209
210 foreach (
211 EOT
212
213 foreach (@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
220 print $fh <<'EOT';
221         ) {
222     push @Type_Order, $_->[0];
223     $Type_Description{$_->[0]} = $_->[1];
224 };
225
226 while (<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
238 close DATA;
239
240 my( $typedesc, $list );
241 unless (caller) { 
242     foreach my $type ( @Type_Order ) {
243         $list = join(", ", sort @{$Kinds{$type}});
244         $typedesc = $Type_Description{$type} . ":";
245         write;
246     } 
247 }
248
249 format = 
250
251 ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
252     $typedesc 
253 ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
254     $typedesc 
255  ~~  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
256         $list
257 .
258
259 1;
260
261 __DATA__
262 EOT
263
264 foreach 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
271 close $fh or die "Can't close '$temp': $!";
272 rename $temp, $real or die "Can't rename '$temp' to '$real': $!";