| 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': $!"; |