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