File Coverage

blib/lib/Test/Pod/LinkCheck/Lite.pm

Criterion	Covered	Total	%
statement	483	526	91.8
branch	159	240	66.2
condition	30	57	52.6
subroutine	102	105	97.1
pod	15	15	100.0
total	789	943	83.6

package Test::Pod::LinkCheck::Lite;

use 5.008;

use strict;			# Core since 5.0
use warnings;			# Core since 5.6.0

use utf8;			# Core since 5.6.0

use B::Keywords ();		# Not core
use Carp ();			# Core since 5.0
use Exporter ();		# Core since 5.0
use File::Find ();		# Core since 5.0
use File::Spec;			# Core since 5.4.5
use HTTP::Tiny;			# Core since 5.13.9
use IPC::Cmd ();		# Core since 5.9.5
use Module::Load::Conditional ();	# Core since 5.9.5
use Pod::Perldoc ();		# Core since 5.8.1
use Pod::Simple ();		# Core since 5.9.3
use Pod::Simple::LinkSection;	# Core since 5.9.3 (part of Pod::Simple)
use Scalar::Util ();		# Core since 5.7.3
use Storable ();		# Core since 5.7.3
use Test::Builder ();		# Core since 5.6.2

our $VERSION = '0.010_01';

our @ISA = qw{ Exporter };

our @EXPORT_OK = qw{
    ALLOW_REDIRECT_TO_INDEX
    MAYBE_IGNORE_GITHUB
};

our %EXPORT_TAGS = (
    const	=> [ grep { m/ \A [[:upper:]_]+ \z /smx } @EXPORT_OK ],
);

use constant ON_DARWIN		=> 'darwin' eq $^O;
use constant ON_VMS		=> 'VMS' eq $^O;

our $DIRECTORY_LEADER;	# FOR TESTING ONLY -- may be retracted without notice
defined $DIRECTORY_LEADER
    or $DIRECTORY_LEADER = ON_VMS ? '_' : '.';

my $DOT_CPAN		= "${DIRECTORY_LEADER}cpan";

use constant ARRAY_REF	=> ref [];
use constant CODE_REF	=> ref sub {};
use constant HASH_REF	=> ref {};
use constant NON_REF	=> ref 0;
use constant REGEXP_REF	=> ref qrsmx;
use constant SCALAR_REF	=> ref \0;

# Pod::Simple versions earlier than this were too restrictive in
# recognizing 'man' links, so some valid ones ended up classified as
# 'pod'. We conditionalize fix-up code on this constant so that, if the
# fix-up is not needed, the optimizer ditches it.
use constant NEED_MAN_FIX	=> Pod::Simple->VERSION lt '3.24';

use constant ALLOW_REDIRECT_TO_INDEX => sub {
    my ( undef, $resp, $url ) = @_;
    # Does not apply to non-hierarchical URLs. This list is derived from
    # the URI distribution, and represents those classes that do not
    # inherit from URI::_generic.
    $url =~ m/ \A (?: data | mailto | urn ) : /smxi
	and return $resp->{url} ne $url;
    $url =~ m| / \z |smx
	or return $resp->{url} ne $url;
    ( my $resp_url = $resp->{url} ) =~ s| (?<= / ) [^/]* \z ||smx;
    return $resp_url ne $url;
};

use constant MAYBE_IGNORE_GITHUB	=> sub {
    m< \A https://github\.com \b >smx
	or return;
    my $git_dir = $ENV{GIT_DIR} || '.git';
    -d $git_dir
	or return 1;
    open my $fh, '-|', qw{ git remote --verbose }	## no critic (RequireBriefOpen)
	or return 1;
    local $_ = undef;	# while (<>) ... does not localize $_.
    while ( <$fh> ) {
	m< \b https://github\.com \b >smx
	    and return;
    }
    return 1;
};

use constant USER_AGENT_CLASS	=> 'HTTP::Tiny';


# NOTE that Test::Builder->new() gets us a singleton. For this reason I
# use $Test::Builder::Level (localized) to get tests reported relative
# to the correct file and line, rather than setting the 'level'
# attribute.
my $TEST = Test::Builder->new();

sub new {
    my ( $class, %arg ) = @_;
    my $self = bless {}, ref $class || $class;
    return _init( $self, %arg );
}

