File Coverage

blib/lib/WWW/Scraper/Lite.pm

Criterion	Covered	Total	%
statement	76	80	95.0
branch	16	20	80.0
condition			n/a
subroutine	13	13	100.0
pod	8	8	100.0
total	113	121	93.3

# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
# vim:ts=8:sw=2:et:sta:sts=2
#########
# Author:        rmp
# Last Modified: $Date: 2011-06-02 22:46:31 +0100 (Thu, 02 Jun 2011) $
# Id:            $Id: Lite.pm 15 2011-06-02 21:46:31Z rmp $
# Source:        $Source$
# $HeadURL: svn+ssh://psyphi.net/repository/svn/www-scraper-lite/trunk/lib/WWW/Scraper/Lite.pm $
#
package WWW::Scraper::Lite;
use strict;
use warnings;
use LWP::UserAgent;
use HTML::TreeBuilder::XPath;
use Carp;

our $VERSION = do { my ($r) = q$Revision: 15 $ =~ /(\d+)/smx; $r; };

sub new {
  my ($class, $ref) = @_;
  if(!$ref) {
    $ref = {};
  }

  bless $ref, $class;

  $ref->{queue} = [];
  $ref->{seen}  = {};

  return $ref;
}

sub ua {
  my $self = shift;

  if(!$self->{ua}) {
    $self->{ua} = LWP::UserAgent->new();
  }

  return $self->{ua};
}

sub crawl {
  my ($self, $url_in, $callbacks) = @_;

  $self->enqueue($url_in);

  while(my $url = $self->dequeue()) {
    $self->{current} = {};
    my $current = $self->{current};

    if($self->{seen}->{$url}++) {
      #########
      # already fetched $url
      #
      next;
    }

    $current->{url} = $url;
    my $res = $self->ua->get($url);
    $current->{response} = $res;

    my $tree = HTML::TreeBuilder::XPath->new;
    $tree->parse_content($res->content);

    while(my ($pattern, $cb) = each %{$callbacks}) {
      my $nb = $tree->findnodes($pattern);
      for my $node (@{$nb}) {
	$cb->($self, $node);
      }
    }

    #########
    # now the recommended cleanup
    #
    $tree->delete;
  }
  return 1;
}

sub enqueue {
  my ($self, @urls) = @_;
  push @{$self->{queue}}, grep { defined } @urls;
  return 1;
}

sub dequeue {
  my $self = shift;
  my $url  = shift @{$self->{queue}};
  return $url;
}

sub current {
  my $self = shift;
  return $self->{current};
}

sub url_remove_anchor {
  my ($self, $url) = @_;
  if(!$url) {
    return;
  }

  $url =~ s{[#].*}{}smx;
  return $url;
}

sub url_make_absolute {
  my ($self, $url)   = @_;

  if(!$url) {
    return q[];
  }

  my $current          = $self->current;
  my $current_url      = $current->{url};
  if(!$current_url) {
    return;
  }
  my ($current_domain) = $current_url =~ m{^([[:lower:]]+://[^/]+)}smix;
  my ($current_dir)    = $current_url =~ m{^([[:lower:]]+://.*/)}smix;

  if(!$current_dir) {
    $current_dir = q[/];
  }

  if($url =~ m{^mailto:}smix) {
    return $url;
  }

  if($url =~ m{^[[:lower:]]+://}smix) {
    #########
    # already absolute
    #
    return $url;
  }

  if($url =~ m{^/}smx) {
    #########
    # yield $domain$url
    #
    return "$current_domain$url";
  }

  return "$current_dir$url";
}

1;
__END__