File Coverage

blib/lib/TMDB/Session.pm
Criterion Covered Total %
statement 30 87 34.4
branch 0 36 0.0
condition 0 19 0.0
subroutine 10 15 66.6
pod 0 3 0.0
total 40 160 25.0


line stmt bran cond sub pod time code
1             package TMDB::Session;
2              
3             #######################
4             # LOAD CORE MODULES
5             #######################
6 1     1   3 use strict;
  1         1  
  1         25  
7 1     1   3 use warnings FATAL => 'all';
  1         1  
  1         33  
8 1     1   3 use Carp qw(croak carp);
  1         2  
  1         52  
9              
10             #######################
11             # LOAD CPAN MODULES
12             #######################
13 1     1   363 use JSON::MaybeXS;
  1         5410  
  1         52  
14 1     1   458 use Encode qw();
  1         7622  
  1         23  
15 1     1   539 use HTTP::Tiny qw();
  1         37117  
  1         48  
16 1     1   465 use URI::Encode qw();
  1         967  
  1         26  
17 1     1   5 use Params::Validate qw(validate_with :types);
  1         1  
  1         161  
18 1     1   446 use Locale::Codes::Language qw(all_language_codes);
  1         155903  
  1         87  
19 1     1   7 use Object::Tiny qw(apikey apiurl lang debug client encoder json);
  1         1  
  1         7  
20              
21             #######################
22             # VERSION
23             #######################
24             our $VERSION = '1.2.1';
25              
26             #######################
27             # PACKAGE VARIABLES
28             #######################
29              
30             # Valid language codes
31             my %valid_lang_codes = map { $_ => 1 } all_language_codes('alpha-2');
32              
33             # Default Headers
34             my $default_headers = {
35             'Accept' => 'application/json',
36             'Content-Type' => 'application/json',
37             };
38              
39             # Default User Agent
40             my $default_ua = 'perl-tmdb-client';
41              
42             #######################
43             # PUBLIC METHODS
44             #######################
45              
46             ## ====================
47             ## Constructor
48             ## ====================
49             sub new {
50 0     0 0   my $class = shift;
51             my %opts = validate_with(
52             params => \@_,
53             spec => {
54             apikey => {
55             type => SCALAR,
56             },
57             apiurl => {
58             type => SCALAR,
59             optional => 1,
60             default => 'https://api.themoviedb.org/3',
61             },
62             lang => {
63             type => SCALAR,
64             optional => 1,
65             callbacks => {
66             'valid language code' =>
67 0     0     sub { $valid_lang_codes{ lc $_[0] } },
68             },
69             },
70 0           client => {
71             type => OBJECT,
72             isa => 'HTTP::Tiny',
73             optional => 1,
74             default => HTTP::Tiny->new(
75             agent => $default_ua,
76             default_headers => $default_headers,
77             ),
78             },
79             encoder => {
80             type => OBJECT,
81             isa => 'URI::Encode',
82             optional => 1,
83             default => URI::Encode->new(),
84             },
85             json => {
86             type => OBJECT,
87             can => [qw(decode)],
88             optional => 1,
89             default => JSON::MaybeXS->new(),
90             },
91             debug => {
92             type => BOOLEAN,
93             optional => 1,
94             default => 0,
95             },
96             },
97             );
98              
99 0 0         $opts{lang} = lc $opts{lang} if $opts{lang};
100 0           my $self = $class->SUPER::new(%opts);
101 0           return $self;
102             } ## end sub new
103              
104             ## ====================
105             ## Talk
106             ## ====================
107             sub talk {
108 0     0 0   my ( $self, $args ) = @_;
109              
110             # Build Call
111             my $url
112 0           = $self->apiurl . '/' . $args->{method} . '?api_key=' . $self->apikey;
113 0 0         if ( $args->{params} ) {
114 0           foreach
115 0           my $param ( sort { lc $a cmp lc $b } keys %{ $args->{params} } )
  0            
116             {
117 0 0         next unless defined $args->{params}->{$param};
118 0           $url .= "&${param}=" . $args->{params}->{$param};
119             } ## end foreach my $param ( sort { ...})
120             } ## end if ( $args->{params} )
121              
122             # Encode
123 0           $url = $self->encoder->encode($url);
124              
125             # Talk
126 0 0         warn "DEBUG: GET -> $url\n" if $self->debug;
127 0           my $response = $self->client->get($url);
128              
129             # Debug
130 0 0         if ( $self->debug ) {
131 0 0         warn "DEBUG: Got a successful response\n" if $response->{success};
132 0           warn "DEBUG: Got Status -> $response->{status}\n";
133             warn "DEBUG: Got Reason -> $response->{reason}\n"
134 0 0         if $response->{reason};
135             warn "DEBUG: Got Content -> $response->{content}\n"
136 0 0         if $response->{content};
137             } ## end if ( $self->debug )
138              
139             # Return
140 0 0         return unless $self->_check_status($response);
141 0 0 0       if ( $args->{want_headers} and exists $response->{headers} ) {
142              
143             # Return headers only
144 0           return $response->{headers};
145             } ## end if ( $args->{want_headers...})
146 0 0         return unless $response->{content}; # Blank Content
147             return $self->json->decode(
148 0           Encode::decode( 'utf-8-strict', $response->{content} ) ); # Real Response
149             } ## end sub talk
150              
151             ## ====================
152             ## PAGINATE RESULTS
153             ## ====================
154             sub paginate_results {
155 0     0 0   my ( $self, $args ) = @_;
156              
157 0           my $response = $self->talk($args);
158 0   0       my $results = $response->{results} || [];
159              
160             # Paginate
161 0 0 0       if ( $response->{page}
      0        
162             and $response->{total_pages}
163             and ( $response->{total_pages} > $response->{page} ) )
164             {
165 0   0       my $page_limit = $args->{max_pages} || '1';
166 0           my $current_page = $response->{page};
167 0           while ($page_limit) {
168 0 0         last if ( $current_page == $page_limit );
169 0           $current_page++;
170 0           $args->{params}->{page} = $current_page;
171 0           my $next_page = $self->talk($args);
172 0           push @$results, @{ $next_page->{results} },;
  0            
173 0 0         last if ( $next_page->{page} == $next_page->{total_pages} );
174 0           $page_limit--;
175             } ## end while ($page_limit)
176             } ## end if ( $response->{page}...)
177              
178             # Done
179 0 0         return @$results if wantarray;
180 0           return $results;
181             } ## end sub paginate_results
182              
183             #######################
184             # INTERNAL
185             #######################
186              
187             # Check Response status
188             sub _check_status {
189 0     0     my ( $self, $response ) = @_;
190              
191 0 0         if ( $response->{success} ) {
192 0           return 1;
193             }
194              
195 0 0         if ( $response->{content} ) {
196 0           my ( $code, $message );
197 0           my $ok = eval {
198              
199             my $status = $self->json->decode(
200 0           Encode::decode( 'utf-8-strict', $response->{content} ) );
201              
202 0           $code = $status->{status_code};
203 0           $message = $status->{status_message};
204              
205 0           1;
206             };
207              
208 0 0 0       if ( $ok and $code and $message ) {
      0        
209 0           carp sprintf( 'TMDB API Error (%s): %s', $code, $message );
210             }
211             } ## end if ( $response->{content...})
212              
213 0           return;
214             } ## end sub _check_status
215              
216             #######################
217             1;