4koma download

gistfile1.pl

use strict;
use warnings;
use utf8;

use Data::Dumper;

MAIN: {

    my $yonkoma = YonKoma->new(
        CREATORS_URL => "http://4koma.livedoor.com/creator/",
        wait         => 0.2
    );
    $yonkoma->download_all();
}

{
    package YonKoma;

    use File::Path;
    use Furl;
    use Log::Minimal;
    use Path::Class qw/file/;
    use Time::HiRes qw/sleep/;
    use URI;
    use Web::Scraper;

    sub new {
        my ($klass, @args) = @_;
        return bless {@args}, $klass;
    }

    sub furl {
        my ($self) = @_;
        $self->{_furl} ||= Furl->new;
        return $self->{_furl}
    }

    sub download_all {
        my ( $self ) = @_;
        my ($title, $creator_urls) = $self->get_urls( $self->{CREATORS_URL} );

    GET_CREATOR_URL:
        for my $creator_url ( @{$creator_urls} ) {
            my ($title, $yonkoma_urls) = $self->get_urls( $creator_url );
            my $creator_name = $self->extract_creator_name($title);

            infof("get 4koma of %s 先生", $creator_name);

        GET_4KOMA_URL:
            for my $yonkoma_url ( @{$yonkoma_urls} ) {
                my $result = $self->scrape_4koma($yonkoma_url);
                my $list = $self->extract_4koma_urls_from_script($result->{script});

                $self->download_4koma($list, $creator_name);
                sleep $self->{wait};
            }
        }
    }

    sub download_4koma {
        my ( $self, $list, $creator_name ) = @_;
        for my $url ( @{ $list } ) {
            eval {
                $self->download_image($creator_name, $url);
            };
            if ($@) {
                critf("Can't download %s", $url);
            }
        }
    }

    sub extract_creator_name {
        my ( $self, $title ) = @_;
        $title =~ s{\A (.+) \s+ 先生 .* \z}{$1}xms;
        return $title;
    }

    sub get_urls {
        my ( $self, $uri, $title, $yonkoma_urls ) = @_;

        my $result = $self->scrape_list_page($uri);
        push @{$yonkoma_urls}, @{ $result->{links} };

        $title = $result->{title} unless $title;

        return ($title, $yonkoma_urls)
            unless $result->{next_text} =~ m{次の}xms;

        $self->get_urls($result->{next_url}, $title, $yonkoma_urls);
    }

    sub scrape_list_page {
        my ( $self, $uri ) = @_;

        $uri = URI->new($uri);
        my $scraper = scraper {
            process '/html//table//tr/td/a', 'links[]' => '@href';
            process 'title', 'title' => 'TEXT';
            process "//div[contains(concat(' ', \@class, ' '), ' paging ')][last()]//li[last()]/a",
                next_url => '@href',
                next_text => 'TEXT';
        };

        my $result = $scraper->scrape($uri);

        infof("scraped %s: %s", $result->{title}, $result->{uri});
        return $result;
    }

    sub scrape_4koma {
        my ( $self, $uri ) = @_;

        $uri = URI->new($uri);

        my $scraper = scraper {
            process 'title', title => 'TEXT';
            process "id('viewer-wrapper')/script", script => 'HTML';
        };

        my $result = $scraper->scrape($uri);

        infof("scraped 4koma %s: %s", $result->{title}, $result->{uri});
        return $result;
    }

    sub extract_4koma_urls_from_script {
        my ( $self, $script ) = @_;
        if ( $script =~ m{images: \s+ \[ \s+ (.*) \s+ \]}xms ) {
            my $images = $1;
            my @urls = ();
            for my $url ( $images =~ m{ "(.+?)",? \s+ }xmsg ) {
                push @urls, $url;
            }
            return \@urls;
        }

        return ;
    }

    sub download_path {
        my ($self, $creator_name, $path) = @_;
        $path =~ s{\A .* work/ .*? / (.+) \z}{$1}xms;
        return file(sprintf "4koma/%s/%s", $creator_name, $path);
    }

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

        my $file = $self->download_path($creater_name, $url);
        $file->parent->mkpath;

        infof("download to %s from %s (%s)", $url, $file, $creater_name);
        my $fh = $file->open('w') or die $!;
        $self->furl->request(
            url => $url,
            write_file => $fh,
        ) or die $!;
    }

    1;
}