File Coverage

blib/lib/WWW/Kickstarter.pm
Criterion Covered Total %
statement 54 293 18.4
branch 0 162 0.0
condition 0 53 0.0
subroutine 18 48 37.5
pod 23 23 100.0
total 95 579 16.4


line stmt bran cond sub pod time code
1              
2             package WWW::Kickstarter;
3              
4 1     1   47122 use strict;
  1         3  
  1         38  
5 1     1   8 use warnings;
  1         3  
  1         38  
6 1     1   424 no autovivification;
  1         958  
  1         6  
7              
8 1     1   406 use version; our $VERSION = qv('v1.12.0');
  1         2375  
  1         7  
9              
10              
11 1     1   562 use Time::HiRes qw( );
  1         1499  
  1         35  
12 1     1   528 use URI qw( );
  1         8590  
  1         40  
13 1     1   10 use URI::Escape qw( uri_escape_utf8 );
  1         3  
  1         83  
14 1     1   395 use URI::QueryParam qw( );
  1         1059  
  1         36  
15 1     1   455 use WWW::Kickstarter::Data::Categories qw( );
  1         4  
  1         33  
16 1     1   377 use WWW::Kickstarter::Data::Category qw( );
  1         4  
  1         35  
17 1     1   399 use WWW::Kickstarter::Data::Location qw( );
  1         4  
  1         29  
18 1     1   376 use WWW::Kickstarter::Data::NotificationPref qw( );
  1         5  
  1         32  
19 1     1   403 use WWW::Kickstarter::Data::Project qw( );
  1         4  
  1         33  
20 1     1   385 use WWW::Kickstarter::Data::Reward qw( );
  1         4  
  1         32  
21 1     1   9 use WWW::Kickstarter::Data::User qw( );
  1         3  
  1         29  
22 1     1   429 use WWW::Kickstarter::Data::User::Myself qw( );
  1         4  
  1         35  
23 1     1   9 use WWW::Kickstarter::Error qw( my_croak );
  1         3  
  1         60  
24 1     1   419 use WWW::Kickstarter::Iterator qw( );
  1         2  
  1         3021  
