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