{
    my %dflt;
    local $_ = undef;
    foreach ( keys %Test::Pod::LinkCheck::Lite:: ) {
	m/ \A _default_ ( .+ ) /smx
	    and my $code = __PACKAGE__->can( $_ )
	    or next;
	$dflt{$1} = $code;
    }

    sub _init {
	my ( $self, %arg ) = @_;
	foreach my $key ( keys %dflt ) {
	    exists $arg{$key}
		or $arg{$key} = $dflt{$key}->();
	}
	foreach my $name ( keys %arg ) {
	    if ( my $code = $self->can( "_init_$name" ) ) {
		$code->( $self, $name, $arg{$name} );
	    } elsif ( defined $arg{$name} ) {
		Carp::croak( "Unknown argument $name" );
	    }
	}
	return $self;
    }
}

sub _default_allow_man_spaces {
    return 0;
}

sub _default_check_external_sections {
    return 1;
}

sub _default_cache_url_response {
    return 1;
}

sub _default_check_url {
    return 1;
}

sub _default_ignore_url {
    return [];
}

{
    my $checked;
    my $rslt;

    sub _default_man {
	unless ( $checked ) {
	    $checked = 1;
	    # I had hoped that just feeling around for an executable
	    # 'man' would be adequate, but ReactOS (which identifies
	    # itself as MSWin32) has a MAN.EXE that will not work. If
	    # the user has customized the system he or she can always
	    # specify man => 1. The hash is in case I find other OSes
	    # that have this problem. OpenVMS might end up here, but I
	    # have no access to it to see.
	    if ( {
		    DOS		=> 1,
		    MSWin32	=> 1,
		}->{$^O}
	    ) {
		$rslt = 0;
		$TEST->diag( "Can not check man pages by default under $^O" );
	    } else {
		$rslt = IPC::Cmd::can_run( 'man' )
		    or $TEST->diag(
		    q );
	    }
	}
	return $rslt;
    }
}

sub _default_module_index {
    my @handlers;
    foreach ( keys %Test::Pod::LinkCheck::Lite:: ) {
	m/ \A _get_module_index_ ( .+ ) /smx
	    and __PACKAGE__->can( $_ )
	    or next;
	push @handlers, $1;
    }
    @handlers = sort @handlers;
    return \@handlers;
}

sub _default_prohibit_redirect {
    return 0;
}

sub _default_require_installed {
    return 0;
}

sub _default_skip_server_errors {
    return 1;
}

sub _default_user_agent {
    return USER_AGENT_CLASS;
}

sub _init_allow_man_spaces {
    my ( $self, $name, $value ) = @_;
    $self->{$name} = $value ? 1 : 0;
    return;
}

sub _init_cache_url_response {
    my ( $self, $name, $value ) = @_;
    $self->{$name} = $value ? 1 : 0;
    return;
}

sub _init_check_external_sections {
    my ( $self, $name, $value ) = @_;
    $self->{$name} = $value ? 1 : 0;
    return;
}

sub _init_check_url {
    my ( $self, $name, $value ) = @_;
    $self->{$name} = $value ? 1 : 0;
    return;
}

{
    my %handler;

    %handler = (
	ARRAY_REF,	sub {
	    my ( $spec, $value ) = @_;
	    $handler{ ref $_ }->( $spec, $_ ) for @{ $value };
	    return;
	},
	CODE_REF,	sub {
	    my ( $spec, $value ) = @_;
	    push @{ $spec->{ CODE_REF() } }, $value;
	    return;
	},
	HASH_REF,	sub {
	    my ( $spec, $value ) = @_;
	    $spec->{ NON_REF() }{$_} = 1 for
		grep { $value->{$_} } keys %{ $value };
	    return;
	},
	NON_REF,	sub {
	    my ( $spec, $value ) = @_;
	    defined $value
		or return;
	    $spec->{ NON_REF() }->{$value} = 1;
	    return;
	},
	REGEXP_REF,	sub {
	    my ( $spec, $value ) = @_;
	    push @{ $spec->{ REGEXP_REF() } }, $value;
	    return;
	},
	SCALAR_REF,	sub {
	    my ( $spec, $value ) = @_;
	    $spec->{ NON_REF() }->{$$value} = 1;
	    return;
	},
    );

    sub _init_ignore_url {
	my ( $self, $name, $value ) = @_;

	my $spec = $self->{$name} = {};
	eval {
	    $handler{ ref $value }->( $spec, $value );
	    1;
	} or Carp::confess(
	    "Invalid ignore_url value '$value': must be scalar, regexp, array ref, hash ref, code ref, or undef" );
	return;
    }
}

