File Coverage

blib/lib/WWW/GoKGS.pm

Criterion	Covered	Total	%
statement	104	108	96.3
branch	14	18	77.7
condition	5	9	55.5
subroutine	31	32	96.8
pod	10	11	90.9
total	164	178	92.1

package WWW::GoKGS;
use 5.008_009;
use strict;
use warnings;
use Carp qw/croak/;
use HTML::TreeBuilder::XPath;
use LWP::RobotUA;
use URI;
use WWW::GoKGS::Scraper::GameArchives;
use WWW::GoKGS::Scraper::Top100;
use WWW::GoKGS::Scraper::TournList;
use WWW::GoKGS::Scraper::TournInfo;
use WWW::GoKGS::Scraper::TournEntrants;
use WWW::GoKGS::Scraper::TournGames;
use WWW::GoKGS::Scraper::TzList;

our $VERSION = '0.21';

sub _tree_builder_class { 'HTML::TreeBuilder::XPath' }

sub new {
    my $class = shift;
    my %args = @_ == 1 ? %{$_[0]} : @_;
    my $self = bless {}, $class;

    for my $key (qw/user_agent/) {
        $self->{$key} = $args{$key} if exists $args{$key};
    }

    $self->init( \%args );

    $self;
}

sub init {
    my ( $self, $args ) = @_;

    unless ( exists $self->{user_agent} ) {
        my $class = ref $self;

        $self->user_agent(
            LWP::RobotUA->new(
                agent => $args->{agent} || "$class/" . $class->VERSION,
                from => $args->{from},
                cookie_jar => $args->{cookie_jar},
            )
        );
    }

    return;
}

sub user_agent {
    my $self = shift;
    $self->{user_agent} = shift if @_;
    $self->{user_agent};
}

sub agent {
    my ( $self, @args ) = @_;
    $self->user_agent->agent( @args );
}

sub from {
    my ( $self, @args ) = @_;
    $self->user_agent->default_header( 'From', @args );
}

sub cookie_jar {
    my ( $self, @args ) = @_;
    $self->user_agent->cookie_jar( @args );
}

sub get {
    my ( $self, @args ) = @_;
    $self->user_agent->get( @args );
}

sub _scrapers {
    my $self = shift;
    $self->{_scrapers} ||= $self->__build_scrapers;
}

BEGIN { # install scrapers
    my %scrapers = (
        game_archives  => 'WWW::GoKGS::Scraper::GameArchives',
        top_100        => 'WWW::GoKGS::Scraper::Top100',
        tourn_list     => 'WWW::GoKGS::Scraper::TournList',
        tourn_info     => 'WWW::GoKGS::Scraper::TournInfo',
        tourn_entrants => 'WWW::GoKGS::Scraper::TournEntrants',
        tourn_games    => 'WWW::GoKGS::Scraper::TournGames',
        tz_list        => 'WWW::GoKGS::Scraper::TzList',
    );

    my %paths;
    while ( my ($method, $class) = each %scrapers ) {
        my $path = $paths{$class} = $class->build_uri->path;
        my $body = sub { $_[0]->get_scraper($path) };
        no strict 'refs';
        *$method = $body;
    }

    sub __build_scrapers {
        my $self = shift;
        my $class = ref $self;

        my %_scrapers;
        while ( my ($scraper, $path) = each %paths ) {
            $_scrapers{$path} = $scraper->new(
                _tree_builder_class => $class->_tree_builder_class,
                user_agent => $self->user_agent,
            );
        }

        \%_scrapers;
    }
}

sub get_scraper {
    my ( $self, $path ) = @_;
    $self->_scrapers->{$path};
}

sub each_scraper {
    my ( $self, $code ) = @_;
    my %scrapers = %{ $self->_scrapers };

    croak 'Not a CODE reference' unless ref $code eq 'CODE';

    while ( my ($path, $scraper) = each %scrapers ) {
        $code->( $path => $scraper );
    }

    return;
}

sub can_scrape {
    my $self = shift;
    my $uri = $self->_build_uri( shift );
    my $path = $uri =~ m{^http://www\.gokgs\.com(?::80)?/} && $uri->path;
    $path ? $self->get_scraper( $path ) : undef;
}

sub scrape {
    my ( $self, $arg ) = @_;
    my $uri = $self->_build_uri( $arg );
    my $scraper = $self->can_scrape( $uri );
    croak "Don't know how to scrape '$arg'" unless $scraper;
    $scraper->scrape( $self->get($uri), $uri );
}

sub _build_uri {
    my $self = shift;
    my $uri = URI->new( shift );
    $uri->scheme( 'http' ) unless $uri->scheme;
    $uri->authority( 'www.gokgs.com' ) unless $uri->authority;
    $uri;
}

1;

__END__