File Coverage

blib/lib/WebService/Dropbox.pm
Criterion Covered Total %
statement 56 170 32.9
branch 3 84 3.5
condition 7 43 16.2
subroutine 19 33 57.5
pod 3 11 27.2
total 88 341 25.8


line stmt bran cond sub pod time code
1             package WebService::Dropbox;
2 10     10   1207858 use strict;
  10         108  
  10         333  
3 10     10   52 use warnings;
  10         20  
  10         264  
4 10     10   44 use Carp ();
  10         19  
  10         211  
5 10     10   77 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK SEEK_SET SEEK_END);
  10         34  
  10         599  
6 10     10   6615 use JSON;
  10         107502  
  10         60  
7 10     10   7187 use URI;
  10         43387  
  10         354  
8 10     10   3295 use File::Temp;
  10         68358  
  10         930  
9 10     10   4679 use WebService::Dropbox::Auth;
  10         30  
  10         621  
10 10     10   4373 use WebService::Dropbox::Files;
  10         26  
  10         950  
11 10     10   4455 use WebService::Dropbox::Files::CopyReference;
  10         27  
  10         553  
12 10     10   4300 use WebService::Dropbox::Files::ListFolder;
  10         25  
  10         608  
13 10     10   4202 use WebService::Dropbox::Files::UploadSession;
  10         25  
  10         648  
14 10     10   4101 use WebService::Dropbox::Sharing;
  10         27  
  10         615  
15 10     10   4168 use WebService::Dropbox::Users;
  10         26  
  10         19148  