sub _init_man {
    my ( $self, $name, $value ) = @_;
    $self->{$name} = $value ? 1 : 0;
    return;
}

sub _init_module_index {
    my ( $self, $name, $value ) = @_;
    my @val = map { split qr{ \s* , \s* }smx } ARRAY_REF eq ref $value ?
    @{ $value } : $value;
    my @handlers;
    foreach my $mi ( @val ) {
	my $code = $self->can( "_get_module_index_$mi" )
	    or Carp::croak( "Invalid module_index value '$mi'" );
	push @handlers, $code;
    }
    $self->{$name} = \@val;
    $self->{"_$name"} = \@handlers;
    return;
}

sub _init_prohibit_redirect {
    my ( $self, $name, $value ) = @_;
    if ( CODE_REF eq ref $value ) {
	$self->{$name} = $self->{"_$name"} = $value;
    } elsif ( $value ) {
	$self->{$name} = 1;
	$self->{"_$name"} = sub {
	    my ( undef, $resp, $url ) = @_;
	    return $resp->{url} ne $url;
	};
    } else {
	$self->{$name} = 0;
	$self->{"_$name"} = sub {
	    return 0;
	};
    }
    return;
}

sub _init_require_installed {
    my ( $self, $name, $value ) = @_;
    $self->{$name} = $value ? 1 : 0;
    return;
}

sub _init_skip_server_errors {
    my ( $self, $name, $value ) = @_;
    $self->{$name} = $value ? 1 : 0;
    return;
}

sub _init_user_agent {
    my ( $self, $name, $value ) = @_;
    defined $name
	or $name = USER_AGENT_CLASS;
    eval {
	$value->isa( USER_AGENT_CLASS )
    } or Carp::confess(
	"Invalid user_agent value '$value': must be a subclass of HTTP::Tiny, or undef" );
    $self->{$name} = $value;
    if ( ref $value ) {
	$self->{_user_agent} = $value;
    } else {
	# Probably unnecessary, but I'm paranoid.
	delete $self->{_user_agent};
    }
    return;
}

sub agent {
    my ( $self ) = @_;
    defined $self->{agent}
	or $self->{agent} = $self->_user_agent()->agent();
    return $self->{agent};
}

sub all_pod_files_ok {
    my ( $self, @dir ) = @_;

    @dir
	or push @dir, 'blib';

    my $note = sprintf 'all_pod_files_ok( %s )',
	join ', ', map { "'$_'" } @dir;

    $TEST->note( "Begin $note" );

    my ( $fail, $pass, $skip ) = ( 0 ) x 3;

    File::Find::find( {
	    no_chdir	=> 1,
	    wanted	=> sub {
		if ( $self->_is_perl_file( $_ ) ) {
		    $TEST->note( "Checking POD links in $File::Find::name" );
		    my ( $f, $p, $s ) = $self->pod_file_ok( $_ );
		    $fail += $f;
		    $pass += $p;
		    $skip += $s;
		}
		return;
	    },
	},
	@dir,
    );

    $TEST->note( "End $note" );

    return wantarray ? ( $fail, $pass, $skip ) : $fail;
}

sub allow_man_spaces {
    my ( $self ) = @_;
    return $self->{allow_man_spaces}
}

sub cache_url_response {
    my ( $self ) = @_;
    return $self->{cache_url_response}
}

sub check_external_sections {
    my ( $self ) = @_;
    return $self->{check_external_sections}
}

sub check_url {
    my ( $self ) = @_;
    return $self->{check_url}
}

