File Coverage

blib/lib/POD2/Base.pm

Criterion	Covered	Total	%
statement	44	57	77.1
branch	13	20	65.0
condition	1	3	33.3
subroutine	10	13	76.9
pod	5	5	100.0
total	73	98	74.4

package POD2::Base;

use 5.005;
use strict;
use warnings;

use vars qw( $VERSION );
$VERSION = '0.044_1';

use File::Spec ();

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $obj = bless {}, $class;
    return $obj->_init( @_ );
}

# instance variables:
#   lang - the preferred language of the POD documents
#   inc - alternate library dirs (if given, replaces the ones in @INC)

sub _init {
    my $self = shift;
    my %args = @_ ? %{$_[0]} : ();
    if ( !exists $args{lang} ) {
        $args{lang} = _extract_lang( ref $self );
    }
    #croak "???" unless $args{lang};
    my $lang = uc $args{lang};
    $self->{lang} = $lang;
    $self->{inc} = $args{inc}; # XXX croak ?! must be array ref

    return $self;
}

# $lang = _extract_lang($module);
sub _extract_lang {
    my $module = shift;

    return $module eq __PACKAGE__  ? undef
         : $module =~ /::(\w+)\z/  ? $1
         :                           undef
         ;
}

sub _lib_dirs {
    my $self = shift;
    return $self->{inc} ? @{$self->{inc}} : @INC;
}

sub pod_dirs {
    my $self = shift;
    my %options = @_ ? %{$_[0]} : ();
    $options{test} = 1 unless exists $options{test};

    my $lang = $self->{lang};
    my @candidates = map { File::Spec->catdir( $_, 'POD2', $lang ) } $self->_lib_dirs; # XXX the right thing to do
    if ( $options{test} ) {
        return grep { -d } @candidates;
    }
    return @candidates;
}

#sub search_perlfunc_re {
#    shift;
#    return 'Alphabetical Listing of Perl Functions';
#}

sub pod_info {
    shift;
    return {};
}

sub print_pods {
    my $self = shift;
    $self->print_pod(sort keys %{$self->pod_info});
}

sub print_pod {
    my $self = shift;
    my @args = @_ ? @_ : @ARGV;

    my $pods = $self->pod_info;
    while (@args) {
        (my $pod = lc(shift @args)) =~ s/\.pod$//;
        if ( exists $pods->{$pod} ) {
            print "\t'$pod' translated from Perl $pods->{$pod}\n";
        }
        else {
            print "\t'$pod' doesn't yet exists\n";
        }
    }
}

1;