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