sub configuration {
    my ( $self, $leader ) = @_;

    defined $leader
	or $leader = '';
    $leader =~ s/ (?<= \S ) \z / /smx;

    my ( $ignore_url ) = $TEST->explain( scalar $self->ignore_url() );
    chomp $ignore_url;

    return <<"EOD";
${leader}'agent' is '@{[ $self->agent() ]}'
${leader}'allow_man_spaces' is @{[ _Boolean(
    $self->allow_man_spaces() ) ]}
${leader}'cache_url_response' is @{[ _Boolean(
    $self->cache_url_response() ) ]}
${leader}'check_external_sections' is @{[ _Boolean(
    $self->check_external_sections() ) ]}
${leader}'check_url' is @{[ _Boolean( $self->check_url() ) ]}
${leader}'ignore_url' is $ignore_url
${leader}'man' is @{[ _Boolean( $self->man() ) ]}
${leader}'module_index' is ( @{[ join ', ', map { "'$_'" }
    $self->module_index() ]} )
${leader}'prohibit_redirect' is @{[ _Boolean( $self->prohibit_redirect() ) ]}
${leader}'require_installed' is @{[ _Boolean( $self->require_installed() ) ]}
${leader}'skip_server_errors' is @{[ _Boolean( $self->skip_server_errors() ) ]}
EOD
}

sub _Boolean {
    my ( $value ) = @_;
    return $value ? 'true' : 'false';
}

sub ignore_url {
    my ( $self ) = @_;
    my $spec = $self->__ignore_url();
    my @rslt = (
	sort keys %{ $spec->{ ( NON_REF ) } || {} },
	@{ $spec->{ ( REGEXP_REF ) } || [] },
	@{ $spec->{ ( CODE_REF ) } || [] },
    );
    return wantarray ? @rslt : \@rslt;
}

# This method returns the internal value of the ignore_url attribute. It
# is PRIVATE to this package, and may be changed or revoked at any time.
# If called with an argument, it returns a true value if that argument
# is a URL that is to be ignored, and false otherwise.
sub __ignore_url {
    my ( $self, $url ) = @_;
    @_ > 1
	or return $self->{ignore_url};
    my $spec = $self->{ignore_url};
    $spec->{ NON_REF() }{$url}
	and return 1;
    foreach my $re ( @{ $spec->{ REGEXP_REF() } } ) {
	$url =~ $re
	    and return 1;
    }
    local $_ = $url;
    foreach my $code ( @{ $spec->{ CODE_REF() } } ) {
	$code->()
	    and return 1;
    }
    return 0;
}

sub man {
    my ( $self ) = @_;
    return $self->{man};
}

sub module_index {
    my ( $self ) = @_;
    wantarray
	and return @{ $self->{module_index} };
    local $" = ',';
    return "@{ $self->{module_index} }";
}

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

    delete $self->{_section};
    $self->{_test} = {
	pass	=> 0,
	fail	=> 0,
	skip	=> 0,
    };

    if ( SCALAR_REF eq ref $file ) {
	$self->{_file_name} = ${ $file } =~ m/ \n /smx ?
	    "String $file" :
	    "String '${ $file }'";
    } elsif ( -f $file ) {
	$self->{_file_name} = "File $file";
    } else {
	$self->{_file_name} = "File $file";
	$self->_fail(
	    'does not exist, or is not a normal file' );
	return wantarray ? ( 1, 0, 0 ) : 1;
    }

    ( $self->{_section}, $self->{_links} ) = My_Parser->new()->run(
	$file, \&_any_errata_seen, $self );

    @{ $self->{_links} }
	or do {
	$self->_pass();
	return wantarray ? ( 0, 1, 0 ) : 0;
    };

    my $errors = 0;

    foreach my $link ( @{ $self->{_links} } ) {
	my $code = $self->can( "_handle_$link->[1]{type}" )
	    or Carp::confess(
	    "TODO - link type $link->[1]{type} not supported" );
	$errors += $code->( $self, $link );
    }

    $errors
	or $self->_pass();
    return wantarray ?
	( @{ $self->{_test} }{ qw{ fail pass skip } } ) :
	$self->{_test}{fail};
}

sub prohibit_redirect {
    my ( $self ) = @_;
    return $self->{prohibit_redirect};
}

sub require_installed {
    my ( $self ) = @_;
    return $self->{require_installed};
}

sub skip_server_errors {
    my ( $self ) = @_;
    return $self->{skip_server_errors};
}

# This is a private method, but because it had to be accessed (read:
# monkey-patched) to get badly-needed user functionality, it needs to
# fulfill its interface contract until March 1 2024 or one year after
# the release of version 0.011, whichever is later. That contract is:
# * Name: _user_agent
# * Arguments: none
# * Return: HTTP::Tiny object, which may be a subclass.
sub _user_agent {
    my ( $self ) = @_;
    return( $self->{_user_agent} ||= do {
	    my @arg;
	    defined $self->{agent}
		and push @arg, agent => $self->{agent};
	    $self->{user_agent}->new( @arg );
	}
    );
}

