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