#!/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
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.