sub _pass {
    my ( $self, @msg ) = @_;
    @msg
	or @msg = ( 'contains no broken links' );
    local $Test::Builder::Level = _nest_depth();
    $TEST->ok( 1, $self->__build_test_msg( @msg ) );
    $self->{_test}{pass}++;
    return 0;
}

sub _fail {
    my ( $self, @msg ) = @_;
    local $Test::Builder::Level = _nest_depth();
    $TEST->ok( 0, $self->__build_test_msg( @msg ) );
    $self->{_test}{fail}++;
    return 1;
}

sub _skip {
    my ( $self, @msg ) = @_;
    local $Test::Builder::Level =  _nest_depth();
    $TEST->skip( $self->__build_test_msg( @msg ) );
    $self->{_test}{skip}++;
    return 0;
}

sub _any_errata_seen {
    my ( $self, $file ) = @_;
    $file = defined $file ? "File $file" : $self->{_file_name};
    $TEST->diag( "$file contains POD errors" );
    return;
}

# This method formats test messages. It is PRIVATE to this package, and
# can be changed or revoked without notice.
sub __build_test_msg {
    my ( $self, @msg ) = @_;
    my @prefix = ( $self->{_file_name} );
    if ( ARRAY_REF eq ref $msg[0] ) {
	my $link = shift @msg;
	my $text = defined $link->[1]{raw} ?
	    "link L<$link->[1]{raw}>" :
	    'Link L<>';
	defined $link->[1]{line_number}
	    and push @prefix, "line $link->[1]{line_number}";
	push @prefix, $text;
    }
    return join ' ', @prefix, join '', @msg;
}

# Get the information on installed documentation. If the doc is found
# the return is a reference to a hash containing key {file}, value the
# path name to the file containing the documentation. This works both
# for module documentation (whether in the .pm or a separate .pod), or
# regular .pod documentation (e.g. perldelta.pod).
sub _get_installed_doc_info {
    my ( undef, $module ) = @_;
    my $pd = Pod::Perldoc->new();

    # Pod::Perldoc writes to STDERR if the module (or whatever) is not
    # installed, so we localize STDERR and reopen it to the null device.
    # The reopen of STDERR is unchecked because if it fails we still
    # want to run the tests. They just may be noisy.
    local *STDERR;
    open STDERR, '>', File::Spec->devnull();	## no critic (RequireCheckedOpen)

    # NOTE that grand_search_init() is undocumented.
    my ( $path ) = $pd->grand_search_init( [ $module ] );

    close STDERR;

    defined $path
	and return {
	file	=> $path,
    };

    # See the comment above (just below where _get_installed_doc_info is
    # called) for why this check is done.
    Module::Load::Conditional::check_install( module	=> $module )
	and return {
	file		=> $path,
	undocumented	=> 1,
    };

    return;
}

# POD link handlers

# Handle a 'man' link.

sub _handle_man {
    my ( $self, $link ) = @_;

    $self->man()
	or return $self->_skip( $link, 'not checked; man checks disabled' );

    $link->[1]{to}
	or return $self->_fail( $link, 'no man page specified' );

    my ( $page, $sect ) = $link->[1]{to} =~ m/
	    ( [^(]+ ) (?: [(] ( [^)]+ ) [)] )? /smx
	or return $self->_fail( $link, 'not recognized as man page spec' );

    $page =~ s/ \s+ \z //smx;

    $page =~ m/ \s /smx
	and not $self->allow_man_spaces()
	and return $self->_fail( $link, 'contains embedded spaces' );

    my @pg = (
	$sect ? $sect : (),
	$page,
    );

    ( $self->{_cache}{man}{"@pg"} ||= IPC::Cmd::run( COMMAND => [
		qw{ man -w }, @pg ] ) || 0 )
	and return 0;

    return $self->_fail( $link, 'refers to unknown man page' );
}

