root/lang/perl/WWW-CommentGetter/trunk/WWW-CommentGetter/lib/WWW/CommentGetter.pm @ 1957

package WWW::CommentGetter;
use strict;
use warnings;
use Carp;
use HTTP::Response::Encoding;
use Encode;
use LWP::UserAgent;
use HTML::TreeBuilder::XPath;
use File::ShareDir 'module_file';
use JSON::Any;

our $VERSION = '0.01';

sub new {
    my ($class, ) = @_;
    bless {}, $class;
}

sub _load_site_info {
    my $self = shift;
    $self->{__siteinfos} ||= do {
        my $fname = module_file(__PACKAGE__, 'siteinfo.json');

        open my $fh, '<', $fname or die $!;
        my $src = do { local $/; join '', <$fh> };
        close $fh;

        JSON::Any->jsonToObj($src);
    };
}

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

    my $siteinfos = $self->_load_site_info;
    for my $siteinfo (@$siteinfos) {
        my $ret = scrape_by_siteinfo($url => $siteinfo);
        return $ret if $ret;
    }
    return;
}

sub scrape_by_siteinfo {
    my ($url, $siteinfo) = @_;

    return unless $url =~ $siteinfo->{url};

    my $ua = LWP::UserAgent->new(agent => __PACKAGE__);
    my $res = $ua->get($url);
    unless ($res->is_success) {
        croak "cannot get $url";
    }
    my $content = decode $res->encoding, $res->content;

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

    my $cnt = 1;
    my @nodes = $tree->findnodes($siteinfo->{context});
    my $stash = [];
    for my $node (@nodes) {
        my $s = {};
        while (my ($key, $local_xpath) = each %{$siteinfo->{attributes}}) {
            my $subattr = '';
            if ($local_xpath =~ s/^substring\(([^,]+)([,\s\d]+)\)$/$1/) {
                $subattr = $2;
            }
            warn "get $key by $local_xpath" if $ENV{DEBUG};
            my $xpath = join '', $siteinfo->{context}, "[$cnt]", $local_xpath;
            if ($subattr) {
                $xpath = "substring(string($xpath)$subattr)";
            }
            warn $xpath if $ENV{DEBUG};
            if ($subattr) {
                $s->{$key} = trim($tree->findvalue($xpath));
            } else {
                $s->{$key} = as_text($tree->findnodes($xpath)->[0]);
            }
        }
        push @$stash, $s;

        $cnt++;
    }

    $tree = $tree->delete;

    return $stash;
}

sub as_text {
    my $element = shift;

    if ($element->isTextNode) {
        trim($element->string_value);
    } else {
        trim($element->as_text);
    }
}

sub trim {
    local $_ = shift;
    s/^\s*//;
    s/\s*$//;
    return $_;
}

1;

__END__

=head1 NAME

WWW::CommentGetter - scraping comments from blogs

=head1 SYNOPSIS

  use WWW::CommentGetter;
  my $wcg = WWW::CommentGetter->new();
  $wcg->get('http://blog.livedoor.jp/dankogai/archives/50935001.html');

=head1 DESCRIPTION

get the comment from blogs.

=head1 METHODS

=head2 new

  my $wcg = WWW::CommentGetter->new('/path/to/assets/');

constructer.

=head2 get

  $wcg->get('http://blog.livedoor.jp/dankogai/archives/50935001.html');

get comments from permalink.

=head1 AUTHOR

Tokuhiro Matsuno <tokuhirom aaaatttt gmail dotottto commmmm>

=head1 COPYRIGHT

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.

=cut