Commit 76690c51ee539d0993740cdf0c517d5604cfe7f6 - libflickr-upload-perl

Imported Upstream version 1.50 gregor herrmann 8 years ago

9 changed file(s) with 711 addition(s) and 460 deletion(s). Raw diff Collapse all Expand all

+64

-1

ChangeLog less more

0		commit 207251a67870f816fb0d1e6037deef8cc1890503 (HEAD, origin/master, origin/HEAD, master)
	0	commit 14f3bd08c297a95a7243db5f1ab40d36b4760c5e (HEAD, origin/master, origin/HEAD, master)
	1	Author: Steven N. Severinghaus <sns@severinghaus.org>
	2	AuthorDate: Wed Jul 15 12:26:14 2015 -0400
	3	Commit: Steven N. Severinghaus <sns@severinghaus.org>
	4	CommitDate: Wed Jul 15 12:26:14 2015 -0400
	5
	6	Implemented _sign_args because method in Flickr::API is private and has been renamed
	7
	8	commit f0b3c48b031f81b28a5aa44f37a2d77ce782a3c8
	9	Author: Steven N. Severinghaus <sns@severinghaus.org>
	10	AuthorDate: Tue Aug 19 21:11:19 2014 -0400
	11	Commit: Steven N. Severinghaus <sns@severinghaus.org>
	12	CommitDate: Tue Aug 19 21:11:19 2014 -0400
	13
	14	Moved Upload.pm into lib/Flickr/ as is more customary
	15
	16	commit 05a5186b6d588ef2e896851bada9e18fe40b5370
	17	Author: Steven N. Severinghaus <sns@severinghaus.org>
	18	AuthorDate: Tue Aug 19 20:49:31 2014 -0400
	19	Commit: Steven N. Severinghaus <sns@severinghaus.org>
	20	CommitDate: Tue Aug 19 20:49:31 2014 -0400
	21
	22	Updated dependency list in README
	23
	24	Do we really need to maintain this separately?
	25
	26	commit cd14e3d7de96e6c8d6eb16615100268c10478148
	27	Author: Steven N. Severinghaus <sns@severinghaus.org>
	28	AuthorDate: Tue Aug 19 20:47:54 2014 -0400
	29	Commit: Steven N. Severinghaus <sns@severinghaus.org>
	30	CommitDate: Tue Aug 19 20:47:54 2014 -0400
	31
	32	Eliminated dependency on XML::Parser::Lite::Tree
	33
	34	I would rather use XPath, but it seems like XML::Simple is the easiest
	35	solution at this point.
	36
	37	commit 533835ed439bd934d7092555fd0ed4fea7709bb5
	38	Author: Steven N. Severinghaus <sns@severinghaus.org>
	39	AuthorDate: Tue Aug 19 14:04:28 2014 -0400
	40	Commit: Steven N. Severinghaus <sns@severinghaus.org>
	41	CommitDate: Tue Aug 19 14:04:28 2014 -0400
	42
	43	Updated dependencies in README
	44
	45	commit 48a82c79c350c066c941235655c239de02648e51
	46	Author: Steven N. Severinghaus <sns@severinghaus.org>
	47	AuthorDate: Mon Aug 18 12:21:20 2014 -0400
	48	Commit: Steven N. Severinghaus <sns@severinghaus.org>
	49	CommitDate: Mon Aug 18 12:21:20 2014 -0400
	50
	51	Merged in contributions by Assaf Gordon
	52
	53	Assaf has added functionality to put the uploaded photos into a new set and to optionally reverse the order of upload. This merge is very literal so far. I have only tested that the functionality works but have not made any revisions to the code, other than a version bump.
	54
	55	commit 01a38a57a50bd6395ddab1d6d8c2154638754a79
	56	Author: Steven N. Severinghaus <sns@severinghaus.org>
	57	AuthorDate: Mon Aug 18 00:20:54 2014 -0400
	58	Commit: Steven N. Severinghaus <sns@severinghaus.org>
	59	CommitDate: Mon Aug 18 00:20:54 2014 -0400
	60
	61	Appears to require at least Flickr::API 1.09
	62
	63	commit 207251a67870f816fb0d1e6037deef8cc1890503 (tag: 1.4)
1	64	Author: maspotts <maspotts@yahoo.com>
2	65	AuthorDate: Mon Jun 30 21:37:55 2014 -0700
3	66	Commit: maspotts <maspotts@yahoo.com>

-1

MANIFEST less more

10	10	t/request.t
11	11	t/testimage.jpg
12	12	t/upload.t
13		Upload.pm
	13	lib/Flickr/Upload.pm
	14	META.json Module JSON meta-data (added by MakeMaker)

+46

-0

META.json less more

	0	{
	1	"abstract" : "Module for uploading images to flickr.com",
	2	"author" : [
	3	"Christophe Beauregard <cpb@cpan.org>"
	4	],
	5	"dynamic_config" : 1,
	6	"generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.120351",
	7	"license" : [
	8	"unknown"
	9	],
	10	"meta-spec" : {
	11	"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
	12	"version" : "2"
	13	},
	14	"name" : "Flickr-Upload",
	15	"no_index" : {
	16	"directory" : [
	17	"t",
	18	"inc"
	19	]
	20	},
	21	"prereqs" : {
	22	"build" : {
	23	"requires" : {
	24	"ExtUtils::MakeMaker" : "0"
	25	}
	26	},
	27	"configure" : {
	28	"requires" : {
	29	"ExtUtils::MakeMaker" : "0"
	30	}
	31	},
	32	"runtime" : {
	33	"requires" : {
	34	"Flickr::API" : "1.09",
	35	"Getopt::Long" : "1",
	36	"HTTP::Request::Common" : "1",
	37	"LWP::UserAgent" : "1",
	38	"Pod::Usage" : "1",
	39	"XML::Simple" : "2"
	40	}
	41	}
	42	},
	43	"release_status" : "stable",
	44	"version" : "1.5"
	45	}