# Handle pod links. This is pretty much everything, except for 'man'
# (see above) or 'url' (see below).
sub _handle_pod {
    my ( $self, $link ) = @_;

    if ( $link->[1]{to} ) {
	return $self->_check_external_pod_info( $link )

    } elsif ( my $section = $link->[1]{section} ) {
	$section = "$section";	# Stringify object
	# Internal links (no {to})
	$self->{_section}{$section}
	    and return 0;

	# Before 3.24, Pod::Simple was too restrictive in parsing 'man'
	# links, and they end up here. The regex is verbatim from
	# Pod::Simple 3.24.
	if ( NEED_MAN_FIX && $section =~ m{^[^/|]+[(][-a-zA-Z0-9]+[)]$}s ) {
	    # The misparse left the actual link text in {section}, but
	    # an honest-to-God Pod link has it in {to}.
	    $link->[1]{to} = delete $link->[1]{section};
	    # While we're at it, we might as well make it an actual
	    # 'man' link.
	    $link->[1]{type} = 'man';
	    goto &_handle_man;
	}

	return $self->_fail( $link, 'links to unknown section' );

    } else {
	# Links to nowhere: L<...|> or L<...|/>
	return $self->_fail( $link, 'links to nothing' );
    }
    return 0;
}

sub _check_external_pod_info {
    my ( $self, $link ) = @_;

    # Stringify overloaded objects
    my $module = $link->[1]{to} ? "$link->[1]{to}" : undef;
    my $section = $link->[1]{section} ?  "$link->[1]{section}" : undef;

    # If there is no section info it might be a Perl builtin. Return
    # success if it is.
    unless ( $section ) {
	$self->_is_perl_function( $module )
	    and return 0;
    }

    # If it is installed, handle it
    if ( my $data = $self->{_cache}{installed}{$module} ||=
	$self->_get_installed_doc_info( $module ) ) {

	# This check is the result of an Andreas J. König (ANDK) test
	# failure under Perl 5.8.9. That version ships with Pod::Perldoc
	# 3.14, which is undocumented. Previously the unfound
	# documentation caused us to fall through to the 'uninstalled'
	# code, which succeeded because all it was doing was looking for
	# the existence of the module, and _assuming_ that it was
	# documented.
	$data->{undocumented}
	    and return $self->_fail( $link,
	    "$module is installed but undocumented" );

	# If we get this far it is an installed module with
	# documentation. We can return success at this point unless the
	# link specifies a section AND we are checking them. We test the
	# link rather than the section name because the latter could be
	# '0'.
	$link->[1]{section}
	    and $self->check_external_sections()
	    or return 0;

	# Find and parse the section info if needed.
	$data->{section} ||= My_Parser->new()->run( $data->{file},
	    \&_any_errata_seen, $self, "File $data->{file}" );

	$data->{section}{$section}
	    and return 0;

	return $self->_fail( $link, 'links to unknown section' );
    }

    # If we're requiring links to be to installed modules, flunk now.
    $self->require_installed()
	and return $self->_fail( $link,
	'links to module that is not installed' );

    # It's not installed on this system, but it may be out there
    # somewhere

    $self->{_cache}{uninstalled} ||= $self->_get_module_index();

    return $self->{_cache}{uninstalled}->( $self, $link );

}

sub _get_module_index {
    my ( $self ) = @_;
    my @inxes = sort { $a->[1] <=> $b->[1] }
	map { $_->( $self ) } @{ $self->{_module_index} };
    if ( @inxes ) {
	my $modinx = $inxes[-1][0];
	return sub {
	    my ( $self, $link ) = @_;
	    my $module = $link->[1]{to};
	    $modinx->( $module )
		or return $self->_fail( $link, 'links to unknown module' );
	    $link->[1]{section}
		or return 0;
	    return $self->_skip( $link, 'not checked; ',
		'module exists, but unable to check sections of ',
		'uninstalled modules' );
	};
    } else {
	return sub {
	    my ( $self, $link ) = @_;
	    return $self->_skip( $link, 'not checked; ',
		'not found on this system' );
	};
    }
}

# In all of the module index getters, the return is either nothing at
# all (for inability to use this indexing mechanism) or a refererence to
# an array. Element [0] of the array is a reference a piece of code that
# takes the module name as its only argument, and returns a true value
# if that module exists and a false value otherwise. Element [1] of the
# array is a Perl time that is characteristic of the information in the
# index (typically the revision date of the underlying file if that's
# the way the index works).

