File Coverage

blib/lib/WWW/Zooomr/Scraper.pm

Criterion	Covered	Total	%
statement	33	125	26.4
branch	0	52	0.0
condition	0	10	0.0
subroutine	10	22	45.4
pod	7	7	100.0
total	50	216	23.1

package WWW::Zooomr::Scraper;
use strict;
use warnings;
use Carp;
use version; our $VERSION = qv('0.3.1');
use English qw( -no_match_vars );
use WWW::Mechanize;

use Path::Class qw( file );

my @fields;
my %defaults = (
   login_page  => 'http://www.zooomr.com/login/',
   upload_page => 'http://www.zooomr.com/photos/upload/?noflash=okiwill',
   logout_page => 'http://www.zooomr.com/logout/',
);

BEGIN {    # Generate simple accessors
   no warnings;
   no strict;
   @fields = qw(
     updater
     agent username password
     login_page upload_page logout_page
   );

   for my $param_name (@fields) {
      *{__PACKAGE__ . '::get_' . $param_name} = sub {
         return $_[0]->{$param_name};
      };
      *{__PACKAGE__ . '::set_' . $param_name} = sub {
         my $previous = $_[0]->{$param_name};
         $_[0]->{$param_name} = $_[1];
         return $previous;
      };
   } ## end for my $param_name (@fields)
} ## end BEGIN

sub new {
   my $package = shift;
   my $config = ref($_[0]) ? $_[0] : {@_};

   my $self = bless {%defaults}, $package;
   $self->reconfig($config);

   return $self;
} ## end sub new

sub reconfig {
   my $self = shift;
   my $config = ref($_[0]) ? $_[0] : {@_};

   for my $param_name (@fields) {
      next unless exists $config->{$param_name};
      $self->{$param_name} = $config->{$param_name};
   }

   $self->set_agent(WWW::Mechanize->new(autocheck => 1, stack_depth => 1, ))
     unless defined $self->get_agent();

   $self->update_proxy(exists($config->{proxy}) && $config->{proxy});

   $self->load_cookies_from($config->{cookie})
     if exists $config->{cookie};
} ## end sub reconfig

sub update_proxy {
   my ($self, $proxy) = @_;
   my $ua = $self->get_agent();
   $ua->env_proxy();
   $ua->proxy('http', $proxy) if $proxy;
   return $proxy;
} ## end sub update_proxy

sub load_cookies_from {
   my $self       = shift;
   my ($filename) = @_;

   require HTTP::Cookies::Mozilla;
   my $jar = HTTP::Cookies::Mozilla->new(autosave => 0);
   $jar->load($filename)
      or croak "could not load cookie file $filename\n";

   # Set photostream_sort_mode to 'recent', trying to be robust
   # getting all the stuff from the currently saved cookie
   my @args;
   $jar->scan(
      sub {
         my ($domain, $name) = @_[4, 1];
         return unless $name eq 'photostream_sort_mode';
         return unless $domain =~ /zooomr/i;
         @args = @_;
      },
   );
   $args[2] = 'recent';    # value
   $jar->set_cookie(@args);

   $self->get_agent()->cookie_jar($jar);

   return;
} ## end sub load_cookies_from

sub login {
   my $self = shift;
   my $args = ref($_[0]) ? $_[0] : {@_};

   $self->set_username($args->{username}) if exists $args->{username};
   $self->set_password($args->{password}) if exists $args->{password};

   my $ua = $self->get_agent();
   $ua->get($self->get_login_page())
      or croak "couldn't get login page\n";
   $ua->form_with_fields(qw( username password ))
      or croak "no login form\n";
   $ua->set_fields(
      username => $self->get_username(),
      password => $self->get_password(),
   );
   $ua->click()
      or croak "no button to click\n";

   return;
} ## end sub login

sub logout {
   my $self = shift;
   return $self->get_agent()->get($self->get_logout_page());
}

sub _config_or_default {
   my $self = shift;
   my $href = shift;
   map {
      if (exists $href->{$_})
      {
         $href->{$_};
      }
      elsif (my $method = $self->can('get_' . $_)) {
         scalar($self->$method());
      }
      else {
         undef;
      }
   } @_;
} ## end sub _config_or_default

sub upload {
   my $self = shift;
   my $config = ref($_[0]) ? $_[0] : {@_};

   my ($updater) = $self->_config_or_default($config, 'updater');
   my $filename  = $config->{filename};
   my $ua        = $self->get_agent();

   (my $barename = file($filename)->basename()) =~ s{\.\w+\z}{}mxs;

   my $updating;
   my $uri = eval {
      $ua->get($self->get_upload_page())
         or croak "couldn't get upload page\n";

      $ua->form_with_fields(qw( Filedata labels is_public ))
         or croak "no form with fields required for upload\n";
      $ua->set_fields(
         labels    => $config->{tags}   || '',
         is_public => $config->{public} || 0,
         Filedata  => $filename,
      );
      $ua->tick('is_friend', 1, $config->{friends});
      $ua->tick('is_family', 1, $config->{family});

      if ($updater) {
         local $HTTP::Request::Common::DYNAMIC_FILE_UPLOAD;
         $HTTP::Request::Common::DYNAMIC_FILE_UPLOAD = 1;
         my $request = $ua->current_form()->click();    # Get request

         my $total = scalar($request->content_length());
         $updater->post(
            'start_file',
            filename     => $filename,
            barename     => $barename,
            file_counter => $config->{file_counter},
            file_octets  => $total,
         );
         $updating = 1;

         my $workhorse = $request->content();
         my $done      = 0;
         $request->content(
            sub {
               my $data_chunk = $workhorse->();
               return unless defined $data_chunk;

               $done += length $data_chunk;
               $updater->post('update_file', sent_octets => $done);

               return $data_chunk;
            },
         );

         $ua->request($request);
      } ## end if ($updater)
      else {
         $ua->click();
      }

      # Check the photo is there
      my $link = $ua->find_link(text => $barename)
         or croak "upload completed but no photo\n";
      $updater->post(
         'end_file',
         filename => $filename,
         uri      => $link->url_abs(),
         outcome  => 'success'
      ) if $updater;
      $link->url_abs();
   };
   return $uri if $uri;

   # Complete stuff in updater before failing
   $updater->post(
      'end_file',
      filename => $filename,
      uri => undef,
      outcome => 'failure',
   ) if $updater && $updating;
   croak $@;
} ## end sub upload

__END__