#!/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 additional 
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 table" );
				}
				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 overrides.

=item B<-with-all-caps>

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

=item B<-with-internals>

Also import pod for methods with names starting with underscores (conventionally
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 effectively
navigating perldoc and inheritance trees. For example, L<IO::File> inherits
from L<IO::Handle>, and so an IO::File object "does" anything an IO::Handle
object does. Novice users are sometimes confused by this, and think that APIs
are more limited than they really are (on a personal note: I found this 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 inheritance
tree, collecting the methods in the superclasses and importing the pod for the
methods in those superclasses. The resulting concatenated pod is written 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 is 
identified by the C<command> method, which takes the following arguments:

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

To recognize pod, the method name needs to be part of a $paragraph start token,
e.g. to find pod for 'method', permutations of the following will be recognized:

 =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 method name, 
and an optional opening parenthesis or token delimiter \b, to be matched against
the $paragraph argument to the C<command> call in subclasses of L<Pod::Parser>.

=cut