# NOTE that Test::Pod::LinkCheck loads CPAN and then messes with it to
# try to prevent it from initializing itself. After trying this and
# thinking about it, I decided to go after the metadata directly.
sub _get_module_index_cpan {
#   my ( $self ) = @_;

    # The following code reproduces
    # CPAN::HandleConfig::cpan_home_dir_candidates()
    # as of CPAN::HandleConfig version 5.5011.
    my @dir_list;

    if ( _has_usable( 'File::HomeDir', 0.52 ) ) {
	ON_DARWIN
	    or push @dir_list, File::HomeDir->my_data();
	push @dir_list, File::HomeDir->my_home();
    }

    $ENV{HOME}
	and push @dir_list, $ENV{HOME};
    $ENV{HOMEDRIVE}
	and $ENV{HOMEPATH}
	and push @dir_list, File::Spec->catpath( $ENV{HOMEDRIVE},
	$ENV{HOMEPATH} );
    $ENV{USERPROFILE}
	and push @dir_list, $ENV{USERPROFILE};
    $ENV{'SYS$LOGIN'}
	and push @dir_list, $ENV{'SYS$LOGIN'};

    # The preceding code reproduces
    # CPAN::HandleConfig::cpan_home_dir_candidates()

    foreach my $dir ( @dir_list ) {
	defined $dir
	    or next;
	my $path = File::Spec->catfile( $dir, $DOT_CPAN, 'Metadata' );
	-e $path
	    or next;
	my $rev = ( stat _ )[9];
	my $hash = Storable::retrieve( $path )
	    or return;
	$hash = $hash->{'CPAN::Module'};
	return [
	    sub { return $hash->{$_[0]} },
	    $rev,
	];
    }

    return;
}

sub _get_module_index_cpan_meta_db {
    my ( $self ) = @_;

    my $user_agent = $self->_user_agent();

    my %hash;

    return [
	sub {
	    exists $hash{$_[0]}
		and return $hash{$_[0]};
	    my $resp = $user_agent->head(
		"https://cpanmetadb.plackperl.org/v1.0/package/$_[0]" );
	    return ( $hash{$_[0]} = $resp->{success} );
	},
	time - 86400 * 7,
    ];
}

# Handle url links. This is something like L or
# L<...|http://...>.
sub _handle_url {
    my ( $self, $link ) = @_;

    $self->check_url()
	or return $self->_skip( $link, 'not checked; url checks disabled' );

    my $user_agent = $self->_user_agent();

    my $url = "$link->[1]{to}"	# Stringify object
	or return $self->_fail( $link, 'contains no url' );

    if ( $url =~ m/ \A https : /smxi ) {
	my ( $ok, $why ) = USER_AGENT_CLASS->can_ssl();
	unless ( $ok ) {
	    $self->{_ssl_warning}
		or $TEST->diag( "Can not check https: links: $why" );
	    $self->{_ssl_warning} = 1;
	    return $self->_skip(
		$link, 'not checked: https: checks unavailable' );
	}
    }

    $self->__ignore_url( $url )
	and return $self->_skip( $link, 'not checked; explicitly ignored' );

    my $resp;
    if ( $self->cache_url_response() ) {
	$resp = $self->{_cache_url_response}{$url} ||=
	    $user_agent->head( $url );
    } else {
	$resp = $user_agent->head( $url );
    }

    if ( $resp->{success} ) {

	my $code = $self->{_prohibit_redirect};
	while ( $code = $code->( $self, $resp, $url ) ) {
	    CODE_REF eq ref $code
		or return $self->_fail( $link, "redirected to $resp->{url}" );
	}

	return 0;

    } else {

	$self->skip_server_errors()
	    and $resp->{status} =~ m/ \A 5 /smx
	    and return $self->_skip( $link,
		"not checked: server error $resp->{status} $resp->{reason}" );

	return $self->_fail( $link,
	    "broken: $resp->{status} $resp->{reason}" );

    }
}

{
    my %checked;

    sub _has_usable {
	my ( $module, $version ) = @_;

	unless ( exists $checked{$module} ) {
	    local $@ = undef;
	    ( my $fn = "$module.pm" ) =~ s| :: |/|smxg;
	    eval {
		require $fn;
		$checked{$module} = 1;
		1;
	    } or do {
		$checked{$module} = 0;
	    };
	}

	$checked{$module}
	    or return;

	if ( defined $version ) {
	    my $rslt = 1;
	    local $SIG{__DIE__} = sub { $rslt = undef };
	    $module->VERSION( $version );
	    return $rslt;
	}

	return 1;
    }
}

