1 files changed, 272 insertions, 0 deletions
diff --git a/ext/Pod-Functions/Functions_pm.PL b/ext/Pod-Functions/Functions_pm.PL
new file mode 100644
index 0000000000..c7bb44bec8
--- /dev/null
+++ b/ext/Pod-Functions/Functions_pm.PL
@@ -0,0 +1,272 @@
+#!perl -w
+use strict;
+use Pod::Simple::SimpleTree;
+
+my ($tap, $test, %Missing);
+
+@ARGV = grep { not($_ eq '--tap' and $tap = 1) } @ARGV;
+
+my (%Kinds, %Flavor, @Types);
+my %Omit;
+
+my $p = Pod::Simple::SimpleTree->new;
+$p->accept_targets('Pod::Functions');
+my $tree = $p->parse_file(shift)->root;
+
+foreach my $TL_node (@$tree[2 .. $#$tree]) {
+    next unless $TL_node->[0] eq 'over-text';
+    my $i = 2;
+    while ($i <= $#$TL_node) {
+        if ($TL_node->[$i][0] ne 'item-text') {
+            ++$i;
+            next;
+        }
+
+        my $item_text = $TL_node->[$i][2];
+        die "Confused by $item_text at line $TL_node->[$i][1]{start_line}"
+            if ref $item_text;
+        $item_text =~ s/\s+\z//s;
+
+        if ($TL_node->[$i+1][0] ne 'for'
+           || $TL_node->[$i+1][1]{target} ne 'Pod::Functions') {
+            ++$i;
+            ++$Missing{$item_text} unless $Omit{$item_text};
+            next;
+        }
+        my $data = $TL_node->[$i+1][2];
+        die "Confused by $data at line $TL_node->[$i+1][1]{start_line}"
+            unless ref $data eq 'ARRAY';
+        my $text = $data->[2];
+        die "Confused by $text at line $TL_node->[$i+1][1]{start_line}"
+            if ref $text;
+
+        $i += 2;
+
+        if ($text =~ s/^=//) {
+            # We are in "Perl Functions by Category"
+            die "Expected a paragraph after =item at $TL_node->[$i-2][1]{start_line}"
+                unless $TL_node->[$i][0] eq 'Para';
+            my $para = $TL_node->[$i];
+            # $text is the "type" of the built-in
+            # Anything starting ! is not for inclusion in Pod::Functions
+
+            foreach my $func (@$para[2 .. $#$para]) {
+                next unless ref $func eq 'ARRAY';
+                die "Expected only C<> blocks in paragraph after item at $TL_node->[$i-2][1]{start_line}"
+                    unless $func->[0] eq 'C' && !ref $func->[2];
+                # Everything is plain text (ie $func->[2] is everything)
+                # except for C<-I<X>>. So untangle up to one level of nested <>
+                my $funcname = join '', map {
+                    ref $_ ? $_->[2] : $_
+                } @$func[2..$#$func];
+                $funcname =~ s!(q.?)//!$1/STRING/!;
+                push @{$Kinds{$text}}, $funcname;
+            }
+            if ($text =~ /^!/) {
+                ++$Omit{$_} foreach @{$Kinds{$text}};
+            } else {
+                push @Types, [$text, $item_text];
+            }
+        } else {
+            $item_text =~ s/ .*//;
+            # For now, just remove any metadata about when it was added:
+            $text =~ s/^\+\S+ //;
+            $Flavor{$item_text} = $text;
+            ++$Omit{$item_text} if $text =~ /^!/;
+        }
+    }
+}
+
+# Take the lists of functions for each type group, and invert them to get the
+# type group (or groups) for each function:
+my %Type;
+while (my ($type, $funcs) = each %Kinds) {
+    push @{$Type{$_}}, $type foreach @$funcs;
+}
+
+# We sort __SUB__ after sub, but before substr, but __PACKAGE__ after package,
+# and __END__ after END.
+sub sort_funcs {
+    map { $_->[0] }
+        sort { uc $a->[1] cmp uc $b->[1] || $b->[1] cmp $a->[1] || $a->[0] cmp $b->[0] }
+            map  { my $f = tr/_//dr; [ $_, $f ] }
+                @_;
+}
+
+if ($tap) {
+    foreach my $func (sort_funcs(keys %Flavor)) {
+       ++$test;
+       my $ok = $Type{$func} ? 'ok' : 'not ok';
+       print "$ok $test - $func is mentioned in at least one category group\n";
+    }
+    foreach (sort keys %Missing) {
+        # Ignore anything that looks like an alternative for a function we've
+        # already seen;
+        s!(?: [A-Z].*| \(\)|\( LIST \)| /PATTERN/.*)!!;
+        next if $Flavor{$_};
+        ++$test;
+        if (/^[_a-z]/) {
+            print "not ok $test - function '$_' has no summary for Pod::Functions\n";
+        } else {
+            print "not ok $test - section '$_' has no type for Pod::Functions\n";
+        }
+    }
+    foreach my $kind (sort keys %Kinds) {
+        my $funcs = $Kinds{$kind};
+        ++$test;
+        my $want = join ' ', sort_funcs(@$funcs);
+        if ("@$funcs" eq $want) {
+            print "ok $test - category $kind is correctly sorted\n";
+        } else {
+            print "not ok $test - category $kind is correctly sorted\n";
+            print STDERR "# Have @$funcs\n# Want $want\n";
+        }
+    }
+    print "1..$test\n";
+    exit;
+}
+
+# blead will run this with miniperl, hence we can't use autodie
+my $real = 'Functions.pm';
+my $temp = "Functions.$$";
+
+END {
+    return if !defined $temp || !-e $temp;
+    unlink $temp or warn "Can't unlink '$temp': $!";
+}
+
+foreach ($real, $temp) {
+    next if !-e $_;
+    unlink $_ or die "Can't unlink '$_': $!";
+}
+
+open my $fh, '>', $temp or die "Can't open '$temp' for writing: $!";
+print $fh <<'EOT';
+package Pod::Functions;
+use strict;
+
+=head1 NAME
+
+Pod::Functions - Group Perl's functions a la perlfunc.pod
+
+=head1 SYNOPSIS
+
+    use Pod::Functions;
+    
+    my @misc_ops = @{ $Kinds{ 'Misc' } };
+    my $misc_dsc = $Type_Description{ 'Misc' };
+
+or
+
+    perl /path/to/lib/Pod/Functions.pm
+
+This will print a grouped list of Perl's functions, like the 
+L<perlfunc/"Perl Functions by Category"> section.
+
+=head1 DESCRIPTION
+
+It exports the following variables:
+
+=over 4
+
+=item %Kinds
+
+This holds a hash-of-lists. Each list contains the functions in the category
+the key denotes.
+
+=item %Type
+
+In this hash each key represents a function and the value is the category.
+The category can be a comma separated list.
+
+=item %Flavor
+
+In this hash each key represents a function and the value is a short 
+description of that function.
+
+=item %Type_Description
+
+In this hash each key represents a category of functions and the value is 
+a short description of that category.
+
+=item @Type_Order
+
+This list of categories is used to produce the same order as the
+L<perlfunc/"Perl Functions by Category"> section.
+
+=back
+
+=cut
+
+our $VERSION = '1.05';
+
+require Exporter;
+
+our @ISA = qw(Exporter);
+our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
+
+our(%Kinds, %Type, %Flavor, %Type_Description, @Type_Order);
+
+foreach (
+EOT
+
+foreach (@Types) {
+    my ($type, $desc) = @$_;
+    $type = "'$type'" if $type =~ /[^A-Za-z]/;
+    $desc =~ s!([\\'])!\\$1!g;
+    printf $fh "    [%-9s  => '%s'],\n", $type, $desc;
+}
+
+print $fh <<'EOT';
+	) {
+    push @Type_Order, $_->[0];
+    $Type_Description{$_->[0]} = $_->[1];
+};
+
+while (<DATA>) {
+    chomp;
+    s/^#.*//;
+    next unless $_;
+    my($name, @data) = split "\t", $_;
+    $Flavor{$name} = pop @data;
+    $Type{$name} = join ',', @data;
+    for my $t (@data) {
+        push @{$Kinds{$t}}, $name;
+    }
+}
+
+close DATA;
+
+my( $typedesc, $list );
+unless (caller) { 
+    foreach my $type ( @Type_Order ) {
+	$list = join(", ", sort @{$Kinds{$type}});
+	$typedesc = $Type_Description{$type} . ":";
+	write;
+    } 
+}
+
+format = 
+
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+    $typedesc 
+~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+    $typedesc 
+ ~~  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+	$list
+.
+
+1;
+
+__DATA__
+EOT
+
+foreach my $func (sort_funcs(keys %Flavor)) {
+    my $desc = $Flavor{$func};
+    die "No types listed for $func" unless $Type{$func};
+    next if $Omit{$func};
+    print $fh join("\t", $func, @{$Type{$func}}, $desc), "\n";
+}
+
+close $fh or die "Can't close '$temp': $!";
+rename $temp, $real or die "Can't rename '$temp' to '$real': $!";