+24

-24

META.yml less more

0		--- #YAML:1.0
1		name: Flickr-Upload
2		version: 1.4
3		abstract: Module for uploading images to flickr.com
	0	---
	1	abstract: 'Module for uploading images to flickr.com'
4	2	author:
5		- Christophe Beauregard <cpb@cpan.org>
6		license: unknown
7		distribution_type: module
	3	- 'Christophe Beauregard <cpb@cpan.org>'
	4	build_requires:
	5	ExtUtils::MakeMaker: 0
8	6	configure_requires:
9		ExtUtils::MakeMaker: 0
10		build_requires:
11		ExtUtils::MakeMaker: 0
	7	ExtUtils::MakeMaker: 0
	8	dynamic_config: 1
	9	generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.120351'
	10	license: unknown
	11	meta-spec:
	12	url: http://module-build.sourceforge.net/META-spec-v1.4.html
	13	version: 1.4
	14	name: Flickr-Upload
	15	no_index:
	16	directory:
	17	- t
	18	- inc
12	19	requires:
13		Flickr::API: 0.07
14		Getopt::Long: 1
15		HTTP::Request::Common: 1
16		LWP::UserAgent: 1
17		Pod::Usage: 1
18		XML::Parser::Lite::Tree: 0.03
19		no_index:
20		directory:
21		- t
22		- inc
23		generated_by: ExtUtils::MakeMaker version 6.57_05
24		meta-spec:
25		url: http://module-build.sourceforge.net/META-spec-v1.4.html
26		version: 1.4
	20	Flickr::API: 1.09
	21	Getopt::Long: 1
	22	HTTP::Request::Common: 1
	23	LWP::UserAgent: 1
	24	Pod::Usage: 1
	25	XML::Simple: 2
	26	version: 1.5

-3

Makefile.PL less more