sub _is_perl_file {
    my ( undef, $path ) = @_;
    -e $path
	and -T _
	or return;
    $path =~ m/ [.] (?: (?i: pl ) | pm | pod | t ) \z /smx
	and return 1;
    open my $fh, '<', $path
	or return;
    local $_ = <$fh> || '';
    close $fh;
    return m/ perl /smx;
}

{
    my $bareword;

    sub _is_perl_function {
	my ( undef, $word ) = @_;
	$bareword ||= {
	    map { $_ => 1 } @B::Keywords::Functions, @B::Keywords::Barewords };
	return $bareword->{$word};
    }
}

{
    my %ignore;
    BEGIN {
	%ignore = map { $_ => 1 } __PACKAGE__, qw{ DB File::Find };
    }

    sub _nest_depth {
	my $nest = 0;
	$nest++ while $ignore{ caller( $nest ) || '' };
	return $nest;
    }
}

package My_Parser;		## no critic (ProhibitMultiplePackages)

use Pod::Simple::PullParser;	# Core since 5.9.3 (part of Pod::Simple)

@My_Parser::ISA = qw{ Pod::Simple::PullParser };

my %section_tag = map { $_ => 1 } qw{ head1 head2 head3 head4 item-text };

sub new {
    my ( $class ) = @_;
    my $self = $class->SUPER::new();
    $self->preserve_whitespace( 1 );
    return $self;
}

sub run {
    my ( $self, $source, $err, @err_arg ) = @_;
	defined $source
	    and $self->set_source( $source );
    my $attr = $self->_attr();
    @{ $attr }{ qw{ line links sections ignore_tag } } = ( 1, [], {}, [] );
    while ( my $token = $self->get_token() ) {
	if ( my $code = $self->can( '__token_' . $token->type() ) ) {
	    $code->( $self, $token );
	}
    }
    $err
	and $self->any_errata_seen()
	and $err->( @err_arg );
    return wantarray ?
	( $attr->{sections}, $attr->{links} ) :
	$attr->{sections};
}

sub _attr {
    my ( $self ) = @_;
    return $self->{ ( __PACKAGE__ ) } ||= {};
}

sub _normalize_text {
    my ( $text ) = @_;
    defined $text
	or $text = '';
    $text =~ s/ \A \s+ //smx;
    $text =~ s/ \s+ \z //smx;
    $text =~ s/ \s+ / /smxg;
    return $text;
}

sub __token_start {
    my ( $self, $token ) = @_;
    my $attr = $self->_attr();
    if ( defined( my $line = $token->attr( 'start_line' ) ) ) {
	$attr->{line} = $line;
    }
    my $tag = $token->tag();
    if ( 'L' eq $tag ) {
	$token->attr( line_number => $self->{My_Parser}{line} );
	foreach my $name ( qw{ section to } ) {
	    my $sect = $token->attr( $name )
		or next;
	    @{ $sect }[ 2 .. $#$sect ] = ( _normalize_text( "$sect" ) );
	}
	push @{ $attr->{links} }, [ @{ $token }[ 1 .. $#$token ] ];
    } elsif ( 'X' eq $tag ) {
	push @{ $attr->{ignore_tag} }, $tag;
    } elsif ( $section_tag{$tag} ) {
	$attr->{text} = '';
    }
    return;
}

sub __token_text {
    my ( $self, $token ) = @_;
    my $attr = $self->_attr();
    return if @{ $attr->{ignore_tag} };
    my $text = $token->text();
    $attr->{line} += $text =~ tr/\n//;
    $attr->{text} .= $text;
    return;
}

sub __token_end {
    my ( $self, $token ) = @_;
    my $attr = $self->_attr();
    my $tag = $token->tag();
    if ( $section_tag{$tag} ) {
	$attr->{sections}{ _normalize_text( delete $attr->{text} ) } = 1;
    } elsif( @{ $attr->{ignore_tag} } && $tag eq $attr->{ignore_tag}[-1] ) {
	pop @{ $attr->{ignore_tag} };
    }
    return;
}

1;

__END__