Commit | Line | Data |
---|---|---|
6f7c8186 NC |
1 | #!perl -w |
2 | use strict; | |
aa1042d8 NC |
3 | use Pod::Simple::SimpleTree; |
4 | ||
7fa6cc82 | 5 | my ($tap, $test, %Missing); |
4094982d NC |
6 | |
7 | @ARGV = grep { not($_ eq '--tap' and $tap = 1) } @ARGV; | |
8 | ||
aa1042d8 NC |
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; | |
7fa6cc82 | 33 | ++$Missing{$item_text} unless $Omit{$item_text}; |
aa1042d8 NC |
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/ .*//; | |
d9b04284 NC |
72 | # For now, just remove any metadata about when it was added: |
73 | $text =~ s/^\+\S+ //; | |
aa1042d8 NC |
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 | } | |
6f7c8186 | 95 | |
4094982d NC |
96 | if ($tap) { |
97 | foreach my $func (sort_funcs(keys %Flavor)) { | |
7fa6cc82 NC |
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 | } | |
4094982d | 113 | } |
46913ee5 NC |
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 | } | |
4094982d NC |
125 | print "1..$test\n"; |
126 | exit; | |
127 | } | |
128 | ||
6f7c8186 NC |
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 { | |
4094982d | 134 | return if !defined $temp || !-e $temp; |
6f7c8186 NC |
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: $!"; | |
aa1042d8 | 144 | print $fh <<'EOT'; |
d93fce09 | 145 | package Pod::Functions; |
66c981cf | 146 | use strict; |
cb1a09d0 | 147 | |
66c981cf | 148 | =head1 NAME |
cb1a09d0 | 149 | |
66c981cf AT |
150 | Pod::Functions - Group Perl's functions a la perlfunc.pod |
151 | ||
152 | =head1 SYNOPSIS | |
153 | ||
0791bc7e | 154 | use Pod::Functions; |
66c981cf AT |
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 | ||
3c4b39be | 174 | This holds a hash-of-lists. Each list contains the functions in the category |
66c981cf AT |
175 | the key denotes. |
176 | ||
177 | =item %Type | |
178 | ||
3c4b39be PF |
179 | In this hash each key represents a function and the value is the category. |
180 | The category can be a comma separated list. | |
66c981cf AT |
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 | ||
3c4b39be PF |
189 | In this hash each key represents a category of functions and the value is |
190 | a short description of that category. | |
66c981cf AT |
191 | |
192 | =item @Type_Order | |
193 | ||
3c4b39be | 194 | This list of categories is used to produce the same order as the |
66c981cf AT |
195 | L<perlfunc/"Perl Functions by Category"> section. |
196 | ||
197 | =back | |
198 | ||
66c981cf AT |
199 | =cut |
200 | ||
df7fb54b | 201 | our $VERSION = '1.06'; |
b75c8c73 | 202 | |
cb1a09d0 AD |
203 | require Exporter; |
204 | ||
66c981cf AT |
205 | our @ISA = qw(Exporter); |
206 | our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order); | |
cb1a09d0 | 207 | |
39376b25 NC |
208 | our(%Kinds, %Type, %Flavor, %Type_Description, @Type_Order); |
209 | ||
210 | foreach ( | |
aa1042d8 NC |
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'; | |
39376b25 NC |
221 | ) { |
222 | push @Type_Order, $_->[0]; | |
223 | $Type_Description{$_->[0]} = $_->[1]; | |
cb1a09d0 AD |
224 | }; |
225 | ||
226 | while (<DATA>) { | |
227 | chomp; | |
aa1042d8 | 228 | s/^#.*//; |
cb1a09d0 | 229 | next unless $_; |
16538db1 NC |
230 | my($name, @data) = split "\t", $_; |
231 | $Flavor{$name} = pop @data; | |
232 | $Type{$name} = join ',', @data; | |
233 | for my $t (@data) { | |
66c981cf | 234 | push @{$Kinds{$t}}, $name; |
cb1a09d0 | 235 | } |
66c981cf | 236 | } |
cb1a09d0 | 237 | |
3e92a254 GS |
238 | close DATA; |
239 | ||
66c981cf | 240 | my( $typedesc, $list ); |
cb1a09d0 | 241 | unless (caller) { |
b75c8c73 | 242 | foreach my $type ( @Type_Order ) { |
66c981cf AT |
243 | $list = join(", ", sort @{$Kinds{$type}}); |
244 | $typedesc = $Type_Description{$type} . ":"; | |
cb1a09d0 AD |
245 | write; |
246 | } | |
247 | } | |
248 | ||
249 | format = | |
250 | ||
251 | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | |
252 | $typedesc | |
253 | ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | |
254 | $typedesc | |
255 | ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | |
256 | $list | |
257 | . | |
258 | ||
66c981cf | 259 | 1; |
cb1a09d0 AD |
260 | |
261 | __DATA__ | |
aa1042d8 NC |
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}; | |
16538db1 | 268 | print $fh join("\t", $func, @{$Type{$func}}, $desc), "\n"; |
aa1042d8 NC |
269 | } |
270 | ||
271 | close $fh or die "Can't close '$temp': $!"; | |
272 | rename $temp, $real or die "Can't rename '$temp' to '$real': $!"; |