File Coverage

blib/lib/Test/Pod/No404s.pm

Criterion	Covered	Total	%
statement	31	78	39.7
branch	0	22	0.0
condition	0	6	0.0
subroutine	9	12	75.0
pod	2	2	100.0
total	42	120	35.0

# Declare our package
package Test::Pod::No404s;
use strict; use warnings;

# Initialize our version
use vars qw( $VERSION );
$VERSION = '0.01';

# Import the modules we need
use Pod::Simple::Text;
use LWP::UserAgent;
use URI::Find;
require Test::Pod;

# setup our tests and etc
use Test::Builder;
my $Test = Test::Builder->new;

# Thanks to Test::Pod for much of the code here!
sub import {
	my $self = shift;
	my $caller = caller;

	for my $func ( qw( pod_file_ok all_pod_files_ok ) ) {
		no strict 'refs';	## no critic ( ProhibitNoStrict )
		*{$caller."::".$func} = \&$func;
	}

	$Test->exported_to($caller);
	$Test->plan(@_);
}

sub pod_file_ok {
	my $file = shift;
	my $name = @_ ? shift : "404 test for $file";

	if ( ! -f $file ) {
		$Test->ok( 0, $name );
		$Test->diag( "$file does not exist" );
		return;
	}

	# Parse the POD!
	my $parser = Pod::Simple::Text->new;
	my $output;
	$parser->output_string( \$output );
	$parser->parse_file( $file );

	# is POD well-formed?
	if ( $parser->any_errata_seen ) {
		$Test->ok( 0, $name );
		$Test->diag( "Unable to parse POD in $file" );
		return 0;
	}

	# Did we see POD in the file?
	if ( $parser->doc_has_started ) {
		my @links;
		my $finder = URI::Find->new( sub {
			my $uri = shift;
			my $scheme = $uri->scheme;
			if ( defined $scheme and ( $scheme eq 'http' or $scheme eq 'https' ) ) {
				# Make sure we have unique links...
				if ( ! grep { $_->eq( $uri ) } @links ) {
					push @links, $uri;
				}
			}
		} );
		$finder->find( \$output );

		if ( scalar @links ) {
			# Verify the links!
			my $ok = 1;
			my @errors;
			my $ua = LWP::UserAgent->new;
			foreach my $l ( @links ) {
				my $response = $ua->head( $l );
				if ( $response->is_error ) {
					$ok = 0;
					push( @errors, [ $l->as_string, $response->status_line ] );
				}
			}

			if ( $ok ) {
				$Test->ok( 1, $name );
			} else {
				$Test->ok( 0, $name );
				foreach my $e ( @errors ) {
					$Test->diag( "Error retrieving '$e->[0]': $e->[1]" );
				}
			}
		} else {
			$Test->ok( 1, $name );
		}
	} else {
		$Test->ok( 1, $name );
	}

	return 1;
}

sub all_pod_files_ok {
	my @files = @_ ? @_ : Test::Pod::all_pod_files();

	$Test->plan( tests => scalar @files );

	my $ok = 1;
	foreach my $file ( @files ) {
		pod_file_ok( $file ) or undef $ok;
	}

	return $ok;
}

1;
__END__