12	12
13	13	WriteMakefile(
14	14	NAME => 'Flickr::Upload',
15		VERSION_FROM => 'Upload.pm',
	15	VERSION_FROM => 'lib/Flickr/Upload.pm',
16	16	ABSTRACT => 'Module for uploading images to flickr.com',
17	17	AUTHOR => 'Christophe Beauregard <cpb@cpan.org>',
18	18	PREREQ_PM => {
19	19	'LWP::UserAgent' => 1,
20	20	'HTTP::Request::Common' => 1,
21		'XML::Parser::Lite::Tree' => 0.03,
22		'Flickr::API' => 0.07,
	21	'Flickr::API' => 1.09,
23	22	'Pod::Usage' => 1,
24	23	'Getopt::Long' => 1,
	24	'XML::Simple' => 2.0,
25	25	},
26	26	'EXE_FILES' => [ 'flickr_upload' ],
27	27	'clean' => { FILES => 'ChangeLog META.yml' },

-2

README less more

15	15	DEPENDENCIES
16	16	============
17	17
18		- LWP
19		- XML::Parser::Lite::Tree
	18	- LWP::UserAgent
	19	- HTTP::Request::Common
20	20	- Flickr::API
	21	- Pod::Usage
	22	- Getopt::Long
	23	- XML::Simple
21	24
22	25	EXAMPLES
23	26	========

-428

~~Upload.pm~~ less more

0		package Flickr::Upload;
1
2		use strict;
3		use warnings;
4
5		use LWP::UserAgent;
6		use HTTP::Request::Common;
7		use Flickr::API;
8		use XML::Parser::Lite::Tree;
9
10		our $VERSION = '1.4';
11
12		our @ISA = qw(Flickr::API);
13
14		sub response_tag {
15		my $t = shift;
16		my $node = shift;
17		my $tag = shift;
18
19		return undef unless defined $t and exists $t->{'children'};
20
21		for my $n ( @{$t->{'children'}} ) {
22		next unless defined $n and exists $n->{'name'} and exists $n->{'children'};
23		next unless $n->{'name'} eq $node;
24
25		for my $m (@{$n->{'children'}} ) {
26		next unless exists $m->{'name'}
27		and $m->{'name'} eq $tag
28		and exists $m->{'children'};
29
30		return $m->{'children'}->[0]->{'content'};
31		}
32		}
33		return undef;
34		}
35
36		=head1 NAME
37
38		Flickr::Upload - Upload images to C<flickr.com>
39
40		=head1 SYNOPSIS
41
42		use Flickr::Upload;
43
44		my $ua = Flickr::Upload->new(
45		{
46		'key' => '90909354',
47		'secret' => '37465825'
48		});
49		$ua->upload(
50		'photo' => '/tmp/image.jpg',
51		'auth_token' => $auth_token,
52		'tags' => 'me myself eye',
53		'is_public' => 1,
54		'is_friend' => 1,
55		'is_family' => 1
56		) or die "Failed to upload /tmp/image.jpg";
57
58		=head1 DESCRIPTION
59
60		Upload an image to L<flickr.com>.
61
62		=head1 METHODS
63
64		=head2 new
65
66		my $ua = Flickr::Upload->new(
67		{
68		'key' => '90909354',
69		'secret' => '37465825'
70		});
71
72		Instantiates a L<Flickr::Upload> instance. The C<key> argument is your
73		API key and the C<secret> is the API secret associated with it. To get an
74		API key and secret, go to L<http://www.flickr.com/services/api/key.gne>.
75
76		The resulting L<Flickr::Upload> instance is a subclass of L<Flickr::API>
77		and can be used for any other Flickr API calls. As such,
78		L<Flickr::Upload> is also a subclass of L<LWP::UserAgent>.
79
80		=head2 upload
81
82		my $photoid = $ua->upload(
83		'photo' => '/tmp/image.jpg',
84		'auth_token' => $auth_token,
85		'tags' => 'me myself eye',
86		'is_public' => 1,
87		'is_friend' => 1,
88		'is_family' => 1
89		'async' => 0,
90		);
91
92		Taking a L<Flickr::Upload> instance C<$ua> as an argument, this is
93		basically a direct interface to the Flickr Photo Upload API. Required
94		parameters are C<photo> and C<auth_token>. Note that the C<auth_token>
95		must have been issued against the API key and secret used to instantiate
96		the uploader.
97
98		Returns the resulting identifier of the uploaded photo on success,
99		C<undef> on failure. According to the API documentation, after an upload the
100		user should be directed to the page
101		L<http://www.flickr.com/tools/uploader_edit.gne?ids=$photoid>.
102
103		If the C<async> option is non-zero, the photo will be uploaded
104		asynchronously and a successful upload returns a ticket identifier. See
105		L<http://flickr.com/services/api/upload.async.html>. The caller can then
106		periodically poll for a photo id using the C<check_upload> method. Note
107		that photo and ticket identifiers aren't necessarily numeric.
108
109		=cut
110
111		sub upload {
112		my $self = shift;
113		die '$self is not a Flickr::Upload' unless $self->isa('Flickr::Upload');
114		my %args = @_;
115
116		# these are the only things _required_ by the uploader.
117		die "Can't read photo '$args{'photo'}'" unless $args{'photo'} and -f $args{'photo'};
118		die "Missing 'auth_token'" unless defined $args{'auth_token'};
119
120		# create a request object and execute it
121		my $req = $self->make_upload_request( %args );
122		return undef unless defined $req;
123
124		return $self->upload_request( $req );
125		}
126
127		=head2 check_upload
128
129		my %status2txt = (0 => 'not complete', 1 => 'completed', 2 => 'failed');
130		my @rc = $ua->check_upload( @ticketids );
131		for( @rc ) {
132		print "Ticket $_->{id} has $status2txt{$_->{complete}}\n";
133		print "\tPhoto id is $_->{photoid}\n" if exists $_->{photoid};
134		}
135
136		This function will check the status of one or more asynchronous uploads. A
137		list of ticket identifiers are provided (C<@ticketids>) and each is
138		checked. This is basically just a wrapper around the Flickr API
139		C<flickr.photos.upload.checkTickets> method.
140
141		On success, a list of hash references is returned. Each
142		hash contains a C<id> (the ticket id), C<complete> and, if
143		completed, C<photoid> members. C<invalid> may also be returned.
144		Status codes (for C<complete>) are as documented at
145		L<http://flickr.com/services/api/upload.async.html> and, actually, the
146		returned fields are identical to those listed in the C<ticket> tag of the
147		response. The returned list isn't guaranteed to be in any particular order.
148
149		This function polls a web server, so avoid calling it too frequently.
150
151		=cut
152
153		sub check_upload {
154		my $self = shift;
155		die '$self is not a Flickr::API' unless $self->isa('Flickr::API');
156
157		return () unless @_; # no tickets
158
159		my $res = $self->execute_method( 'flickr.photos.upload.checkTickets',
160		{ 'tickets' => ((@_ == 1) ? $_[0] : join(',', @_)) } );
161		return () unless defined $res and $res->{success};
162
163		# FIXME: better error feedback
164
165		my @rc;
166		return undef unless defined $res->{tree} and exists $res->{tree}->{'children'};
167		for my $n ( @{$res->{tree}->{'children'}} ) {
168		next unless defined $n and exists $n->{'name'} and $n->{'children'};
169		next unless $n->{'name'} eq "uploader";
170
171		for my $m (@{$n->{'children'}} ) {
172		next unless exists $m->{'name'}
173		and $m->{'name'} eq 'ticket'
174		and exists $m->{'attributes'};
175
176		# okay, this is maybe a little lazy...
177		push @rc, $m->{'attributes'};
178		}
179		}
180
181		return @rc;
182		}
183
184		=head2 make_upload_request
185
186		my $req = $uploader->make_upload_request(
187		'auth_token' => '82374523',
188		'tags' => 'me myself eye',
189		'is_public' => 1,
190		'is_friend' => 1,
191		'is_family' => 1
192		);
193		$req->header( 'X-Greetz' => 'hi cal' );
194		my $resp = $ua->request( $req );
195
196		Creates an L<HTTP::Request> object loaded with all the flick upload
197		parameters. This will also sign the request, which means you won't be able to
198		mess any further with the upload request parameters.
199
200		Takes all the same parameters as L<upload>, except that the photo argument
201		isn't required. This in intended so that the caller can include it by
202		messing directly with the HTTP content (via C<$DYNAMIC_FILE_UPLOAD> or
203		the L<HTTP::Message> class, among other things). See C<t/> directory from
204		the source distribution for examples.
205
206		Returns a standard L<HTTP::Response> POST object. The caller can manually
207		do the upload or just call the L<upload_request> function.
208
209		=cut
210
211		sub make_upload_request {
212		my $self = shift;
213		die '$self is not a Flickr::Upload' unless $self->isa('Flickr::Upload');
214		my %args = @_;
215
216		# _required_ by the uploader.
217		die "Missing 'auth_token' argument" unless $args{'auth_token'};
218
219		my $uri = $args{'uri'} \|\| 'https://api.flickr.com/services/upload/';
220
221		# passed in separately, so remove from the hash
222		delete $args{uri};
223
224		# Flickr::API includes this with normal requests, but we're building a custom
225		# message.
226		$args{'api_key'} = $self->{'api_key'};
227
228		# photo is _not_ included in the sig
229		my $photo = $args{photo};
230		delete $args{photo};
231
232		# HACK: sign_args() is an internal Flickr::API method
233		$args{'api_sig'} = $self->sign_args(\%args);
234
235		# unlikely that the caller would set up the photo as an array,
236		# but...
237		if( defined $photo ) {
238		$photo = [ $photo ] if ref $photo ne "ARRAY";
239		$args{photo} = $photo;
240		}
241
242		my $req = POST $uri, 'Content_Type' => 'form-data', 'Content' => \%args;
243
244		return $req;
245		}
246
247		=head2 upload_request
248
249		my $photoid = upload_request( $ua, $request );
250
251		Taking (at least) L<LWP::UserAgent> and L<HTTP::Request> objects as
252		arguments, this executes the request and processes the result as a
253		flickr upload. It's assumed that the request looks a lot like something
254		created with L<make_upload_request>. Note that the request must be signed
255		according to the Flickr API authentication rules.
256
257		Returns the resulting identifier of the uploaded photo (or ticket for
258		asynchronous uploads) on success, C<undef> on failure. According to the
259		API documentation, after an upload the user should be directed to the
260		page L<http://www.flickr.com/tools/uploader_edit.gne?ids=$photoid>.
261
262		=cut
263
264		sub upload_request {
265		my $self = shift;
266		die "$self is not a LWP::UserAgent" unless $self->isa('LWP::UserAgent');
267		my $req = shift;
268		die "expecting a HTTP::Request" unless $req->isa('HTTP::Request');
269
270		# Try 3 times to upload data. Without this flickr_upload is bound
271		# to die on large uploads due to some miscellaneous network
272		# issues. Timeouts on flickr or something else.
273		my ($res, $tree);
274		my $tries = 3;
275		for my $try (1 .. $tries) {
276		# Try to upload
277		$res = $self->request( $req );
278		return () unless defined $res;
279
280		if ($res->is_success) {
281		$tree = XML::Parser::Lite::Tree::instance()->parse($res->decoded_content());
282		return () unless defined $tree;
283		last;
284		} else {
285		my $what_next = ($try == $tries ? "giving up" : "trying again");
286		my $status = $res->status_line;
287
288		print STDERR "Failed uploading attempt attempt $try/$tries, $what_next. Message from server was: '$status'\n";
289		next;
290		}
291		}
292
293		my $photoid = response_tag($tree, 'rsp', 'photoid');
294		my $ticketid = response_tag($tree, 'rsp', 'ticketid');
295		unless( defined $photoid or defined $ticketid ) {
296		print STDERR "upload failed:\n", $res->decoded_content(), "\n";
297		return undef;
298		}
299
300		return (defined $photoid) ? $photoid : $ticketid;
301		}
302
303		=head2 file_length_in_encoded_chunk
304
305		$HTTP::Request::Common::DYNAMIC_FILE_UPLOAD = 1;
306		my $photo = 'image.jpeg';
307		my $photo_size = (stat($photo))[7];
308		my $req = $ua->make_upload_request( ... );
309		my $gen = $req->content();
310		die unless ref($gen) eq "CODE";
311
312		my $state;
313		my $size;
314
315		$req->content(
316		sub {
317		my $chunk = &$gen();
318
319		$size += Flickr::Upload::file_length_in_encoded_chunk(\$chunk, \$state, $photo_size);
320
321		warn "$size bytes have now been uploaded";
322
323		return $chunk;
324		}
325		);
326
327		$rc = $ua->upload_request( $req );
328
329		This subroutine is tells you how much of a chunk in a series of
330		variable size multipart HTTP chunks contains a single file being
331		uploaded given a reference to the current chunk, a reference to a
332		state variable that lives between calls, and the size of the file
333		being uploaded.
334
335		It can be used used along with L<HTTP::Request::Common>'s
336		$HTTP::Request::Common::DYNAMIC_FILE_UPLOAD facility to implement
337		upload progress bars or other upload monitors, see L<flickr_upload>
338		for a practical example and F<t/progress_request.t> for tests.
339
340		=cut
341
342		sub file_length_in_encoded_chunk
343		{
344		my ($chunk, $s, $img_size) = @_;
345
346		$$s = {} unless ref $$s eq 'HASH';
347
348		# If we've run past the end of the image there's nothing to do but
349		# report no image content in this sector.
350		return 0 if $$s->{done};
351
352		unless ($$s->{in}) {
353		# Since we haven't found the image yet append this chunk to
354		# our internal data store, we do this because we have to do a
355		# regex match on m[Content-Type...] which might be split
356		# across multiple chunks
357		$$s->{data} .= defined $$chunk ? $$chunk : '';
358
359		if ($$s->{data} =~ m[Content-Type: .*?\r\n\r\n]g) {
360		# We've found the image inside the stream, record this,
361		# delete ->{data} since we don't need it, and see how much
362		# of the image this particular chunk gives us.
363		$$s->{in} = 1;
364		my $size = length substr($$s->{data}, pos($$s->{data}), -1);
365		delete $$s->{data};
366
367		$$s->{size} = $size;
368
369		if ($$s->{size} >= $img_size) {
370		# The image could be so small that we've already run
371		# through it in chunk it starts in, mark as done and
372		# return the total image size
373
374		$$s->{done} = 1;
375		return $img_size;
376		} else {
377		return $$s->{size};
378		}
379		} else {
380		# Are we inside the image yet? No!
381		return 0;
382		}
383		} else {
384		my $size = length $$chunk;
385
386		if (($$s->{size} + $size) >= $img_size) {
387		# This chunk finishes the image
388
389		$$s->{done} = 1;
390
391		# Return what we had left
392		return $img_size - $$s->{size};
393		} else {
394		# This chunk isn't the last one
395
396		$$s->{size} += $size;
397
398		return $size;
399		}
400		}
401		}
402
403		1;
404		__END__
405
406		=head1 SEE ALSO
407
408		L<http://flickr.com/services/api/>
409
410		L<Flickr::API>
411
412		=head1 AUTHORS
413
414		Christophe Beauregard, L<cpb@cpan.org>
415
416		E<AElig>var ArnfjE<ouml>rE<eth> Bjarmason, <avar@cpan.org>
417
418		=head1 COPYRIGHT AND LICENSE
419
420		This module is not an official Flickr.com (or Ludicorp, or Yahoo) service.
421
422		Copyright (C) 2004-2008 by Christophe Beauregard and 2008-2009 by
423		E<AElig>var ArnfjE<ouml>rE<eth> Bjarmason
424
425		This library is free software; you can redistribute it and/or modify
426		it under the same terms as Perl itself, either Perl version 5.8.3 or,
427		at your option, any later version of Perl 5 you may have available.

+48

-1

flickr_upload less more

17	17	my $progress = 0;
18	18	my $check = 0;
19	19	my $report = 1;
	20	my $reverse = 0;
	21	my $photoset;
	22	my @photo_ids;
20	23
21	24	if( open CONFIG, "< $ENV{HOME}/.flickrrc" ) {
22	25	while( <CONFIG> ) {

57	60	'check' => \$check,
58	61	'report!' => \$report,
59	62	'option=s' => \%args,
	63	'reverse' => \$reverse,
	64	'set=s' => \$photoset,
60	65	) or pod2usage(2);
61	66	pod2usage(1) if $help;
62	67	pod2usage(-exitstatus => 0, -verbose => 2) if $man;

128	133	my %tickets;
129	134
130	135	$\| = 1;
131		while( my $photo = shift @ARGV ) {
	136
	137	my @argv = $reverse ? reverse @ARGV : @ARGV;
	138
	139	while( my $photo = shift @argv ) {
132	140	my $rc;
133	141
134	142	if ($progress) {

187	195	# uploaded, got photoid
188	196	print "$tickets{$_->{id}} is at " .
189	197	"http://www.flickr.com/tools/uploader_edit.gne?ids=$_->{photoid}\n";
	198	push @photo_ids, $_->{photoid};
190	199	delete $tickets{$_->{id}};
191	200	} else {
192	201	print "$tickets{$_->{id}} failed to get photoid\n";

196	205	} while( %tickets );
197	206	}
198	207
	208	if ( $photoset ) {
	209	if ( scalar(@photo_ids)==0 ) {
	210	warn "Cannot create photoset '$photoset', no photos were successfully uploaded (or, you didn't wait for the upload verification)\n";
	211	}
	212	else {
	213	my $primary_photo_id = shift @photo_ids;
	214	warn "Creating photoset '$photoset', primary_photo_id = $primary_photo_id\n";
	215	my $photoset_id = $ua->photosets_create (
	216	title => $photoset,
	217	primary_photo_id => $primary_photo_id,
	218	'auth_token' => $args{'auth_token'} );
	219	warn "Created photoset, id = $photoset_id\n";
	220
	221	while ( my $photo_id = shift @photo_ids ) {
	222	warn "Adding photoID $photo_id to photoset $photoset...\n";
	223	my $rc = $ua->photosets_addphoto (
	224	photoset_id => $photoset_id,
	225	photo_id => $photo_id,
	226	'auth_token' => $args{'auth_token'} );
	227	warn "Adding photoID $photo_id failed...\n" unless $rc;
	228	}
	229	}
	230	}
	231
199	232	exit 0;
200	233
201	234	sub response_tag {

325	358	The following works in L<bash>:
326	359
327	360	flickr_upload --tag='"tag one"' --tag='"tag two"' image.jpg
	361
	362	=item --reverse
	363
	364	Reverse the list of supplied images. Useful when uploading contents of
	365	directory with sorted filenames. Following example will upload the last
	366	glob expanded file as first and vice versa. The last file will appear
	367	first in target photo stream.
	368
	369	flickr_upload --reverse *.jpg
	370
	371	=item --set <NAME>
	372
	373	After successfully uploading all photos, create a new set named "NAME", and
	374	add the photos into the set. One (random) photo will be the set's thumbnail.
328	375
329	376	=item --option key=value
330	377

+519

-0

lib/Flickr/Upload.pm less more

	0	package Flickr::Upload;
	1
	2	use strict;
	3	use warnings;
	4
	5	use LWP::UserAgent;
	6	use HTTP::Request::Common;
	7	use Flickr::API;
	8	use XML::Simple qw(:strict);
	9	use Digest::MD5 qw(md5_hex);
	10	use Encode qw(encode_utf8);
	11	use Carp;
	12
	13	our $VERSION = '1.5';
	14
	15	our @ISA = qw(Flickr::API);
	16
	17	=head1 NAME
	18
	19	Flickr::Upload - Upload images to C<flickr.com>
	20
	21	=head1 SYNOPSIS
	22
	23	use Flickr::Upload;
	24
	25	my $ua = Flickr::Upload->new(
	26	{
	27	'key' => '90909354',
	28	'secret' => '37465825'
	29	});
	30	$ua->upload(
	31	'photo' => '/tmp/image.jpg',
	32	'auth_token' => $auth_token,
	33	'tags' => 'me myself eye',
	34	'is_public' => 1,
	35	'is_friend' => 1,
	36	'is_family' => 1
	37	) or die "Failed to upload /tmp/image.jpg";
	38
	39	=head1 DESCRIPTION
	40
	41	Upload an image to L<flickr.com>.
	42
	43	=head1 METHODS
	44
	45	=head2 new
	46
	47	my $ua = Flickr::Upload->new(
	48	{
	49	'key' => '90909354',
	50	'secret' => '37465825'
	51	});
	52
	53	Instantiates a L<Flickr::Upload> instance. The C<key> argument is your
	54	API key and the C<secret> is the API secret associated with it. To get an
	55	API key and secret, go to L<http://www.flickr.com/services/api/key.gne>.
	56
	57	The resulting L<Flickr::Upload> instance is a subclass of L<Flickr::API>
	58	and can be used for any other Flickr API calls. As such,
	59	L<Flickr::Upload> is also a subclass of L<LWP::UserAgent>.
	60
	61	=head2 upload
	62
	63	my $photoid = $ua->upload(
	64	'photo' => '/tmp/image.jpg',
	65	'auth_token' => $auth_token,
	66	'tags' => 'me myself eye',
	67	'is_public' => 1,
	68	'is_friend' => 1,
	69	'is_family' => 1
	70	'async' => 0,
	71	);
	72
	73	Taking a L<Flickr::Upload> instance C<$ua> as an argument, this is
	74	basically a direct interface to the Flickr Photo Upload API. Required
	75	parameters are C<photo> and C<auth_token>. Note that the C<auth_token>
	76	must have been issued against the API key and secret used to instantiate
	77	the uploader.
	78
	79	Returns the resulting identifier of the uploaded photo on success,
	80	C<undef> on failure. According to the API documentation, after an upload the
	81	user should be directed to the page
	82	L<http://www.flickr.com/tools/uploader_edit.gne?ids=$photoid>.
	83
	84	If the C<async> option is non-zero, the photo will be uploaded
	85	asynchronously and a successful upload returns a ticket identifier. See
	86	L<http://flickr.com/services/api/upload.async.html>. The caller can then
	87	periodically poll for a photo id using the C<check_upload> method. Note
	88	that photo and ticket identifiers aren't necessarily numeric.
	89
	90	=cut
	91
	92	sub upload {
	93	my $self = shift;
	94	die '$self is not a Flickr::Upload' unless $self->isa('Flickr::Upload');
	95	my %args = @_;
	96
	97	# these are the only things _required_ by the uploader.
	98	die "Can't read photo '$args{'photo'}'" unless $args{'photo'} and -f $args{'photo'};
	99	die "Missing 'auth_token'" unless defined $args{'auth_token'};
	100
	101	# create a request object and execute it
	102	my $req = $self->make_upload_request( %args );
	103	return undef unless defined $req;
	104
	105	return $self->upload_request( $req );
	106	}
	107
	108	=head2 check_upload
	109
	110	my %status2txt = (0 => 'not complete', 1 => 'completed', 2 => 'failed');
	111	my @rc = $ua->check_upload( @ticketids );
	112	for( @rc ) {
	113	print "Ticket $_->{id} has $status2txt{$_->{complete}}\n";
	114	print "\tPhoto id is $_->{photoid}\n" if exists $_->{photoid};
	115	}
	116
	117	This function will check the status of one or more asynchronous uploads. A
	118	list of ticket identifiers are provided (C<@ticketids>) and each is
	119	checked. This is basically just a wrapper around the Flickr API
	120	C<flickr.photos.upload.checkTickets> method.
	121
	122	On success, a list of hash references is returned. Each
	123	hash contains a C<id> (the ticket id), C<complete> and, if
	124	completed, C<photoid> members. C<invalid> may also be returned.
	125	Status codes (for C<complete>) are as documented at
	126	L<http://flickr.com/services/api/upload.async.html> and, actually, the
	127	returned fields are identical to those listed in the C<ticket> tag of the
	128	response. The returned list isn't guaranteed to be in any particular order.
	129
	130	This function polls a web server, so avoid calling it too frequently.
	131
	132	=cut
	133
	134	sub check_upload {
	135	my $self = shift;
	136	die '$self is not a Flickr::API' unless $self->isa('Flickr::API');
	137
	138	return () unless @_; # no tickets
	139
	140	my $res = $self->execute_method( 'flickr.photos.upload.checkTickets',
	141	{ 'tickets' => ((@_ == 1) ? $_[0] : join(',', @_)) } );
	142	return () unless defined $res and $res->{success};
	143
	144	# FIXME: better error feedback
	145
	146	my @rc;
	147	return undef unless defined $res->{tree} and exists $res->{tree}->{'children'};
	148	for my $n ( @{$res->{tree}->{'children'}} ) {
	149	next unless defined $n and exists $n->{'name'} and $n->{'children'};
	150	next unless $n->{'name'} eq "uploader";
	151
	152	for my $m (@{$n->{'children'}} ) {
	153	next unless exists $m->{'name'}
	154	and $m->{'name'} eq 'ticket'
	155	and exists $m->{'attributes'};
	156
	157	# okay, this is maybe a little lazy...
	158	push @rc, $m->{'attributes'};
	159	}
	160	}
	161
	162	return @rc;
	163	}
	164
	165	=head2 make_upload_request
	166
	167	my $req = $uploader->make_upload_request(
	168	'auth_token' => '82374523',
	169	'tags' => 'me myself eye',
	170	'is_public' => 1,
	171	'is_friend' => 1,
	172	'is_family' => 1
	173	);
	174	$req->header( 'X-Greetz' => 'hi cal' );
	175	my $resp = $ua->request( $req );
	176
	177	Creates an L<HTTP::Request> object loaded with all the flick upload
	178	parameters. This will also sign the request, which means you won't be able to
	179	mess any further with the upload request parameters.
	180
	181	Takes all the same parameters as L<upload>, except that the photo argument
	182	isn't required. This in intended so that the caller can include it by
	183	messing directly with the HTTP content (via C<$DYNAMIC_FILE_UPLOAD> or
	184	the L<HTTP::Message> class, among other things). See C<t/> directory from
	185	the source distribution for examples.
	186
	187	Returns a standard L<HTTP::Response> POST object. The caller can manually
	188	do the upload or just call the L<upload_request> function.
	189
	190	=cut
	191
	192	sub make_upload_request {
	193	my $self = shift;
	194	die '$self is not a Flickr::Upload' unless $self->isa('Flickr::Upload');
	195	my %args = @_;
	196
	197	# _required_ by the uploader.
	198	die "Missing 'auth_token' argument" unless $args{'auth_token'};
	199
	200	my $uri = $args{'uri'} \|\| 'https://api.flickr.com/services/upload/';
	201
	202	# passed in separately, so remove from the hash
	203	delete $args{uri};
	204
	205	# Flickr::API includes this with normal requests, but we're building a custom
	206	# message.
	207	$args{'api_key'} = $self->{'api_key'};
	208
	209	# photo is _not_ included in the sig
	210	my $photo = $args{photo};
	211	delete $args{photo};
	212
	213	$args{'api_sig'} = $self->_sign_args(\%args);
	214
	215	# unlikely that the caller would set up the photo as an array,
	216	# but...
	217	if( defined $photo ) {
	218	$photo = [ $photo ] if ref $photo ne "ARRAY";
	219	$args{photo} = $photo;
	220	}
	221
	222	my $req = POST $uri, 'Content_Type' => 'form-data', 'Content' => \%args;
	223
	224	return $req;
	225	}
	226
	227	=head2 upload_request
	228
	229	my $photoid = upload_request( $ua, $request );
	230
	231	Taking (at least) L<LWP::UserAgent> and L<HTTP::Request> objects as
	232	arguments, this executes the request and processes the result as a
	233	flickr upload. It's assumed that the request looks a lot like something
	234	created with L<make_upload_request>. Note that the request must be signed
	235	according to the Flickr API authentication rules.
	236
	237	Returns the resulting identifier of the uploaded photo (or ticket for
	238	asynchronous uploads) on success, C<undef> on failure. According to the
	239	API documentation, after an upload the user should be directed to the
	240	page L<http://www.flickr.com/tools/uploader_edit.gne?ids=$photoid>.
	241
	242	=cut
	243
	244	sub upload_request {
	245	my $self = shift;
	246	die "$self is not a LWP::UserAgent" unless $self->isa('LWP::UserAgent');
	247	my $req = shift;
	248	die "expecting a HTTP::Request" unless $req->isa('HTTP::Request');
	249
	250	# Try 3 times to upload data. Without this flickr_upload is bound
	251	# to die on large uploads due to some miscellaneous network
	252	# issues. Timeouts on flickr or something else.
	253	my ($res, $xml);
	254	my $tries = 3;
	255	for my $try (1 .. $tries) {
	256	# Try to upload
	257	$res = $self->request( $req );
	258	return () unless defined $res;
	259
	260	if ($res->is_success) {
	261	$xml = XMLin($res->decoded_content, KeyAttr=>[], ForceArray=>0);
	262	return () unless defined $xml;
	263	last;
	264	} else {
	265	my $what_next = ($try == $tries ? "giving up" : "trying again");
	266	my $status = $res->status_line;
	267
	268	print STDERR "Failed uploading attempt attempt $try/$tries, $what_next. Message from server was: '$status'\n";
	269	next;
	270	}
	271	}
	272
	273	my $photoid = $xml->{photoid};
	274	my $ticketid = $xml->{ticketid};
	275	unless( defined $photoid or defined $ticketid ) {
	276	print STDERR "upload failed:\n", $res->decoded_content(), "\n";
	277	return undef;
	278	}
	279
	280	return (defined $photoid) ? $photoid : $ticketid;
	281	}
	282
	283	=head2 file_length_in_encoded_chunk
	284
	285	$HTTP::Request::Common::DYNAMIC_FILE_UPLOAD = 1;
	286	my $photo = 'image.jpeg';
	287	my $photo_size = (stat($photo))[7];
	288	my $req = $ua->make_upload_request( ... );
	289	my $gen = $req->content();
	290	die unless ref($gen) eq "CODE";
	291
	292	my $state;
	293	my $size;
	294
	295	$req->content(
	296	sub {
	297	my $chunk = &$gen();
	298
	299	$size += Flickr::Upload::file_length_in_encoded_chunk(\$chunk, \$state, $photo_size);
	300
	301	warn "$size bytes have now been uploaded";
	302
	303	return $chunk;
	304	}
	305	);
	306
	307	$rc = $ua->upload_request( $req );
	308
	309	This subroutine is tells you how much of a chunk in a series of
	310	variable size multipart HTTP chunks contains a single file being
	311	uploaded given a reference to the current chunk, a reference to a
	312	state variable that lives between calls, and the size of the file
	313	being uploaded.
	314
	315	It can be used used along with L<HTTP::Request::Common>'s
	316	$HTTP::Request::Common::DYNAMIC_FILE_UPLOAD facility to implement
	317	upload progress bars or other upload monitors, see L<flickr_upload>
	318	for a practical example and F<t/progress_request.t> for tests.
	319
	320	=cut
	321
	322	sub file_length_in_encoded_chunk
	323	{
	324	my ($chunk, $s, $img_size) = @_;
	325
	326	$$s = {} unless ref $$s eq 'HASH';
	327
	328	# If we've run past the end of the image there's nothing to do but
	329	# report no image content in this sector.
	330	return 0 if $$s->{done};
	331
	332	unless ($$s->{in}) {
	333	# Since we haven't found the image yet append this chunk to
	334	# our internal data store, we do this because we have to do a
	335	# regex match on m[Content-Type...] which might be split
	336	# across multiple chunks
	337	$$s->{data} .= defined $$chunk ? $$chunk : '';
	338
	339	if ($$s->{data} =~ m[Content-Type: .*?\r\n\r\n]g) {
	340	# We've found the image inside the stream, record this,
	341	# delete ->{data} since we don't need it, and see how much
	342	# of the image this particular chunk gives us.
	343	$$s->{in} = 1;
	344	my $size = length substr($$s->{data}, pos($$s->{data}), -1);
	345	delete $$s->{data};
	346
	347	$$s->{size} = $size;
	348
	349	if ($$s->{size} >= $img_size) {
	350	# The image could be so small that we've already run
	351	# through it in chunk it starts in, mark as done and
	352	# return the total image size
	353
	354	$$s->{done} = 1;
	355	return $img_size;
	356	} else {
	357	return $$s->{size};
	358	}
	359	} else {
	360	# Are we inside the image yet? No!
	361	return 0;
	362	}
	363	} else {
	364	my $size = length $$chunk;
	365
	366	if (($$s->{size} + $size) >= $img_size) {
	367	# This chunk finishes the image
	368
	369	$$s->{done} = 1;
	370
	371	# Return what we had left
	372	return $img_size - $$s->{size};
	373	} else {
	374	# This chunk isn't the last one
	375
	376	$$s->{size} += $size;
	377
	378	return $size;
	379	}
	380	}
	381	}
	382
	383	=head2 photosets_create
	384
	385	Calls Flickr's "flickr.photosets.create" method,
	386	to create a new Set.
	387
	388	The set will use the PrimaryPhotoID as the thumbnail photo.
	389
	390	returns: UNDEF on failure, PhotosetID on success.
	391
	392	my $photoset_id = $ua->photosets_create( title => 'title',
	393	description => 'description',
	394	primary_photo_id => ID,
	395	auth_token => AUTH_TOKEN );
	396
	397	$ua->photosets_addphoto ( photoset_id => $photoset_id,
	398	photo_id => ID );
	399
	400	=cut
	401	sub photosets_create {
	402	my $self = shift;
	403	die '$self is not a Flickr::API' unless $self->isa('Flickr::API');
	404
	405	my %args = @_;
	406	carp "Missing 'auth_token' parameter for photosets_create()"
	407	unless exists $args{'auth_token'};
	408	my $auth_token = $args{'auth_token'};
	409	carp "Missing 'title' parameter for photosets_create()"
	410	unless exists $args{'title'} && length($args{'title'})>0;
	411	my $title = $args{'title'};
	412	carp "Missing 'primary_photo_id' parameter for photosets_create()"
	413	unless exists $args{'primary_photo_id'};
	414	my $primary_photo_id = $args{'primary_photo_id'};
	415	carp "Invalid primary_photo_id ($primary_photo_id) value (expecting numeric ID)" unless $primary_photo_id =~ /^[0-9]+$/;
	416	my $description = ( exists $args{'description'} ) ? $args{'description'} : "" ;
	417
	418	my $res = $self->execute_method( 'flickr.photosets.create',
	419	{ 'title' => $title,
	420	'description' => $description,
	421	'primary_photo_id' => $primary_photo_id,
	422	'auth_token' => $auth_token,
	423	} ) ;
	424	#TODO: Add detailed error messages
	425	return undef unless defined $res and $res->{success};
	426
	427	my $hash = XMLin($res->decoded_content(), KeyAttr=>[], ForceArray=>0);
	428	my $photoset_id = $hash->{photoset}->{id};
	429	if ( ! defined $photoset_id ) {
	430	warn "Failed to extract photoset ID from response:\n" .
	431	$res->decoded_content() . "\n\n";
	432	return undef;
	433	}
	434	return $photoset_id ;
	435	}
	436
	437	=head2 photosets_addphoto
	438
	439	Calls Flickr's "flickr.photosets.addPhoto" method,
	440	to add a (existing) photo to an existing set.
	441
	442	returns: UNDEF on failure, TRUE on success.
	443
	444	my $photoset_id = $ua->photosets_create( title => 'title',
	445	description => 'description',
	446	primary_photo_id => ID,
	447	auth_token => AUTH_TOKEN );
	448
	449	$ua->photosets_addphoto ( photoset_id => $photoset_id,
	450	photo_id => ID );
	451
	452	=cut
	453	sub photosets_addphoto {
	454	my $self = shift;
	455	die '$self is not a Flickr::API' unless $self->isa('Flickr::API');
	456
	457	my %args = @_;
	458	carp "Missing 'auth_token' parameter for photosets_addphoto()"
	459	unless exists $args{'auth_token'};
	460	my $auth_token = $args{'auth_token'};
	461	carp "Missing 'photoset_id' parameter for photosets_addphoto()"
	462	unless exists $args{'photoset_id'};
	463	my $photoset_id = $args{'photoset_id'};
	464	carp "Missing 'photo_id' parameter for photosets_addphoto()"
	465	unless exists $args{'photo_id'};
	466	my $photo_id = $args{'photo_id'};
	467
	468	my $res = $self->execute_method( 'flickr.photosets.addPhoto',
	469	{ 'photoset_id' => $photoset_id,
	470	'photo_id' => $photo_id,
	471	'auth_token' => $auth_token,
	472	} ) ;
	473	#TODO: Add detailed error messages
	474	return undef unless defined $res;
	475
	476	return $res->{success};
	477	}
	478
	479	# Private method adapted from Flickr::API
	480	# See: https://www.flickr.com/services/api/auth.howto.web.html
	481	sub _sign_args {
	482	my $self = shift;
	483	my $args = shift;
	484
	485	my $sig = $self->{api_secret};
	486
	487	for(sort { $a cmp $b } keys %$args) {
	488	$sig .= $_ . (defined($args->{$_}) ? $args->{$_} : "");
	489	}
	490
	491	return md5_hex($self->{unicode} ? encode_utf8($sig) : $sig);
	492	}
	493
	494	1;
	495	__END__
	496
	497	=head1 SEE ALSO
	498
	499	L<http://flickr.com/services/api/>
	500
	501	L<Flickr::API>
	502
	503	=head1 AUTHORS
	504
	505	Christophe Beauregard, L<cpb@cpan.org>
	506
	507	E<AElig>var ArnfjE<ouml>rE<eth> Bjarmason, <avar@cpan.org>
	508
	509	=head1 COPYRIGHT AND LICENSE
	510
	511	This module is not an official Flickr.com (or Ludicorp, or Yahoo) service.
	512
	513	Copyright (C) 2004-2008 by Christophe Beauregard and 2008-2009 by
	514	E<AElig>var ArnfjE<ouml>rE<eth> Bjarmason
	515
	516	This library is free software; you can redistribute it and/or modify
	517	it under the same terms as Perl itself, either Perl version 5.8.3 or,
	518	at your option, any later version of Perl 5 you may have available.