File Coverage

lib/Test/Pod/Links.pm

Criterion	Covered	Total	%
statement	137	137	100.0
branch	55	56	98.2
condition	14	15	93.3
subroutine	16	16	100.0
pod	3	3	100.0
total	225	227	99.1

package Test::Pod::Links;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.003';

use Carp ();
use HTTP::Tiny 0.014 ();
use Pod::Simple::Search     ();
use Pod::Simple::SimpleTree ();
use Scalar::Util            ();
use Test::Builder           ();
use Test::XTFiles           ();

my $TEST = Test::Builder->new();

# - Do not use subtests because subtests cannot be tested with
#   Test::Builder:Tester.
# - Do not use a plan because a method that sets a plan cannot be tested
#   with Test::Builder:Tester.
# - Do not call done_testing in a method that should be tested by
#   Test::Builder::Tester because TBT cannot test them.

sub all_pod_files_ok {
    my $self = shift;

    my @files = Test::XTFiles->new->all_files();
    if ( !@files ) {
        $TEST->skip_all("No files found\n");
        return 1;
    }

    my @pod_files = grep { Pod::Simple::Search->new->contains_pod($_) } @files;
    if ( !@pod_files ) {
        $TEST->skip_all("No files with Pod found\n");
        return 1;
    }

    my $rc = 1;
    for my $file (@pod_files) {
        if ( !$self->pod_file_ok($file) ) {
            $rc = 0;
        }
    }

    $TEST->done_testing;

    return 1 if $rc;
    return;
}

sub new {
    my $class = shift;

    Carp::croak 'Odd number of arguments' if @_ % 2;
    my %args = @_;

    my $self = bless {}, $class;

    #
    $self->{_cache} = {};

    #
    $self->_ua( $args{ua} || HTTP::Tiny->new );

    #
    my @ignores;
    if ( exists $args{ignore} ) {
        my $ignore = $args{ignore};
        if ( ref $ignore eq ref [] ) {
            @ignores = @{$ignore};
        }
        else {
            @ignores = $ignore;
        }
    }

    #
    my @ignores_match;
    if ( exists $args{ignore_match} ) {
        my $ignore_match = $args{ignore_match};
        if ( ref $ignore_match eq ref [] ) {
            @ignores_match = @{$ignore_match};
        }
        else {
            @ignores_match = $ignore_match;
        }
    }

    ## no critic (RegularExpressions::RequireDotMatchAnything)
    ## no critic (RegularExpressions::RequireExtendedFormatting)
    ## no critic (RegularExpressions::RequireLineBoundaryMatching)
    my $ignore_regex = join q{|}, @ignores_match, map { qr{^\Q$_\E$} } @ignores;
    $self->_ignore_regex( $ignore_regex ne q{} ? qr{$ignore_regex} : undef );
    ## use critic

  KEY:
    for my $key ( keys %args ) {
        next KEY if $key eq 'ignore';
        next KEY if $key eq 'ignore_match';
        next KEY if $key eq 'ua';

        Carp::croak "new() knows nothing about argument '$key'";
    }

    return $self;
}

sub pod_file_ok {
    my ( $self, $file ) = @_;

    Carp::croak 'usage: pod_file_ok(FILE)' if @_ != 2 || !defined $file;

    my $parse_msg = "Parse Pod ($file)";

    if ( !-f $file ) {
        $TEST->ok( 0, $parse_msg );
        $TEST->diag("\n");
        $TEST->diag("File $file does not exist or is not a file");
        return;
    }

    my $pod = Pod::Simple::SimpleTree->new->parse_file($file);

    if ( $pod->any_errata_seen ) {

        # Pod contains errors
        $TEST->ok( 0, $parse_msg );
        return;
    }

    $TEST->ok( 1, $parse_msg );

    my @links =
      grep { defined && m{ ^ http(?:s)? :// }xsmi }
      map  { ${ $_->{to} }[2] }
      grep { $_->{type} eq 'url' } $self->_extract_links_from_pod( $pod->root );

    my $ignore_regex = $self->_ignore_regex;
    if ( defined $ignore_regex ) {
        @links = grep { $_ !~ $ignore_regex } @links;
    }

    my $rc = 1;
    my $ua = $self->_ua;
    my %url_checked_in_this_file;

  LINK:
    for my $link (@links) {
        next LINK if exists $url_checked_in_this_file{$link};
        $url_checked_in_this_file{$link} = 1;

        if ( !exists $self->{_cache}->{$link} ) {
            $self->{_cache}->{$link} = $ua->head($link);
        }
        my $res = $self->{_cache}->{$link};

        $TEST->ok( $res->{success}, "$link ($file)" );

        if ( !$res->{success} ) {
            $rc = 0;
            $TEST->diag("\n");
            $TEST->diag( $res->{reason} );
            $TEST->diag("\n");
        }
    }

    return 1 if $rc;
    return;
}

sub _extract_links_from_pod {
    my ( $self, $node_ref ) = @_;

    Carp::croak 'usage: _extract_links_from_pod([ elementname, \%attributes, ...subnodes... ])' if @_ != 2 || ref $node_ref ne ref [] || scalar @{$node_ref} < 2;

    my @links;
    my ( $elem_name, $attr_ref, @subnodes ) = @{$node_ref};

    if ( $elem_name eq 'L' ) {
        push @links, $attr_ref;
    }

  SUBNODE:
    for my $subnode (@subnodes) {
        next SUBNODE if ref $subnode ne ref [];

        push @links, $self->_extract_links_from_pod($subnode);
    }

    return @links;
}

sub _ignore_regex {
    my $self = shift;

    if (@_) {
        my $ignore_regex = shift;
        $self->{_ignore_regex} = $ignore_regex;
    }

    return $self->{_ignore_regex};
}

sub _ua {
    my $self = shift;

    if (@_) {
        my $ua = shift;
        Carp::croak q{ua must have method 'head'} if !Scalar::Util::blessed($ua) || !$ua->can('head');
        $self->{_ua} = $ua;
    }

    return $self->{_ua};
}

1;

__END__