File Coverage

blib/lib/Net/Twitter/Lite.pm
Criterion Covered Total %
statement 208 279 74.5
branch 60 112 53.5
condition 27 53 50.9
subroutine 32 41 78.0
pod 7 8 87.5
total 334 493 67.7


line stmt bran cond sub pod time code
1             package Net::Twitter::Lite;
2             our $VERSION = '0.12006';
3 11     11   377040 use 5.005;
  11         42  
  11         572  
4 10     10   222 use warnings;
  10         43  
  10         312  
5 9     9   59 use strict;
  9         20  
  9         412  
6              
7             =head1 NAME
8              
9             Net::Twitter::Lite - A perl library for Twitter's API v1
10              
11             =head1 VERSION
12              
13             version 0.12006
14              
15             =cut
16              
17 9     9   49 use Carp;
  9         19  
  9         2011  
18 9     9   6816 use URI::Escape;
  9         10721  
  9         645  
19 9     9   34369 use JSON;
  9         276668  
  9         69  
20 9     9   18504 use HTTP::Request::Common;
  9         404205  
  9         871  
21 9     9   12370 use Net::Twitter::Lite::Error;
  9         23  
  9         280  
22 9     9   15967 use Encode qw/encode_utf8/;
  9         176506  
  9         981  
23 9     9   15804 use Net::Twitter::Lite::WrapResult;
  9         26  
  9         4098333  
