1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
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
|