File Coverage

blib/lib/WWW/SimpleRobot.pm

Criterion	Covered	Total	%
statement	74	85	87.0
branch	19	38	50.0
condition	1	3	33.3
subroutine	10	10	100.0
pod	0	2	0.0
total	104	138	75.3

package WWW::SimpleRobot;

#==============================================================================
#
# Standard pragmas
#
#==============================================================================

require 5.005_62;
use strict;
use warnings;

#==============================================================================
#
# Required modules
#
#==============================================================================

use URI;
use LWP::Simple;
use HTML::LinkExtor;

#==============================================================================
#
# Private globals
#
#==============================================================================

our $VERSION = '0.07';
our %OPTIONS = (
    URLS                => [],
    FOLLOW_REGEX        => '',
    VISIT_CALLBACK      => sub {},
    BROKEN_LINK_CALLBACK=> sub {},
    VERBOSE             => 0,
    DEPTH               => undef,
    TRAVERSAL           => 'depth',
);

#==============================================================================
#
# Private methods
#
#==============================================================================

sub _verbose
{
    my $self = shift;

    return unless $self->{VERBOSE};
    print STDERR @_;
}

#==============================================================================
#
# Constructor
#
#==============================================================================

sub new
{
    my $class = shift;
    my %args = ( %OPTIONS, @_ );

    for ( keys %args )
    {
        die "Unknown option $_\n" unless exists $OPTIONS{$_};
    }
    unless ( $args{TRAVERSAL} =~ /^(depth|breadth)$/ )
    {
        die "option TRAVERSAL should be either 'depth' or 'breadth'\n";
    }

    my $self = bless \%args, $class;

    return $self;

}

#==============================================================================
#
# Public methods
#
#==============================================================================

sub traverse
{
    my $self = shift;

    die "No URLS specified in constructor\n" unless @{$self->{URLS}};
    $self->_verbose(
        "Creating list of files to index from @{$self->{URLS}}...\n"
    );
    my @pages;
    my %seen;
    for my $url ( @{$self->{URLS}} )
    {
        my $uri = URI->new( $url );
        die "$uri is not a valid URL\n" unless $uri;
        die "$uri is not a valid URL\n" unless $uri->scheme;
        die "$uri is not a web page\n" unless $uri->scheme eq 'http';
        die "can't HEAD $uri\n" unless
            my ( $content_type, $document_length, $modified_time ) =
                head( $uri )
        ;
        $uri = $uri->canonical->as_string;
        $seen{$uri}++;
        my $page = {
            modified_time => $modified_time,
            url => $uri,
            depth => 0,
            linked_from => $url,
        };
        push( @pages, $page );
    }
    while ( my $page = shift( @pages ) )
    {
        my $url = $page->{url};
        $self->_verbose( "GET $url\n" );
        my $html = get( $url );
        unless( $html )
        {
            $self->{BROKEN_LINK_CALLBACK}( $url, $page->{linked_from}, $page->{depth} );
        }
        $self->_verbose( "Extract links from $url\n" );
        my $linkxtor = HTML::LinkExtor->new( undef, $url );
        $linkxtor->parse( $html );
        my @links = $linkxtor->links;
        $self->{VISIT_CALLBACK}( $url, $page->{depth}, $html, \@links );
        next if defined( $self->{DEPTH} ) and $page->{depth} == $self->{DEPTH};
        for my $link ( @links )
        {
            my ( $tag, %attr ) = @$link;
            next unless $tag eq 'a';
            next unless my $href = $attr{href};
            $href =~ s/[#?].*$//;
            next unless $href = URI->new( $href );
            $href = $href->canonical->as_string;
            next unless $href =~ /$self->{FOLLOW_REGEX}/;
            my ( $content_type, undef, $modified_time ) = head( $href );
            next unless $content_type;
            next unless $content_type eq 'text/html';
            next if $seen{$href}++;
            my $npages = @pages;
            my $nseen = keys %seen;
            my $page = {
                modified_time => $modified_time,
                url => $href,
                depth => $page->{depth}+1,
            };
            splice(
                @pages,
                $self->{TRAVERSAL} eq 'depth' ? 0 : @pages,
                # depth first ... unshift, breadth first ... push
                0,
                $page
            );
            $self->_verbose(
                "$nseen/$npages : $url : $href",
                " : ", join( ' ', map { $_->{url} } @pages ),
                "\n"
            );
        }
    }
    $self->{pages} = \@pages;
    $self->{urls} = [ map { $_->{url} } @pages ];
}

#==============================================================================
#
# AUTOLOADed accessor methods
#
#==============================================================================

sub AUTOLOAD
{
    my $self = shift;
    my $value = shift;
    use vars qw( $AUTOLOAD );
    my $method_name = $AUTOLOAD;
    $method_name =~ s/.*:://;
    $self->{$method_name} = $value if defined $value;
    return $self->{$method_name};
}

# Preloaded methods go here.

1;
__END__