24              
25             sub twitter_api_def_from () { 'Net::Twitter::Lite::API::V1' }
26             sub _default_api_url () { 'http://api.twitter.com/1' }
27             sub _default_searchapiurl () { 'http://search.twitter.com' }
28             sub _default_search_trends_api_url () { 'http://api.twitter.com/1' }
29             sub _default_lists_api_url () { 'http://api.twitter.com/1' }
30              
31             my $json_handler = JSON->new->utf8;
32              
33             sub new {
34 11     11 1 750676 my ($class, %args) = @_;
35              
36 11 100       194 $class->can('verify_credentials') || $class->build_api_methods;
37              
38 11         46 my $netrc = delete $args{netrc};
39 11 50 33     600 my $new = bless {
      33        
40             apiurl => $class->_default_api_url,
41             searchapiurl => $class->_default_searchapiurl,
42             search_trends_api_url => $class->_default_search_trends_api_url,
43             lists_api_url => $class->_default_lists_api_url,
44             apirealm => 'Twitter API',
45             $args{identica} ? ( apiurl => 'http://identi.ca/api' ) : (),
46             useragent => (ref $class || $class) . "/$VERSION (Perl)",
47             clientname => (ref $class || $class),
48             clientver => $VERSION,
49             clienturl => 'http://search.cpan.org/dist/Net-Twitter-Lite/',
50             source => 'twitterpm',
51             useragent_class => 'LWP::UserAgent',
52             useragent_args => {},
53             oauth_urls => {
54             request_token_url => "https://api.twitter.com/oauth/request_token",
55             authentication_url => "https://api.twitter.com/oauth/authenticate",
56             authorization_url => "https://api.twitter.com/oauth/authorize",
57             access_token_url => "https://api.twitter.com/oauth/access_token",
58             xauth_url => "https://api.twitter.com/oauth/access_token",
59             },
60             netrc_machine => 'api.twitter.com',
61             %args
62             }, $class;
63              
64 11 50       109 unless ( exists $new->{legacy_lists_api} ) {
65 0         0 $new->{legacy_lists_api} = 1;
66 0         0 carp
67 0         0 "For backwards compatibility @{[ __PACKAGE__ ]} uses the deprecated Lists API
68             endpoints and semantics. This default will be changed in a future version.
69             Please update your code to use the new lists semantics and pass
70             (legacy_lists_api => 0) to new.
71              
72             You can disable this warning, and keep backwards compatibility by passing
73             (legacy_lists_api => 1) to new. Be warned, however, that support for the
74             legacy endpoints will be removed in a future version and the default will
75             change to (legacy_lists_api => 0).";
76              
77             }
78              
79 11 100       73 if ( delete $args{ssl} ) {
80             $new->{$_} =~ s/^http:/https:/
81 4         84 for qw/apiurl searchapiurl search_trends_api_url lists_api_url/;
82             }
83              
84             # get username and password from .netrc
85 11 50       41 if ( $netrc ) {
86 0 0       0 eval { require Net::Netrc; 1 }
  0         0  
  0         0  
87             || croak "Net::Netrc is required for the netrc option";
88              
89 0 0       0 my $host = $netrc eq '1' ? $new->{netrc_machine} : $netrc;
90 0   0     0 my $nrc = Net::Netrc->lookup($host)
91             || croak "No .netrc entry for $host";
92              
93 0         0 @{$new}{qw/username password/} = $nrc->lpa;
  0         0  
94             }
95              
96 11   66     88 $new->{ua} ||= do {
97 9     7   1554 eval "use $new->{useragent_class}";
  7         70  
  7         15  
  7         136  
98 9 50       44 croak $@ if $@;
99              
100 9         44 $new->{useragent_class}->new(%{$new->{useragent_args}});
  9         88  
101             };
102              
103 11         45509 $new->{ua}->agent($new->{useragent});
104 11         879 $new->{ua}->default_header('X-Twitter-Client' => $new->{clientname});
105 11         665 $new->{ua}->default_header('X-Twitter-Client-Version' => $new->{clientver});
106 11         590 $new->{ua}->default_header('X-Twitter-Client-URL' => $new->{clienturl});
107 11         665 $new->{ua}->env_proxy;
108              
109 11 100       61439 $new->{_authenticator} = exists $new->{consumer_key}
110             ? '_oauth_authenticated_request'
111             : '_basic_authenticated_request';
112              
113 11 100 66     596 $new->credentials(@{$new}{qw/username password/})
  4         24  
114             if exists $new->{username} && exists $new->{password};
115              
116 11         205 return $new;
117             }
118              
119             sub credentials {
120 5     5 1 1008 my $self = shift;
121 5         15 my ($username, $password) = @_;
122              
123 5 50       25 croak "exected a username and password" unless @_ == 2;
124 5 50       26 croak "OAuth authentication is in use" if exists $self->{consumer_key};
125              
126 5         14 $self->{username} = $username;
127 5         14 $self->{password} = $password;
128              
129 5         43 my $uri = URI->new($self->{apiurl});
130 5         31709 my $netloc = join ':', $uri->host, $uri->port;
131              
132 5         890 $self->{ua}->credentials($netloc, $self->{apirealm}, $username, $password);
133             }
134              
135             # This is a hack. Rather than making Net::OAuth an install requirement for
136             # Net::Twitter::Lite, require it at runtime if any OAuth methods are used. It
137             # simply returns the string 'Net::OAuth' after successfully requiring
138             # Net::OAuth.
139             sub _oauth {
140 1     1   3 my $self = shift;
141              
142 1   33     8 return $self->{_oauth} ||= do {
143 1         205 eval "use Net::OAuth 0.25";
144 1 50       6 croak "Install Net::OAuth 0.25 or later for OAuth support" if $@;
145              
146 1         63 eval '$Net::OAuth::PROTOCOL_VERSION = Net::OAuth::PROTOCOL_VERSION_1_0A';
147 1 50       6 die $@ if $@;
148              
149 1         10 'Net::OAuth';
150             };
151             }
152              
153             # simple check to see if we have access tokens; does not check to see if they are valid
154             sub authorized {
155 1     1 1 3 my $self = shift;
156              
157 1   33     16 return defined $self->{access_token} && $self->{access_token_secret};
158             }
159              
160             # get the athorization or authentication url
161             sub _get_auth_url {
162 0     0   0 my ($self, $which_url, %params ) = @_;
163              
164 0         0 $self->_request_request_token(%params);
165              
166 0         0 my $uri = $self->$which_url;
167 0         0 $uri->query_form(oauth_token => $self->request_token);
168 0         0 return $uri;
169             }
170              
171             # get the authentication URL from Twitter
172 0     0 1 0 sub get_authentication_url { return shift->_get_auth_url(authentication_url => @_) }
173              
174             # get the authorization URL from Twitter
175 0     0 1 0 sub get_authorization_url { return shift->_get_auth_url(authorization_url => @_) }
176              
177             # common portion of all oauth requests
178             sub _make_oauth_request {
179 1     1   19 my ($self, $type, %params) = @_;
180              
181 1         6 my $request = $self->_oauth->request($type)->new(
182             version => '1.0',
183             consumer_key => $self->{consumer_key},
184             consumer_secret => $self->{consumer_secret},
185             request_method => 'GET',
186             signature_method => 'HMAC-SHA1',
187             timestamp => time,
188             nonce => time ^ $$ ^ int(rand 2**32),
189             %params,
190             );
191              
192 1         58300 $request->sign;
193              
194 1         34695 return $request;
195             }
196              
197             # called by get_authorization_url to obtain request tokens
198             sub _request_request_token {
199 0     0   0 my ($self, %params) = @_;
200              
201 0         0 my $uri = $self->request_token_url;
202 0   0     0 $params{callback} ||= 'oob';
203 0         0 my $request = $self->_make_oauth_request(
204             'request token',
205             request_url => $uri,
206             %params,
207             );
208              
209 0         0 my $res = $self->{ua}->get($request->to_url);
210 0 0       0 die "GET $uri failed: ".$res->status_line
211             unless $res->is_success;
212              
213             # reuse $uri to extract parameters from the response content
214 0         0 $uri->query($res->content);
215 0         0 my %res_param = $uri->query_form;
216              
217 0         0 $self->request_token($res_param{oauth_token});
218 0         0 $self->request_token_secret($res_param{oauth_token_secret});
219             }
220              
221             # exchange request tokens for access tokens; call with (verifier => $verifier)
222             sub request_access_token {
223 0     0 1 0 my ($self, %params ) = @_;
224              
225 0         0 my $uri = $self->access_token_url;
226 0         0 my $request = $self->_make_oauth_request(
227             'access token',
228             request_url => $uri,
229             token => $self->request_token,
230             token_secret => $self->request_token_secret,
231             %params, # verifier => $verifier
232             );
233              
234 0         0 my $res = $self->{ua}->get($request->to_url);
235 0 0       0 die "GET $uri failed: ".$res->status_line
236             unless $res->is_success;
237              
238             # discard request tokens, they're no longer valid
239 0         0 delete $self->{request_token};
240 0         0 delete $self->{request_token_secret};
241              
242             # reuse $uri to extract parameters from content
243 0         0 $uri->query($res->content);
244 0         0 my %res_param = $uri->query_form;
245              
246             return (
247 0         0 $self->access_token($res_param{oauth_token}),
248             $self->access_token_secret($res_param{oauth_token_secret}),
249             $res_param{user_id},
250             $res_param{screen_name},
251             );
252             }
253              
254             # exchange username and password for access tokens
255             sub xauth {
256 0     0 1 0 my ( $self, $username, $password ) = @_;
257              
258 0         0 my $uri = $self->xauth_url;
259 0         0 my $request = $self->_make_oauth_request(
260             'XauthAccessToken',
261             request_url => $uri,
262             x_auth_username => $username,
263             x_auth_password => $password,
264             x_auth_mode => 'client_auth',
265             );
266              
267 0         0 my $res = $self->{ua}->get($request->to_url);
268 0 0       0 die "GET $uri failed: ".$res->status_line
269             unless $res->is_success;
270              
271             # reuse $uri to extract parameters from content
272 0         0 $uri->query($res->content);
273 0         0 my %res_param = $uri->query_form;
274              
275             return (
276 0         0 $self->access_token($res_param{oauth_token}),
277             $self->access_token_secret($res_param{oauth_token_secret}),
278             $res_param{user_id},
279             $res_param{screen_name},
280             );
281             }
282              
283             # common call for both Basic Auth and OAuth
284             sub _authenticated_request {
285 155     155   361 my $self = shift;
286              
287 155         390 my $authenticator = $self->{_authenticator};
288 155         664 $self->$authenticator(@_);
289             }
290              
291             sub _encode_args {
292 154     154   234 my $args = shift;
293              
294             # Values need to be utf-8 encoded. Because of a perl bug, exposed when
295             # client code does "use utf8", keys must also be encoded.
296             # see: http://www.perlmonks.org/?node_id=668987
297             # and: http://perl5.git.perl.org/perl.git/commit/eaf7a4d2
298 154 50       514 return { map { utf8::upgrade($_) unless ref($_); $_ } %$args };
  256         1862  
  256         1574  
299             }
300              
301             sub _oauth_authenticated_request {
302 1     1   4 my ($self, $http_method, $uri, $args, $authenticate) = @_;
303              
304 1         2 delete $args->{source}; # not necessary with OAuth requests
305              
306 1         5 my $is_multipart = grep { ref } %$args;
  0         0  
307              
308 1         2 my $msg;
309 1 50 33     12 if ( $authenticate && $self->authorized ) {
    0          
    0          
310 1         4 local $Net::OAuth::SKIP_UTF8_DOUBLE_ENCODE_CHECK = 1;
311              
312 1 50       6 my $request = $self->_make_oauth_request(
313             'protected resource',
314             request_url => $uri,
315             request_method => $http_method,
316             token => $self->access_token,
317             token_secret => $self->access_token_secret,
318             extra_params => $is_multipart ? {} : $args,
319             );
320              
321 1 50       28 if ( $http_method =~ /^(?:GET|DELETE)$/ ) {
    0          
322 1         12 $msg = HTTP::Request->new($http_method, $request->to_url);
323             }
324             elsif ( $http_method eq 'POST' ) {
325 0 0       0 $msg = $is_multipart
326             ? POST($request->request_url,
327             Authorization => $request->to_authorization_header,
328             Content_Type => 'form-data',
329             Content => [ %$args ],
330             )
331             : POST($$uri, Content => $request->to_post_body)
332             ;
333             }
334             else {
335 0         0 croak "unexpected http_method: $http_method";
336             }
337             }
338             elsif ( $http_method eq 'GET' ) {
339 0         0 $uri->query_form($args);
340 0         0 $args = {};
341 0         0 $msg = GET($uri);
342             }
343             elsif ( $http_method eq 'POST' ) {
344 0         0 my $encoded_args = { %$args };
345 0         0 _encode_args($encoded_args);
346 0         0 $msg = $self->_mk_post_msg($uri, $args);
347             }
348             else {
349 0         0 croak "unexpected http_method: $http_method";
350             }
351              
352 1         1339 return $self->{ua}->request($msg);
353             }
354              
355             sub _basic_authenticated_request {
356 154     154   402 my ($self, $http_method, $uri, $args, $authenticate) = @_;
357              
358 154         474 _encode_args($args);
359              
360 154         366 my $msg;
361 154 100       922 if ( $http_method =~ /^(?:GET|DELETE)$/ ) {
    50          
362 90         558 $uri->query_form($args);
363 90         21527 $msg = HTTP::Request->new($http_method, $uri);
364             }
365             elsif ( $http_method eq 'POST' ) {
366 64         250 $msg = $self->_mk_post_msg($uri, $args);
367             }
368             else {
369 0         0 croak "unexpected HTTP method: $http_method";
370             }
371              
372 154 100 100     48912 if ( $authenticate && $self->{username} && $self->{password} ) {
      66        
373 48         160 $msg->headers->authorization_basic(@{$self}{qw/username password/});
  48         423  
374             }
375              
376 154         15889 return $self->{ua}->request($msg);
377             }
378              
379             sub _mk_post_msg {
380 64     64   311 my ($self, $uri, $args) = @_;
381              
382 64 50       167 if ( grep { ref } values %$args ) {
  73         221  
383             # if any of the arguments are (array) refs, use form-data
384 0         0 return POST($uri, Content_Type => 'form-data', Content => [ %$args ]);
385             }
386             else {
387             # There seems to be a bug introduced by Twitter about 2013-02-25: If
388             # post arguments are uri encoded exactly the same way the OAuth spec
389             # requires base signature string encoding, Twitter chokes and throws a
390             # 401. This seems to be a violation of the OAuth spec on Twitter's
391             # part. The specifically states the more stringent URI encoding is for
392             # consistent signature generation and *only* applies to encoding the
393             # base signature string and Authorization header.
394              
395 64         95 my @pairs;
396 64         7041 while ( my ($k, $v) = each %$args ) {
397 73         5384 push @pairs, join '=', map URI::Escape::uri_escape_utf8($_, '^A-Za-z0-9\-\._~'), $k, $v;
398             }
399              
400 64         4242 my $content = join '&', @pairs;
401 64         342 return POST($uri, Content => $content);
402             }
403             }
404              
405             sub build_api_methods {
406 8     8 0 23 my $class = shift;
407              
408 8         38 my $api_def_module = $class->twitter_api_def_from;
409 8 50       917 eval "require $api_def_module" or die $@;
410 8         134 my $api_def = $api_def_module->api_def;
411              
412             my $with_url_arg = sub {
413 0     0   0 my ($path, $args) = @_;
414              
415 0 0       0 if ( defined(my $id = delete $args->{id}) ) {
416 0         0 $path .= uri_escape($id);
417             }
418             else {
419 0         0 chop($path);
420             }
421 0         0 return $path;
422 8         328 };
423              
424 8         76 while ( @$api_def ) {
425 20         48 my $api = shift @$api_def;
426 20         44 my $api_name = shift @$api;
427 20         33 my $methods = shift @$api;
428              
429 20         48 for my $method ( @$methods ) {
430 928         1665 my $name = shift @$method;
431 928         1171 my %options = %{ shift @$method };
  928         7485  
432              
433 928         4166 my ($arg_names, $path) = @options{qw/required path/};
434 928 100 100     2400 $arg_names = $options{params} if @$arg_names == 0 && @{$options{params}} == 1;
  452         3416  
435              
436 928 50   0   4122 my $modify_path = $path =~ s,/id$,/, ? $with_url_arg : sub { $_[0] };
  0         0  
437              
438             my $code = sub {
439 176     176   322271 my $self = shift;
440              
441             # copy callers args since we may add ->{source}
442 176 100       977 my $args = ref $_[-1] eq 'HASH' ? { %{pop @_} } : {};
  99         414  
443              
444 176 100 66     3213 if ( (my $legacy_method = $self->can("legacy_$name")) && (
    100          
445             exists $$args{-legacy_lists_api} ? delete $$args{-legacy_lists_api}
446             : $self->{legacy_lists_api} ) ) {
447 21         68 return $self->$legacy_method(@_, $args);
448             }
449              
450             # just in case it's included where it shouldn't be:
451 155         517 delete $args->{-legacy_lists_api};
452              
453 155 50       1304 croak sprintf "$name expected %d args", scalar @$arg_names if @_ > @$arg_names;
454              
455             # promote positional args to named args
456 155         556 for ( my $i = 0; @_; ++$i ) {
457 73         146 my $param = $arg_names->[$i];
458 73 50       246 croak "duplicate param $param: both positional and named"
459             if exists $args->{$param};
460              
461 73         539 $args->{$param} = shift;
462             }
463              
464 155 100 33     591 $args->{source} ||= $self->{source} if $options{add_source};
465              
466 155 100       711 my $authenticate = exists $args->{authenticate} ? delete $args->{authenticate}
467             : $options{authenticate}
468             ;
469             # promote boolean parameters
470 155         282 for my $boolean_arg ( @{ $options{booleans} } ) {
  155         864  
471 160 50       716 if ( exists $args->{$boolean_arg} ) {
472 0 0       0 next if $args->{$boolean_arg} =~ /^true|false$/;
473 0 0       0 $args->{$boolean_arg} = $args->{$boolean_arg} ? 'true' : 'false';
474             }
475             }
476              
477             # Workaround Twitter bug: any value passed for skip_user is treated as true.
478             # The only way to get 'false' is to not pass the skip_user at all.
479 155 50 33     819 delete $args->{skip_user} if exists $args->{skip_user} && $args->{skip_user} eq 'false';
480              
481             # replace placeholder arguments
482 155         285 my $local_path = $path;
483 155 100       704 $local_path =~ s,/:id$,, unless exists $args->{id}; # remove optional trailing id
484 155 50       483 $local_path =~ s/:(\w+)/delete $args->{$1} or croak "required arg '$1' missing"/eg;
  61         321  
485              
486             # stringify lists
487 155         615 for ( qw/screen_name user_id/ ) {
488 310 100       1239 $args->{$_} = join(',' => @{ $args->{$_} }) if ref $args->{$_} eq 'ARRAY';
  3         15  
489             }
490              
491 155         2168 my $uri = URI->new($self->{$options{base_url_method}} . "/$local_path.json");
492              
493 155         95930 return $self->_parse_result(
494             $self->_authenticated_request($options{method}, $uri, $args, $authenticate)
495             );
496 928         5647 };
497              
498 9     9   109 no strict 'refs';
  9         21  
  9         2221  
499 928         1107 $name = $_, *{"$class\::$_"} = $code for $name, @{$options{aliases}};
  928         2319  
  1110         10912  
500             }
501             }
502              
503             # catch expected error and promote it to an undef
504 8         28 for ( qw/list_members is_list_member list_subscribers is_list_subscriber
505             legacy_list_members legacy_is_list_member legacy_list_subscribers legacy_is_list_subscriber/ ) {
506 64 100       459 my $orig = $class->can($_) or next;
507              
508             my $code = sub {
509 11     11   22572 my $r = eval { $orig->(@_) };
  11         44  
510 11 50       32 if ( $@ ) {
511 0 0       0 return if $@ =~ /The specified user is not a (?:memb|subscrib)er of this list/;
512              
513 0         0 die $@;
514             }
515              
516 11         27 return $r;
517 56         214 };
518              
519 9     9   115 no strict 'refs';
  9         22  
  9         322  
520 9     9   331 no warnings 'redefine';
  9         19  
  9         869  
521 56         91 *{"$class\::$_"} = $code;
  56         219  
522             }
523              
524             # OAuth token accessors
525 8         29 for my $method ( qw/
526             access_token
527             access_token_secret
528             request_token
529             request_token_secret
530             / ) {
531 9     9   52 no strict 'refs';
  9         20  
  9         1069  
532 32         225 *{"$class\::$method"} = sub {
533 4     4   19 my $self = shift;
534              
535 4 100       20 $self->{$method} = shift if @_;
536 4         22 return $self->{$method};
537 32         166 };
538             }
539              
540             # OAuth url accessors
541 8         25 for my $method ( qw/
542             request_token_url
543             authentication_url
544             authorization_url
545             access_token_url
546             xauth_url
547             / ) {
548 9     9   78 no strict 'refs';
  9         34  
  9         4440  
549 40         270 *{"$class\::$method"} = sub {
550 0     0   0 my $self = shift;
551              
552 0 0       0 $self->{oauth_urls}{$method} = shift if @_;
553 0         0 return URI->new($self->{oauth_urls}{$method});
554 40         206 };
555             }
556              
557             }
558              
559             sub _from_json {
560 155     155   439 my ($self, $json) = @_;
561              
562 155         561 return eval { $json_handler->decode($json) };
  155         2137  
563             }
564              
565             sub _parse_result {
566 155     155   218796 my ($self, $res) = @_;
567              
568             # workaround for Laconica API returning bools as strings
569             # (Fixed in Laconi.ca 0.7.4)
570 155         574 my $content = $res->content;
571 155         1884 $content =~ s/^"(true|false)"$/$1/;
572              
573 155         498 my $obj = $self->_from_json($content);
574              
575             # Twitter sometimes returns an error with status code 200
576 155 50 66     1664 if ( $obj && ref $obj eq 'HASH' && exists $obj->{error} ) {
      66        
577 0         0 die Net::Twitter::Lite::Error->new(twitter_error => $obj, http_response => $res);
578             }
579              
580 155 100 66     687 if ( $res->is_success && defined $obj ) {
581 151 100       3780 if ( $self->{wrap_result} ) {
582 17         98 $obj = Net::Twitter::Lite::WrapResult->new($obj, $res);
583             }
584 151         2588 return $obj;
585             }
586              
587 4         74 my $error = Net::Twitter::Lite::Error->new(http_response => $res);
588 4 50       12 $error->twitter_error($obj) if ref $obj;
589              
590 4         29 die $error;
591             }
592              
593             1;