25              
26              
27             # ---
28              
29              
30             our $HTTP_CLIENT_CLASS = 'WWW::Kickstarter::HttpClient::Lwp';
31             our $JSON_PARSER_CLASS = 'WWW::Kickstarter::JsonParser::JsonXs';
32              
33              
34             # ---
35              
36              
37             sub _load_class {
38 0     0     my ($class) = @_;
39              
40             # This isn't exactly what Perl accepts as an identifier, but close enough.
41 0 0         $class =~ /^\w+(?:::\w+)*\z/
42             or my_croak(400, "Unacceptable class name $class");
43              
44 0 0         eval("require $class")
45             or die($@);
46              
47 0           return $class;
48             }
49              
50              
51             sub _expand_agent {
52 0     0     my ($agent) = @_;
53              
54 0 0 0       return $agent if defined($agent) && $agent !~ / \z/;
55              
56 0 0         $agent = 'unspecified_application/0.00 ' if !defined($agent);
57              
58 0           my $version = $VERSION;
59 0           $version =~ s/^v//;
60 0           $agent .= "perl-WWW-Kickstarter/$version ";
61              
62 0           return $agent;
63             }
64              
65              
66             # ---
67              
68              
69             sub new {
70 0     0 1   my ($class, %opts) = @_;
71              
72 0   0       my $http_client_class = delete($opts{http_client_class}) || $HTTP_CLIENT_CLASS;
73 0   0       my $json_parser_class = delete($opts{json_parser_class}) || $JSON_PARSER_CLASS;
74 0           my $agent = delete($opts{agent});
75 0           my $impolite = delete($opts{impolite});
76              
77 0 0         if (my @unrecognized = keys(%opts)) {
78 0           my_croak(400, "Unrecognized parameters @unrecognized");
79             }
80              
81 0           my $self = bless({}, $class);
82 0           $self->{http_client } = _load_class($http_client_class)->new( agent => _expand_agent($agent) );
83 0           $self->{json_parser } = _load_class($json_parser_class)->new();
84 0           $self->{polite } = !$impolite;
85 0           $self->{wait_until } = 0;
86 0           $self->{access_token} = undef;
87 0           $self->{my_id } = undef;
88              
89 0           return $self;
90             }
91              
92              
93             # ---
94              
95              
96             sub _validate_response {
97 0     0     my ($self, $response, %opts) = @_;
98              
99 0           my $recognize_404 = delete($opts{recognize_404});
100              
101 0 0 0       return 1
102             if (ref($response) || '') ne 'HASH';
103              
104 0           my $ksr_code = $response->{ksr_code};
105 0           my $http_code = $response->{http_code};
106 0           my $messages = $response->{error_messages};
107              
108 0           my $msg = "Error from Kickstarter";
109 0 0         $msg .= ": $ksr_code" if $ksr_code;
110 0 0         $msg .= ": HTTP $http_code" if $http_code;
111 0 0 0       $msg .= ": " . join(' // ', @{ $response->{error_messages} }) if $messages && @$messages;
  0            
112              
113 0 0 0       if ($recognize_404 && $http_code && $http_code eq '404') {
      0        
114 0           my_croak(404, $msg);
115             }
116              
117 0 0 0       if ($messages && @$messages) {
118 0           my_croak(500, $msg);
119             }
120              
121 0           return 1;
122             }
123              
124              
125             sub _http_request {
126 0     0     my ($self, $method, $url, $form) = @_;
127              
128 0           my $req_content;
129 0 0         if ($form) {
130 0 0         if ($method eq 'GET' ) {
131 0           $url = URI->new($url);
132 0           for (my $i=0; $i<@$form; $i+=2) {
133 0           $url->query_param_append($form->[$i+0] => $form->[$i+1]);
134             }
135             } else {
136 0           my @params;
137 0           for (my $i=0; $i<@$form; $i+=2) {
138 0           push @params, uri_escape_utf8($form->[$i+0]) . '=' . uri_escape_utf8($form->[$i+1]);
139             }
140              
141 0           $req_content = join('&', @params);
142             }
143             }
144              
145              
146 0           my $stime = Time::HiRes::time();
147              
148 0 0         if ($self->{polite}) {
149             # Throttle requests
150 0           my $wait_until = $self->{wait_until};
151 0           while ($stime < $wait_until) {
152             # Sometimes, it sleeps a little less than requested,
153             # resulting in a loop of ever-shorter sleeps.
154             # Sleeping an extra millisecond avoids that waste.
155 0           Time::HiRes::sleep($wait_until - $stime + 0.001);
156 0           $stime = Time::HiRes::time();
157             }
158             }
159              
160              
161 0           my ( $status_code, $status_line, $content_type, $content_encoding, $content ) = $self->{http_client}->request($method, $url, $req_content);
162              
163 0           my $etime = Time::HiRes::time();
164              
165 0           my $cool_down = $etime - $stime;
166 0 0         $cool_down = 4 if $cool_down > 4;
167 0           $self->{wait_until} = $etime + $cool_down;
168              
169 0 0         if ($content_type ne 'application/json') {
170 0 0 0       if ($status_code >= 200 && $status_code < 300) {
171 0           my_croak(500, "Error parsing response: Unexpected content type");
172             } else {
173 0           my_croak(500, "HTTP error: $status_line");
174             }
175             }
176              
177 0 0 0       if ($content_encoding && uc($content_encoding) ne 'UTF-8') {
178 0           my_croak(500, "Error parsing response: Unexpected content encoding \"$content_encoding\"");
179             }
180              
181 0 0         my $response = eval { $self->{json_parser}->decode($content) }
  0            
182             or my_croak(500, "Error parsing response: Invalid JSON");
183              
184 0           return $response;
185             }
186              
187              
188             my %ks_iterator_name_by_class = (
189             'WWW::Kickstarter::Data::Category' => 'categories',
190             'WWW::Kickstarter::Data::Project' => 'projects',
191             'WWW::Kickstarter::Data::User' => 'users',
192             );
193              
194             sub _call_api {
195 0 0   0     my_croak(400, "Incorrect usage") if @_ < 4;
196 0           my ($self, $url, $call_type, $class, %opts) = @_;
197              
198 0           my $recognize_404 = 0;
199 0           my $cursor_style;
200 0 0         if (ref($call_type)) {
201 0           ($call_type, my %call_opts) = @$call_type;
202 0           $recognize_404 = delete($call_opts{recognize_404});
203 0           $cursor_style = delete($call_opts{cursor_style});
204             }
205              
206 0           my @cursor;
207 0 0         if (defined($cursor_style)) {
208 0 0         if ($cursor_style eq 'start') {
    0          
209 0           my $start = delete($opts{start});
210 0 0 0       @cursor = ( cursor => $start ) if defined($start) && length($start);
211             }
212             elsif ($cursor_style eq 'page') {
213 0           my $page = delete($opts{page});
214 0 0 0       @cursor = ( page => $page ) if defined($page) && length($page);
215             }
216             else {
217 0           die("Invalid cursor style $cursor_style");
218             }
219             }
220              
221 0 0         if (my @unrecognized = keys(%opts)) {
222 0           my_croak(400, "Unrecognized parameters @unrecognized");
223             }
224              
225             my $access_token = $self->{access_token}
226 0 0         or my_croak(400, "Must login first");
227              
228 0           $url = URI->new('https://api.kickstarter.com/v1/' . $url);
229 0           $url->query_param_append(oauth_token => $access_token);
230              
231 0           $class = 'WWW::Kickstarter::Data::' . $class;
232              
233 0 0         if ($call_type eq 'single') {
    0          
    0          
234 0           my $response = $self->_http_request(GET => $url);
235 0           $self->_validate_response($response, recognize_404 => $recognize_404);
236              
237 0           return $class->_new($self, $response);
238             }
239             elsif ($call_type eq 'list') {
240 0           my $response = $self->_http_request(GET => $url);
241 0           $self->_validate_response($response, recognize_404 => $recognize_404);
242              
243 0           return map { $class->_new($self, $_) } @$response;
  0            
244             }
245             elsif ($call_type eq 'iterator') {
246 0 0         my $ks_iterator_name = $ks_iterator_name_by_class{$class}
247             or die("Can't determine Kickstarter iterator name for $class");
248              
249 0 0         $url->query_param_append(@cursor)
250             if @cursor;
251              
252             my $fetcher = sub {
253 0     0     my ($recognize_404) = @_;
254              
255 0 0         return () if !$url;
256              
257 0           my $response = $self->_http_request(GET => $url);
258 0           $self->_validate_response($response, recognize_404 => $recognize_404);
259              
260 0 0         $response->{$ks_iterator_name}
261             or my_croak(500, "Error parsing response: Unrecognized format");
262              
263 0 0         if (my $more_url = $response->{urls}{api}{"more_".$ks_iterator_name}) {
264 0           $url = URI->new($more_url);
265 0           $url->query_param_delete('signature');
266 0           $url->query_param_append(oauth_token => $access_token);
267             } else {
268 0           $url = undef;
269             }
270              
271 0           return map { $class->_new($self, $_) } @{ $response->{$ks_iterator_name} };
  0            
  0            
272 0           };
273              
274             # Prefetch the first batch to check for 404 errors.
275 0           my @results = $fetcher->($recognize_404);
276              
277 0           return WWW::Kickstarter::Iterator->new($fetcher, \@results);
278             }
279             else {
280 0           die("Invalid call type $call_type");
281             }
282             }
283              
284              
285             # ---
286              
287              
288             sub login {
289 0 0   0 1   my_croak(400, "Incorrect usage") if @_ < 3;
290 0           my ($self, $email, $password, %opts) = @_;
291              
292 0 0         if (my @unrecognized = keys(%opts)) {
293 0           my_croak(400, "Unrecognized parameters @unrecognized");
294             }
295              
296 0           my $response = $self->_http_request(
297             POST => 'https://api.kickstarter.com/xauth/access_token?client_id=2II5GGBZLOOZAA5XBU1U0Y44BU57Q58L8KOGM7H0E0YFHP3KTG',
298             [
299             email => $email,
300             password => $password,
301             ],
302             );
303              
304             {
305 0           my $ksr_code = $response->{ksr_code};
  0            
306 0 0 0       if ($ksr_code && $ksr_code eq 'invalid_xauth_login') {
307 0           my_croak(401, "Invalid user name or password");
308             }
309             }
310              
311 0           $self->_validate_response($response);
312              
313             my $access_token = $response->{access_token}
314 0 0         or my_croak(500, "Error parsing response: Missing access token");
315              
316 0           $self->{access_token} = $access_token;
317              
318             my $user_data = $response->{user}
319 0 0         or my_croak(500, "Error parsing response: Missing user data");
320              
321 0           my $myself = WWW::Kickstarter::Data::User::Myself->_new($self, $user_data);
322              
323 0           $self->{my_id} = $myself->id;
324              
325 0           return $myself;
326             }
327              
328              
329             # ---
330              
331              
332             sub _projects {
333 0     0     my ($self, $fixed, %opts) = @_;
334              
335 0           my %form;
336 0           for my $field_name (
337             'q', # Search terms
338             'category', # Category's "id", "slug" or "name".
339             'tag', # Tag's "id" or "slug".
340             'location', # Location's "id" (which is a "Where on Earth Identifier").
341             'backed_by_self', # Boolean
342             'starred_by_self', # Boolean
343             'backed_by_friends', # Boolean
344             'picked_by_staff', # Boolean
345             'state', # 'all' (default), 'live', 'successful'
346             'pledged', # 'all' (default), '0':<=$1k, '1':$1k to $10k, '2':$10k to $100k, '3':$100k to $1M, '4':>$1M
347             'goal', # 'all' (default), '0':<=$1k, '1':$1k to $10k, '2':$10k to $100k, '3':$100k to $1M, '4':>$1M
348             'raised', # 'all' (default), '0':<75%, '1':75% to 100%, '2':>100%
349             'sort', # 'magic' (default), 'end_date', 'newest', 'launch_date', 'popularity', 'most_funded'
350             ) {
351 0 0         $form{$field_name} = exists($fixed->{$field_name}) ? $fixed->{$field_name} : delete($opts{$field_name});
352             }
353              
354 0 0         $form{q} = '' if !defined($form{q});
355 0 0         $form{category} = '' if !defined($form{category});
356 0 0         $form{tag} = '' if !defined($form{tag});
357 0 0         $form{location} = '' if !defined($form{location});
358 0 0 0       $form{state} = 'all' if !defined($form{state}) || !length($form{state});
359 0 0 0       $form{pledged} = 'all' if !defined($form{pledged}) || !length($form{pledged});
360 0 0 0       $form{goal} = 'all' if !defined($form{goal}) || !length($form{goal});
361 0 0 0       $form{raised} = 'all' if !defined($form{raised}) || !length($form{raised});
362 0 0 0       $form{sort} = 'magic' if !defined($form{sort}) || !length($form{sort});
363              
364 0 0         $form{state} =~ /^(?:all|live|successful)\z/
365             or my_croak(400, "Unrecognized value for state. Valid: all, live, successful");
366 0 0         $form{pledged} =~ /^(?:all|[01234])\z/
367             or my_croak(400, "Unrecognized value for pledged. Valid: all, 0, 1, 2, 3, 4");
368 0 0         $form{goal} =~ /^(?:all|[01234])\z/
369             or my_croak(400, "Unrecognized value for goal. Valid: all, 0, 1, 2, 3, 4");
370 0 0         $form{raised} =~ /^(?:all|[012])\z/
371             or my_croak(400, "Unrecognized value for raised. Valid: all, 0, 1, 2");
372 0 0         $form{sort} =~ /^(?:magic|end_date|newest|launch_date|popularity|most_funded)\z/
373             or my_croak(400, "Unrecognized value for sort. Valid: magic, end_date, newest, launch_date, popularity, most_funded");
374              
375 0           my $url = URI->new('discover', 'http');
376 0 0         $url->query_param_append( term => $form{q} ) if length($form{q});
377 0 0         $url->query_param_append( category_id => $form{category} ) if length($form{category});
378 0 0         $url->query_param_append( tag_id => $form{tag} ) if length($form{tag});
379 0 0         $url->query_param_append( woe_id => $form{location} ) if length($form{location});
380 0 0         $url->query_param_append( backed => '1' ) if $form{backed_by_self};
381 0 0         $url->query_param_append( starred => '1' ) if $form{starred_by_self};
382 0 0         $url->query_param_append( social => '1' ) if $form{backed_by_friends};
383 0 0         $url->query_param_append( staff_picks => '1' ) if $form{picked_by_staff};
384 0 0         $url->query_param_append( state => $form{state} ) if $form{state} ne 'all';
385 0 0         $url->query_param_append( pledged => $form{pledged} ) if $form{pledged} ne 'all';
386 0 0         $url->query_param_append( goal => $form{goal} ) if $form{goal} ne 'all';
387 0 0         $url->query_param_append( raised => $form{raised} ) if $form{raised} ne 'all';
388 0 0         $url->query_param_append( sort => $form{sort} ) if $form{sort} ne 'magic';
389              
390 0           return $self->_call_api($url, [ 'iterator', cursor_style=>'page' ], 'Project', %opts);
391             }
392              
393              
394             # ---
395              
396              
397             sub myself {
398 0     0 1   my $self = shift;
399 0           return $self->_call_api('users/self', 'single', 'User::Myself', @_);
400             }
401              
402             sub my_id {
403 0     0 1   my ($self) = @_;
404 0           return $self->{my_id};
405             }
406              
407             sub my_notification_prefs {
408 0     0 1   my $self = shift;
409 0           return $self->_call_api('users/self/notifications', 'list', 'NotificationPref', @_);
410             }
411              
412             sub my_projects_created {
413 0     0 1   my $self = shift;
414 0           return $self->_call_api('users/self/projects/created', 'list', 'Project', @_);
415             }
416              
417             # There's no way to have 'discover?backed=1' return the results sorted by backing timestamp,
418             # so we'll continue to use the original interface ('users/self/projects/backed').
419             # But for consistency and possibly for foward-compatibility, we'll require a page-style cursor.
420             sub my_projects_backed {
421 0     0 1   my ($self, %opts) = @_;
422              
423 0 0         if (exists($opts{start})) {
424 0           my_croak(400, "Unrecognized parameter start");
425             }
426              
427 0 0         if (defined(my $page = delete($opts{page}))) {
428 0           $opts{start} = ($page - 1) * 10;
429             }
430              
431 0           return $self->_call_api('users/self/projects/backed', [ 'iterator', cursor_style=>'start' ], 'Project', %opts);
432             }
433              
434             # There's no way to have 'discover?starred=1' return the results sorted by starring timestamp,
435             # so we'll continue to use the original interface ('users/self/projects/starred').
436             # But for consistency and possibly for forward-compatibility, we'll require a page-style cursor.
437             sub my_projects_starred {
438 0     0 1   my ($self, %opts) = @_;
439              
440 0 0         if (exists($opts{start})) {
441 0           my_croak(400, "Unrecognized parameter start");
442             }
443              
444 0 0         if (defined(my $page = delete($opts{page}))) {
445 0           $opts{start} = ($page - 1) * 10;
446             }
447              
448 0           return $self->_call_api('users/self/projects/starred', [ 'iterator', cursor_style=>'start' ], 'Project', %opts);
449             }
450              
451             sub user {
452 0 0   0 1   my_croak(400, "Incorrect usage") if @_ < 2;
453 0           my $self = shift;
454 0           my $user_id = shift; # From "id" field. Cannot be "slug".
455 0           return $self->_call_api('users/'.uri_escape_utf8($user_id), [ 'single', recognize_404=>1 ], 'User', @_);
456             }
457              
458             sub user_projects_created {
459 0 0   0 1   my_croak(400, "Incorrect usage") if @_ < 2;
460 0           my $self = shift;
461 0           my $user_id = shift; # From "id" field. Cannot be "slug".
462 0           return $self->_call_api('users/'.uri_escape_utf8($user_id).'/projects/created', [ 'list', recognize_404=>1 ], 'Project', @_);
463             }
464              
465             sub project {
466 0 0   0 1   my_croak(400, "Incorrect usage") if @_ < 2;
467 0           my $self = shift;
468 0           my $project_id = shift; # "id" or "slug".
469 0           return $self->_call_api('projects/'.uri_escape_utf8($project_id), [ 'single', recognize_404=>1 ], 'Project', @_);
470             }
471              
472             sub project_rewards {
473 0 0   0 1   my_croak(400, "Incorrect usage") if @_ < 2;
474 0           my $self = shift;
475 0           my $project_id = shift; # "id" or "slug".
476 0           return $self->_call_api('projects/'.uri_escape_utf8($project_id).'/rewards', [ 'list', recognize_404=>1 ], 'Reward', @_);
477             }
478              
479             sub projects {
480 0     0 1   my $self = shift;
481 0           return $self->_projects({}, @_);
482             }
483              
484             sub projects_recommended {
485 0     0 1   my $self = shift;
486 0           return $self->_projects({ staff_picks => 1 }, @_);
487             }
488              
489             sub projects_ending_soon {
490 0     0 1   my $self = shift;
491 0           return $self->_projects({ state => 'live', sort => 'end_date' }, @_);
492             }
493              
494             sub projects_recently_launched {
495 0     0 1   my $self = shift;
496 0           return $self->_projects({ state => 'live', sort => 'newest' }, @_);
497             }
498              
499             sub popular_projects {
500 0     0 1   my $self = shift;
501 0           return $self->_projects({ sort => 'popularity' }, @_);
502             }
503              
504             sub location {
505 0 0   0 1   my_croak(400, "Incorrect usage") if @_ < 2;
506 0           my $self = shift;
507 0           my $location_id = shift; # From "id" field. Cannot be "slug".
508 0           return $self->_call_api('locations/'.uri_escape_utf8($location_id), [ 'single', recognize_404=>1 ], 'Location', @_);
509             }
510              
511             sub projects_near_location {
512 0     0 1   my $self = shift;
513 0           my $location_id = shift; # From "id" field. Cannot be "slug".
514 0           return $self->_projects({ location => $location_id }, @_);
515             }
516              
517             sub category {
518 0 0   0 1   my_croak(400, "Incorrect usage") if @_ < 2;
519 0           my $self = shift;
520 0           my $category_id = shift; # "id", "slug" or "name".
521 0           return $self->_call_api('categories/'.uri_escape_utf8($category_id), [ 'single', recognize_404=>1 ], 'Category', @_);
522             }
523              
524             sub categories {
525 0     0 1   my $self = shift;
526 0           my $iter = $self->_call_api('categories', 'iterator', 'Category');
527 0           return WWW::Kickstarter::Data::Categories->_new($self, [ $iter->get_rest() ]);
528             }
529              
530             sub category_projects {
531 0 0   0 1   my_croak(400, "Incorrect usage") if @_ < 2;
532 0           my $self = shift;
533 0           my $category_id = shift; # "id", "slug" or "name".
534 0           return $self->_projects({ category => $category_id }, @_);
535             }
536              
537             sub category_projects_recommended {
538 0 0   0 1   my_croak(400, "Incorrect usage") if @_ < 2;
539 0           my $self = shift;
540 0           my $category_id = shift; # "id", "slug" or "name".
541 0           return $self->_projects({ category => $category_id, staff_picks => 1 }, @_);
542             }
543              
544              
545             # ---
546              
547              
548             1;
549              
550              
551             __END__