File Coverage

blib/lib/WWW/Find.pm

Criterion	Covered	Total	%
statement	21	45	46.6
branch	0	6	0.0
condition	0	5	0.0
subroutine	7	13	53.8
pod	0	6	0.0
total	28	75	37.3

package WWW::Find;

use 5.006;
use strict;
use warnings;
use Carp;
use URI;
use URI::Heuristic;
use HTML::LinkExtor;

our $VERSION = '0.07';
my $depth = 0;
my %seen;

# Default URL matching subroutine
sub match_sub {
    my($self) = shift;

## tests for URL's matching this REGEX
    if($self->{REQUEST}->uri =~ /html?$/io) {

## do something with matching URL's
## print to STDOUT is the default action
        print $self->{REQUEST}->uri . "\n";
    }
    return
}

## Default URL follow subtroutine
## Should return true or false
sub follow_sub {
    my $self = shift;
    my $header = HTTP::Request->new(HEAD => $self->{REQUEST}->uri);
    my $response = $self->{AGENT}->request($header) || next;
    $response->content_type eq 'text/html' && ref($self->{REQUEST}->uri) eq 'URI::http'
    ? return 1
    : return 0
}

## Private methods

my $_rec;
$_rec = sub {
    my $find_obj = shift;
    my $uri = URI->new($find_obj->{REQUEST}->uri);
#    $seen{$uri}++;
#    return if($seen{$uri} > 1);
    return if($depth > $find_obj->{MAX_DEPTH});
    $depth++;

## Request HTML Document
    my $html = $find_obj->{AGENT}->request($find_obj->{REQUEST});

## Parse out HREF links
    my $parser = HTML::LinkExtor->new(undef);
    $parser->parse($html->content);
    my @links = $parser->links;
    foreach my $ln (@links)
    {
       my @element = @$ln;
       my $type = shift @element;
       next unless($type =~ /^a/io);
       while(@element)
       {
           my ($name, $value) = splice(@element, 0, 2);

## Make URL absolute
           $find_obj->{REQUEST}->uri(URI->new_abs($value, $uri));
           my $url = $find_obj->{REQUEST}->uri;

## Check recursion depth
           next if($depth > $find_obj->{MAX_DEPTH});

## Skip if duplicate
	   $seen{$url}++;
	   next if($seen{$url} > 1);
## User defined matching subroutine
           $find_obj->{MATCH_SUB}($find_obj);

## Check recursion depth
#           next if($depth > $find_obj->{MAX_DEPTH});

## Modify request object for next request
           if(ref($find_obj->{REQUEST}->uri))
           {
               $find_obj->{REQUEST}->uri(URI::Heuristic::uf_urlstr($find_obj->{REQUEST}->uri));

## User defined follow subroutine
               &$_rec($find_obj) if ($find_obj->{FOLLOW_SUB}($find_obj));
           }
       }
   }
   $depth--;

};

# constructor
sub new
{
    my($class, %parm) = @_;
    croak 'Expecting a class' if ref $class;
    my $self = { MAX_DEPTH => 2,
                 DIRECTORY => '.',
                 MATCH_SUB => \&match_sub,
                 FOLLOW_SUB => \&follow_sub
    };
## Parms should be validated, but I'm feeling lazy
    while(my($k, $v) = each(%parm)) { $self->{$k} = $v};
    bless $self, $class;
    return $self;
}

## Public methods
sub go {
    my($self, %parm) = @_;
    $self->{REQUEST}->uri(URI::Heuristic::uf_urlstr($self->{REQUEST}->uri));
    &$_rec($self);
}

sub set_match {
   my($self, $sub_ref) = @_;
   $self->{MATCH_SUB} = $sub_ref;
   return $self->{MATCH_SUB};
}

sub set_follow {
   my($self, $sub_ref) = @_;
   $self->{FOLLOW_SUB} = $sub_ref;
   return $self->{FOLLOW_SUB};
}

1;

__END__