File Coverage

blib/lib/Pod/Section.pm

Criterion	Covered	Total	%
statement	24	86	27.9
branch	0	30	0.0
condition			n/a
subroutine	8	12	66.6
pod	1	1	100.0
total	33	129	25.5

package Pod::Section;

use warnings;
use strict;
use IO::String;
use Pod::Abstract;
use Pod::Perldoc;
use Pod::Perldoc::ToPod;
use base qw/Exporter/;
use Carp qw/croak/;

our @EXPORT_OK = qw/select_podsection/;

sub select_podsection {
  my ($module, @functions) = @_;
  my $pod = Pod::Perldoc->new;
  my @path = $pod->grand_search_init([$module]) or croak "Cannot find $module";
  my $parser = Pod::Perldoc::ToPod->new;
  my $fh = IO::String->new;
  $parser->parse_from_file(@path, $fh);
  seek $fh, 0, 0;
  my $pa = Pod::Abstract->load_file($fh);

  my @function_node;
  my $func_regexp = join "|", @functions;
  $func_regexp    = qr{((^($func_regexp))|[^a-zA-Z_0-9_\$]($func_regexp)|(\->($func_regexp))|(\s($func_regexp)))\b};
  my @try = ($pa, $func_regexp);
  if ($module eq 'Carp') {
    @function_node = _try_from_carp(@try);
  } else {
  CHECK: {
      @function_node = _try_head(2, @try)      and last;
      @function_node = _try_head_item(2, @try) and last;
      @function_node = _try_head_item(1, @try) and last;
      @function_node = _try_head(3, @try)      and last;
      @function_node = _try_head_item(3, @try) and last;
      @function_node = _try_head(4, @try)      and last;
      @function_node = _try_head_item(4, @try) and last;
      @function_node = _try_head(1, @try)      and last;
    }
  }
  my @pod;
  foreach my $pod (@function_node) {
    $pod =~s{L}{L<$module/$1>}gs;
    push @pod, $pod;
  }
  return wantarray ? @pod : join "", @pod;
}

sub _try_head_item {
  my ($n, $pa, $regexp) = @_;
  my @target;
  push @target, "/head$_" for 1 .. $n;
  my $target = join '', @target;
  my @nodes = $pa->select("$target/over/item");
  my @function_node;
  foreach my $node (@nodes) {
    foreach my $f ($node->param('label')->children) {
      if ($f->text =~ $regexp) {
        push @function_node, $node->pod;
      }
    }
  }
  return @function_node;
}

sub _try_head {
  my ($n, $pa, $regexp) = @_;
  my @target;
  push @target, "/head$_" for 1 .. $n;
  my $target = join '', @target;
  my @nodes = $pa->select($target);
  my @function_node;
  foreach my $node (@nodes) {
    foreach my $f ($node->param('heading')->children) {
      if ($f->text =~ $regexp) {
        push @function_node, $node->pod;
      }
    }
  }
  return @function_node;
}

sub _try_from_carp {
  my ($pa, $regexp) = @_;
  my @nodes = $pa->select('/head1');
  my @function_node;
  foreach my $node (@nodes) {
    foreach my $f ($node->param('heading')->children) {
      if ($f->text =~ m{NAME}) {
        my $pod = $node->pod;
        $pod =~ s{=head1 NAME}{};
        $pod =~ s{^(\w+)[\s\t]*(.+)$}{=head2 $1\n\n$2}gm;
        if ($pod =~ $regexp) {
          push @function_node, $pod;
        }
      }
    }
  }
  return @function_node;
}

=head1 NAME

Pod::Section - select specified section from Module's POD

=head1 VERSION

Version 0.02

=cut

our $VERSION = '0.02';


=head1 SYNOPSIS

    use Pod::Section qw/select_podsection/;

    my @function_pods = select_podsection($module, @functions);
    my @section_pods = select_podsection($module, @sections);

In scalar context, pod is joined as one scalar.

    my $function_pods = select_podsection($module, @functions);
    my $section_pods = select_podsection($module, @sections);

use podsection on shell

    % podsection Catalyst req res
    $c->req
      Returns the current Catalyst::Request object, giving access to
      information about the current client request (including parameters,
      cookies, HTTP headers, etc.). See Catalyst::Request.

    $c->res
      Returns the current Catalyst::Response object, see there for details.

=head1 EXPORT

=head2 select_podsection

See SYNOPSIS.

=head1 AUTHOR

Ktat, C<<  >>

=head1 BUGS

The way to search section is poor. This cannot find section correctly in some modules.

Please report any bugs or feature requests to C, or through
the web interface at L.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Pod::Section
    perldoc podsection

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back

=head1 ACKNOWLEDGEMENTS

=head1 SEE ALSO

=head2 Pod::Select

This also select section, but cannot search function/method explanation.

=head1 LICENSE AND COPYRIGHT

Copyright 2010 Ktat.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1; # End of Pod::Section