16              
17             our $VERSION = '2.09';
18              
19             __PACKAGE__->mk_accessors(qw/
20             timeout
21             key
22             secret
23             access_token
24              
25             error
26             req
27             res
28             /);
29              
30             $WebService::Dropbox::USE_LWP = 0;
31             $WebService::Dropbox::DEBUG = 0;
32             $WebService::Dropbox::VERBOSE = 0;
33              
34             my $JSON = JSON->new->ascii;
35             my $JSON_PRETTY = JSON->new->pretty->utf8->canonical;
36              
37             sub import {
38 10     10   81 eval {
39 10         5564 require Furl;
40 10         253860 require IO::Socket::SSL;
41 10 50 33     684160 };if ($@ || ($Furl::VERSION < 3.08)) {
42 0         0 __PACKAGE__->use_lwp;
43             }
44             }
45              
46             sub use_lwp {
47 0     0 0 0 require LWP::UserAgent;
48 0         0 require HTTP::Request;
49 0         0 require HTTP::Request::Common;
50 0         0 $WebService::Dropbox::USE_LWP++;
51             }
52              
53             sub debug {
54 0 0   0 1 0 $WebService::Dropbox::DEBUG = defined $_[0] ? $_[0] : 1;
55             }
56              
57             sub verbose {
58 0 0   0 1 0 $WebService::Dropbox::VERBOSE = defined $_[0] ? $_[0] : 1;
59             }
60              
61             sub new {
62 2     2 0 774 my ($class, $args) = @_;
63              
64             bless {
65             timeout => $args->{timeout} || 86400,
66             key => $args->{key} || '',
67             secret => $args->{secret} || '',
68             access_token => $args->{access_token} || '',
69 2   50     42 env_proxy => $args->{env_proxy} || 0,
      50        
      50        
      50        
      100        
70             }, $class;
71             }
72              
73             sub api {
74 0     0 0 0 my ($self, $args) = @_;
75              
76             # Content-download endpoints
77 0 0       0 if (my $output = delete $args->{output}) {
78 0 0       0 if (ref $output eq 'CODE') {
    0          
79 0         0 $args->{write_code} = $output; # code ref
80             } elsif (ref $output) {
81 0         0 $args->{write_file} = $output; # file handle
82 0         0 binmode $args->{write_file};
83             } else {
84 0         0 open $args->{write_file}, '>', $output; # file path
85             Carp::croak("invalid output, output must be code ref or filehandle or filepath.")
86 0 0       0 unless $args->{write_file};
87 0         0 binmode $args->{write_file};
88             }
89             }
90              
91             # Always HTTP POST. https://www.dropbox.com/developers/documentation/http/documentation#formats
92 0         0 $args->{method} = 'POST';
93              
94 0   0     0 $args->{headers} ||= [];
95              
96 0 0 0     0 if ($self->access_token && $args->{url} ne 'https://notify.dropboxapi.com/2/files/list_folder/longpoll') {
97 0         0 push @{ $args->{headers} }, 'Authorization', 'Bearer ' . $self->access_token;
  0         0  
98             }
99              
100             # Set PARAMETERS
101 0         0 my $params = delete $args->{params};
102              
103             # Token
104             # * PARAMETERS in to Request Body (application/x-www-form-urlencoded)
105             # * RETURNS in to Response Body (application/json)
106 0 0       0 if ($args->{url} eq 'https://api.dropboxapi.com/oauth2/token') {
    0          
    0          
107 0         0 $args->{content} = $params;
108             }
109              
110             # RPC endpoints
111             # * PARAMETERS in to Request Body (application/json)
112             # * RETURNS in to Response Body (application/json)
113             elsif ($args->{url} =~ qr{ \A https://(?:api|notify).dropboxapi.com }xms) {
114 0 0       0 if ($params) {
115 0         0 push @{ $args->{headers} }, 'Content-Type', 'application/json';
  0         0  
116 0         0 $args->{content} = $JSON->encode($params);
117             }
118             }
119              
120             # Content-upload endpoints or Content-download endpoints
121             # * PARAMETERS in to Dropbox-API-Arg (JSON Format)
122             # * RETURNS in to Dropbox-API-Result (JSON Format)
123             elsif ($args->{url} =~ qr{ \A https://content.dropboxapi.com }xms) {
124 0 0       0 if ($params) {
125 0         0 push @{ $args->{headers} }, 'Dropbox-API-Arg', $JSON->encode($params);
  0         0  
126             }
127 0 0       0 if ($args->{content}) {
128 0         0 push @{ $args->{headers} }, 'Content-Type', 'application/octet-stream';
  0         0  
129             }
130             }
131              
132 0         0 my ($req, $res);
133 0 0       0 if ($WebService::Dropbox::USE_LWP) {
134 0         0 ($req, $res) = $self->api_lwp($args);
135             } else {
136 0         0 ($req, $res) = $self->api_furl($args);
137             }
138              
139 0         0 $self->req($req);
140 0         0 $self->res($res);
141              
142 0 0       0 my $is_success = $self->res->code =~ qr{ \A [23] }xms ? 1 : 0;
143              
144 0         0 my $decoded_content = $res->decoded_content;
145              
146 0         0 my $res_data;
147 0         0 my $res_json = $res->header('Dropbox-Api-Result');
148 0 0 0     0 if (!$res_json && $res->header('Content-Type') =~ qr{ \A (?:application/json|text/javascript) }xms) {
149 0         0 $res_json = $decoded_content;
150             }
151              
152 0 0 0     0 if ($res_json && $res_json ne 'null') {
153 0         0 $res_data = $JSON->decode($res_json);
154             }
155              
156 0 0 0     0 if ($WebService::Dropbox::DEBUG || !$is_success) {
157 0 0       0 my $level = $is_success ? 'DEBUG': 'ERROR';
158 0 0       0 my $color = $is_success ? "\e[32m" : "\e[31m";
159 0         0 my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time);
160 0         0 my $time = sprintf("%04d-%02d-%02dT%02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec);
161 0 0       0 if ($WebService::Dropbox::VERBOSE) {
162             warn sprintf(qq|%s [WebService::Dropbox] [%s] %s
163             \e[90m%s %s %s
164             %s
165             %s\e[0m
166             ${color}%s %s\e[0m
167             \e[90m%s
168             %s\e[0m
169             |,
170             $time,
171             $level,
172             $req->uri,
173             $req->method,
174             $req->uri,
175             $req->protocol || '',
176             $req->headers->as_string,
177 0 0 0     0 ( ref $args->{content} ? '' : $args->{content} && $params ? $JSON_PRETTY->encode($params) : '' ),
    0 0        
    0          
178             $res->protocol,
179             $res->status_line,
180             $res->headers->as_string,
181             ( $res_data ? $JSON_PRETTY->encode($res_data) : $decoded_content . "\n" ),
182             );
183             } else {
184 0 0 0     0 warn sprintf("%s [WebService::Dropbox] [%s] %s %s -> [%s] %s",
185             $time,
186             $level,
187             $req->uri,
188             ( $params ? $JSON->encode($params) : '-' ),
189             $res->code,
190             ( $res_json || $decoded_content ),
191             );
192             }
193             }
194              
195 0 0       0 unless ($is_success) {
196 0 0       0 unless ($self->error) {
197 0         0 $self->error($decoded_content);
198             }
199 0         0 return;
200             }
201              
202 0         0 $self->error(undef);
203              
204 0   0     0 return $res_data || +{};
205             }
206              
207             sub api_lwp {
208 0     0 0 0 my ($self, $args) = @_;
209              
210 0 0       0 my @headers = @{ $args->{headers} || +[] };
  0         0  
211              
212 0 0       0 if ($args->{write_file}) {
213             $args->{write_code} = sub {
214 0     0   0 my $buf = shift;
215 0         0 $args->{write_file}->print($buf);
216 0         0 };
217             }
218              
219 0 0 0     0 if ($args->{content} && UNIVERSAL::can($args->{content}, 'read')) {
220 0         0 my $buf;
221 0         0 my $content = delete $args->{content};
222             $args->{content} = sub {
223 0     0   0 read($content, $buf, 1024);
224 0         0 return $buf;
225 0         0 };
226             my $assert = sub {
227 0 0   0   0 $_[0] or Carp::croak(
228             "Failed to $_[1] for Content-Length: $!",
229             );
230 0         0 };
231 0         0 $assert->(defined(my $cur_pos = tell($content)), 'tell');
232 0         0 $assert->(seek($content, 0, SEEK_END), 'seek');
233 0         0 $assert->(defined(my $end_pos = tell($content)), 'tell');
234 0         0 $assert->(seek($content, $cur_pos, SEEK_SET), 'seek');
235 0         0 my $content_length = $end_pos - $cur_pos;
236 0         0 push @headers, 'Content-Length' => $content_length;
237             }
238              
239 0         0 my $req;
240 0 0 0     0 if ($args->{content} && ref $args->{content} eq 'HASH') {
241             # application/x-www-form-urlencoded
242             $req = HTTP::Request::Common::request_type_with_data(
243             $args->{method},
244             $args->{url},
245             @headers,
246             Content => $args->{content}
247 0         0 );
248             } else {
249             # application/json or application/octet-stream
250             # $args->{content} is encodeed json or file handle
251             $req = HTTP::Request->new(
252             $args->{method},
253             $args->{url},
254             \@headers,
255             $args->{content},
256 0         0 );
257             }
258              
259 0         0 $req->protocol('HTTP/1.1');
260              
261 0         0 my $res = $self->ua->request($req, $args->{write_code});
262 0         0 ($req, $res);
263             }
264              
265             sub api_furl {
266 0     0 0 0 my ($self, $args) = @_;
267              
268 0 0       0 if (my $write_file = delete $args->{write_file}) {
269             $args->{write_code} = sub {
270 0     0   0 $write_file->print($_[3]);
271 0         0 };
272             }
273              
274 0 0       0 if (my $write_code = delete $args->{write_code}) {
275             $args->{write_code} = sub {
276 0 0   0   0 if ($_[0] =~ qr{ \A 2 }xms) {
277 0         0 $write_code->(@_);
278             } else {
279 0         0 $self->error($_[3]);
280             }
281 0         0 };
282             }
283              
284 0         0 my $res = $self->furl->request(%$args);
285 0         0 ($res->request, $res);
286             }
287              
288             sub ua {
289 0     0 0 0 my $self = shift;
290 0         0 my $ua = LWP::UserAgent->new;
291 0         0 $ua->timeout($self->timeout);
292 0 0       0 if ($self->{env_proxy}) {
293 0         0 $ua->env_proxy;
294             }
295 0         0 $ua;
296             }
297              
298             sub furl {
299 0     0 0 0 my $self = shift;
300 0 0       0 unless ($self->{furl}) {
301 0         0 $self->{furl} = Furl->new(
302             timeout => $self->timeout,
303             ssl_opts => {
304             SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER(),
305             },
306             );
307 0 0       0 $self->{furl}->env_proxy if $self->{env_proxy};
308             }
309 0         0 $self->{furl};
310             }
311              
312             sub mk_accessors {
313 10     10 0 25 my $package = shift;
314 10     10   99 no strict 'refs';
  10         32  
  10         1905  
315 10         29 foreach my $field ( @_ ) {
316 70         346 *{ $package . '::' . $field } = sub {
317 0 0   0   0 return $_[0]->{ $field } if scalar( @_ ) == 1;
318 0 0       0 return $_[0]->{ $field } = scalar( @_ ) == 2 ? $_[1] : [ @_[1..$#_] ];
319 70         228 };
320             }
321             }
322              
323 2 100   2 1 1613 sub env_proxy { $_[0]->{env_proxy} = defined $_[1] ? $_[1] : 1 }
324              
325             1;
326             __END__