#!/usr/bin/perl
use strict;
use warnings;
use Getopt::Long;
use Pod::Usage;

my $SKIPME  = qr/./;
my $VERBOSE = 0;
my $CLASS;
my $ALL_CAPS_REGEX  = '[A-Z]+';
my $INTERNALS_REGEX = '_.+';
my $WITH_OVERRIDES;
my $ISA   = {};
my $LOCAL = {};
my $equals = '=';

GetOptions(
    'class=s'        => \$CLASS,
    'verbose'        => \$VERBOSE,
    'with-overrides' => \$WITH_OVERRIDES,
    'with-all-caps'  => sub { $ALL_CAPS_REGEX  = '' },
    'with-internals' => sub { $INTERNALS_REGEX = '' },    
    'help|?'         => sub { pod2usage(2) },
    'man'            => sub { pod2usage(0) },
);
pod2usage( "Need a class name to analyze!" ) if not $CLASS;

if ( $ALL_CAPS_REGEX || $INTERNALS_REGEX ) {
    my $regex = join '|', $ALL_CAPS_REGEX, $INTERNALS_REGEX;
    $SKIPME = qr/^(?:$regex)$/;
}

eval "require $CLASS";
if ( $@ ) {
    pod2usage( "Can't analyze $CLASS: $@" );
}

$ISA->{$CLASS} = 1;
recurse_isa( $CLASS );
delete $ISA->{$CLASS};
my @classes = ( $CLASS );
push @classes, keys %{ $ISA };

if ( scalar @classes > 1 ) {
    my $script = $0;
    my $time = localtime;
    print << "HEADER";
# AUTOGENERATED pod created by $script on $time
# DO NOT EDIT the code below, rerun $script instead.

${equals}pod

${equals}head1 INHERITED METHODS

$CLASS inherits from one or more superclasses. This means that objects
+ of class
$CLASS also "do" the methods from the superclasses in addition to the 
+ones 
implemented in this class. Below is the documentation for those additi
+onal 
methods, organized by superclass.

HEADER

    for my $c ( @classes ) {
        if ( $c ne $CLASS ) {
        print << "CLASSHEADER";
${equals}head2 SUPERCLASS $c

$CLASS inherits from superclass L<$c>. 
Below are the public methods from this superclass.

${equals}over

CLASSHEADER
}
        my @methods = sort { $a cmp $b } get_methods( $c );
        for my $method ( @methods ) {
            my $pod = get_pod( $c, $method );
            print $pod if $pod;
        }
        print "=back\n\n" if $c ne $CLASS;        
    }
    print "=cut\n\n";
}

sub recurse_isa {
    my $class = shift;
    msg( "recursing up superclass $class" );
    my @isa;
    eval "\@isa = \@${class}::ISA";
    for ( @isa ) {
        if ( not exists $ISA->{$_} ) {
            recurse_isa($_);
        }
        $ISA->{$_} = 1;
    }
}

