flickr_fetcher.plは、元々は引数でキーワードを入れるという、とてもフレキシブルなスクリプトです。
元ネタ
ゆーすけべー日記: Flickr からキーワードにマッチした写真を一括ダウンロードする Perl スクリプト「flickr_fetcher.pl」
が、前エントリーでは、プログラムの中に直接書き込む事を選んだので、別のキーワードで画像を探すときにはその部分を変更してやる必要が出てきます。
ローマ字や英語でキーワードを入れる場合はかまいませんが、日本語の検索は標準のコマンドプロンプトでは無理なのです。
本来なら配布されているプログラムの中身を変えるのは、配布元で更新があったときに、それに対応するのが面倒なので、できれば変えたくない。
実際、このスクリプトの場合はページの最大値を求める計算方法が変わった。
勝手に改造した部分には変更はなかったが、こういうのは精神衛生上良くない。
…と思いながらソースを見ていると、モジュールとスクリプトを分けて記述してあることに気づいた。
実際の実行部（スクリプト部分）はたったの2行（宣言と空白を入れて4行）だった。
package main;
my $fetcher = FlickrFetcher->new_with_options();
$fetcher->run();ここだけを別のファイルに切り分けて、FlickrFetcherモジュールを使うようにすれば、スクリプトファイルを別で用意すればいいので、それほどややこしくない。
今回は、スクリプトファイルの中身は簡単でしたが、keywordとdirのデータを沢山揃えてfor文でfetchに流してやれば、かなり収集が便利になるでしょう。
というところで、モジュール化したFlickrFetcherですが、現時点で二つほど改善点があります。
どちらも、fetchルーチン内です。
一つは「Transfer truncated」で止まってしまう事がある問題です。
細かく調べてはいませんが、止まらなければ良いので、evalで括ってしまいました。
本来ならリトライを頑張るところでしょうが、そのあたりは誰かにおまかせです。
もう一つは、検索結果が1枚だけの時にループで「Not an ARRAY reference」と言われてしまいます。
parse_responseメソッドの親切心（？）が仇になっているのでしょうか？
ともあれ、ARRAY referenceでない場合はARRAY referenceに変換するようにしました。
あと、モジュールにはしましたが、podは変更してません。
FlickrFetcher.pm
package FlickrFetcher;
use Moose;
use Moose::Util::TypeConstraints;
use Params::Coerce ();
use Digest::MD5 qw(md5_hex);
use Encode;
use LWP::UserAgent;
use Path::Class;
use POSIX qw(ceil);
use WebService::Simple;
use WebService::Simple::Parser::XML::Simple;
use XML::Simple;
use Perl6::Say;
our $VERSION = '0.01';
with 'MooseX::Getopt';
subtype 'Dir' => as 'Object' => where { $_->isa('Path::Class::Dir') };
coerce 'Dir' => from 'Str' => via { Path::Class::Dir->new($_) };
MooseX::Getopt::OptionTypeMap->add_option_type_to_map( 'Dir' => '=s' );
has 'keyword' => ( is => 'rw', isa => 'Str', required => 1 );
has 'dir' => ( is => 'rw', isa => 'Dir', required => 1, coerce => 1 );
has 'api_key' => ( is => 'rw', isa => 'Str' );
has 'license' => ( is => 'rw', isa => 'Int' );
has '_perpage' => ( is => 'ro', isa => 'Int', default => 500 );
has '_flickr' => ( is => 'rw', isa => 'WebService::Simple' );
has '_ua' => (
is => 'ro',
isa => 'LWP::UserAgent',
default => sub { LWP::UserAgent->new( keep_alive => 1 ) }
);
sub BUILD {
my ( $self, $args ) = @_;
unless ( $self->api_key ) {
if ( my $api_key = $ENV{FLICKR_API_KEY} ) {
$self->api_key($api_key);
}
else {
die "api_key is required\n";
}
}
my $xs = XML::Simple->new( KeepRoot => 1, keyattr => [] );
my $parser = WebService::Simple::Parser::XML::Simple->new( xs => $xs );
my $flickr = WebService::Simple->new(
base_url => "http://api.flickr.com/services/rest/",
param => { api_key => $self->api_key },
response_parser => $parser,
);
$self->_flickr($flickr);
}
__PACKAGE__->meta->make_immutable;
no Moose;
sub run {
my $self = shift;
mkdir $self->dir->relative if !-d $self->dir->is_absolute;
say "search keyword : " . $self->keyword;
my $photo_total = $self->photo_total( $self->keyword );
say "total count : " . $photo_total;
my $pages = ceil( $photo_total / $self->_perpage );
for my $current_page ( 1 .. $pages ) {
say "search page : $current_page";
$self->search( $self->keyword, $current_page, $self->_perpage );
}
}
sub search {
my ( $self, $keyword, $page , $perpage) = @_;
my $response = $self->_flickr->get(
{
method => "flickr.photos.search",
text => $keyword,
per_page => $perpage,
sort => 'date-posted-desc',
extras => 'date_upload',
page => $page,
license => $self->license || "",
}
);
my $xml = $response->parse_response;
$self->fetch($xml->{rsp}->{photos}->{photo});
}
sub fetch {
my ( $self, $photo_ref ) = @_;
$photo_ref = ref $photo_ref eq 'ARRAY' ? $photo_ref : [$photo_ref];# 要素が一つのとき対策
for my $photo ( @$photo_ref ){
my $url = $self->photo_url( $photo->{id} );
my $file = $self->dir->file( md5_hex($url) . ".jpg" );
my $res;
eval { $res = $self->_ua->mirror( $url, $file ); };# 「Transfer truncated」対策。ここから
if ($@) {
say $@;
} else {
say "try to fetch : " . $res->status_line . " : $url";
}# ここまで
}
}
sub photo_url {
my ( $self, $photo_id ) = @_;
my $response = $self->_flickr->get(
{
method => "flickr.photos.getSizes",
photo_id => $photo_id
}
);
my $xml = $response->parse_response;
my $largest_ref = pop @{ $xml->{rsp}->{sizes}->{size} };
return $largest_ref->{source};
}
sub photo_total {
my ( $self, $keyword ) = @_;
my $response = $self->_flickr->get(
{
method => "flickr.photos.search",
text => $keyword,
per_page => 1,
license => $self->license || "",
}
);
my $xml = $response->parse_response;
return $xml->{rsp}->{photos}->{total};
}
1;
__END__
=head1 NAME
flickr_fetcher.pl - Fetch Flickr photos by keyword
=head1 SYNOPSIS
./flickr_fetcher.pl --keyword hoge --dir hoge --api_key yourflickrapikey
=head1 AUTHOR
Yusuke Wada E<lt>yusuke (at) kamawada.comE<gt>
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
flickr_fetcher.pl
#!/usr/bin/perl
# ｕｔｆ８
use strict;
use warnings;
use FlickrFetcher;
fetch({
keyword => '石原さとみ',
dir => 'satomi_ishihara',
});
sub fetch {
my $rh_arg = shift;
my $fetcher = FlickrFetcher->new_with_options( %{$rh_arg} );
$fetcher->run();
}
コメントする