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