sub get_methods {
    my $class = shift;
    msg( "getting methods for superclass $class" );
    eval "require $class";
    if ( $@ ) {
        warn "Can't load superclass $class: $@";
    }
    my %symbol_table_for_class;
    my @methods;
    eval "\%symbol_table_for_class = \%${class}::";
    for my $entry ( keys %symbol_table_for_class ) {
        my $can = $class->can( $entry );
        if ( UNIVERSAL::isa( $can, 'CODE' ) ) {
            if ( $class eq $CLASS ) {
                $LOCAL->{$entry} = 1 if not $WITH_OVERRIDES;
                msg( "found local method $entry" );
            }    
            else {
                if ( $entry !~ $SKIPME and not exists $LOCAL->{$entry}
+ ) {
                    push @methods, $entry;
                    msg( "found method $entry in ${class}'s symbol tab
+le" );
                }
                else {
                    msg( "skipping method $entry in ${class}'s symbol 
+table" );
                }
            }
        }
    }
    return @methods;
}

sub get_pod {
    my ( $class, $method ) = @_;
    msg( "getting pod for method $method in class $class" );
    my $canon_class = $class;
    $canon_class =~ s/::/\//g;
    $canon_class .= ".pm";
    my $path = $INC{$canon_class};
    msg( "going to parse pod from file $path" );
    my $parser = ItemParser->new;
    $parser->method_to_find( $method );
    $parser->parse_from_file( $path );
    my $pod = $parser->get_pod_for_method;
    return $pod;
}

sub msg {
    my ( $msg, $level ) = @_;
    print STDERR $msg, "\n" if $VERBOSE;
}

BEGIN {
    package ItemParser;
    use Pod::Parser;
    @ItemParser::ISA = qw(Pod::Parser);
    
    sub command {
        my ( $parser, $command, $paragraph, $line_num ) = @_;
        my $method = $parser->{'method'};
        if ( $paragraph =~ m/^(?:\$\w+->)?$method(?:\(|\b)/ ) {
            $parser->{'para'} = "=item " . $paragraph;
            $parser->{'concat'} = 1;
        }
        else {
            $parser->{'concat'} = 0;
        }
    }
    
    sub verbatim {
        my ( $parser, $paragraph, $line_num ) = @_;
        if ( $parser->{'concat'} ) {
            $parser->{'para'} .= $paragraph;
        }
    }
    
    sub method_to_find {
        my ( $parser, $method ) = @_;
        $parser->{'method'} = $method;
    }
    
    sub get_pod_for_method { shift->{'para'} }
    
    sub textblock {
        my ( $parser, $text, $line_num, $pod_para ) = @_;
        if ( $parser->{'concat'} ) {
            $parser->{'para'} .= $text;
        }
    }
    
    sub interior_sequence {}
}

__END__

=head1 NAME

podinherit - Imports pod from superclasses

=head1 SYNOPSIS

 podinherit [-verbose] [-help] [-man] -class <Some::Class> 
            [-with-overrides] [-with-all-caps] [-with-internals]

=head1 OPTIONS

=over 8

=item B<-verbose>

Print verbose feedback to STDERR

=item B<-help>

Print a brief help message and exits.

=item B<-man>

Prints the manual page and exits.

=item B<-class> C<Some::Class>

Class name of child class.

=item B<-with-overrides>

Also import pod from superclasses for methods that Some::Class overrid
+es.

=item B<-with-all-caps>

Also import pod for methods with names in all capitals (typically inte
+rnal
methods such as DESTROY or TIEARRAY).

=item B<-with-internals>

Also import pod for methods with names starting with underscores (conv
+entionally
these are private/internal methods).

=back

=head1 DESCRIPTION

When object-oriented perl classes use inheritance, child classes will 
+have
additional methods not immediately apparent to users unfamiliar to eff
+ectively
navigating perldoc and inheritance trees. For example, L<IO::File> inh
+erits
from L<IO::Handle>, and so an IO::File object "does" anything an IO::H
+andle
object does. Novice users are sometimes confused by this, and think th
+at APIs
are more limited than they really are (on a personal note: I found thi
+s to be
the case when bug reports came in that some object no longer had the "
+set_name"
method, when really I had re-factored it into a superclass).

This script remedies that by analyzing
a class (provided on the command line), recursing up the class's inher
+itance
tree, collecting the methods in the superclasses and importing the pod
+ for the
methods in those superclasses. The resulting concatenated pod is writt
+en to 
STDOUT. That output can then be re-directed to a file, or formatted, e
+.g.
by doing:

 podinherit -class Some::Class | pod2text | more
 
=head1 IMPLEMENTATION

This script contains a subclass of L<Pod::Parser>, which implements a 
+stream
parser for pod. The appropriate documentation for superclass methods i
+s 
identified by the C<command> method, which takes the following argumen
+ts:

 my ( $parser, $command, $paragraph, $line_num ) = @_;

To recognize pod, the method name needs to be part of a $paragraph sta
+rt token,
e.g. to find pod for 'method', permutations of the following will be r
+ecognized:

 =item method
 =head1 method()
 =item method( $arg )
 =item $obj->method( $arg )

Or, specifically, anything that matches:
 
 /^(?:\$\w+->)?$method(?:\(|\b)/

I.e. an optional object reference with method arrow ($self->), a metho
+d name, 
and an optional opening parenthesis or token delimiter \b, to be match
+ed against
the $paragraph argument to the C<command> call in subclasses of L<Pod:
+:Parser>.

=cut