File Coverage

blib/lib/Net/Google/Drive/Simple/Core.pm
Criterion Covered Total %
statement 77 196 39.2
branch 13 70 18.5
condition 2 19 10.5
subroutine 19 30 63.3
pod 11 11 100.0
total 122 326 37.4


line stmt bran cond sub pod time code
1             ###########################################
2             ###########################################
3              
4             use strict;
5 10     10   4253 use warnings;
  10         21  
  10         241  
6 10     10   38  
  10         16  
  10         210  
7             use LWP::UserAgent ();
8 10     10   5797 use HTTP::Request ();
  10         429944  
  10         250  
9 10     10   91  
  10         25  
  10         129  
10             use File::MMagic ();
11 10     10   7005 use IO::File ();
  10         141746  
  10         255  
12 10     10   94 use MIME::Base64 ();
  10         21  
  10         124  
13 10     10   4671  
  10         5810  
  10         266  
14             use OAuth::Cmdline::CustomFile ();
15 10     10   3789 use OAuth::Cmdline::GoogleDrive ();
  10         975527  
  10         429  
16 10     10   4665  
  10         2779  
  10         192  
17             use Net::Google::Drive::Simple::Item ();
18 10     10   4531  
  10         28  
  10         224  
19             use JSON qw( from_json to_json );
20 10     10   61 use Log::Log4perl qw(:easy);
  10         20  
  10         148  
21 10     10   1106  
  10         39  
  10         87  
22             # used in V3.pm too
23             use constant {
24             'HTTP_CODE_OK' => 200,
25 10         8891 'HTTP_CODE_RESUME' => 308,
26             };
27 10     10   7937  
  10         25  
28             our $VERSION = '3.02';
29              
30             ###########################################
31             ###########################################
32             my ( $class, %options ) = @_;
33              
34 10     10 1 61 my $oauth;
35              
36 10         20 if ( exists $options{custom_file} ) {
37             $oauth = OAuth::Cmdline::CustomFile->new( custom_file => $options{custom_file} );
38 10 50       42 }
39 0         0 else {
40             $oauth = OAuth::Cmdline::GoogleDrive->new();
41             }
42 10         157  
43             my $self = {
44             init_done => undef,
45 10         17476 oauth => $oauth,
46             error => undef,
47             %options,
48             };
49              
50             return bless $self, $class;
51             }
52 10         57  
53             ###########################################
54             ###########################################
55             my ( $self, $set ) = @_;
56              
57             if ( defined $set ) {
58 0     0 1 0 $self->{error} = $set;
59             }
60 0 0       0  
61 0         0 return $self->{error};
62             }
63              
64 0         0 ###########################################
65             ###########################################
66             my ( $self, $path ) = @_;
67              
68             if ( $self->{init_done} ) {
69             return 1;
70 0     0 1 0 }
71              
72 0 0       0 DEBUG "Testing API";
73 0         0 if ( !$self->api_test() ) {
74             LOGDIE "api_test failed";
75             }
76 0         0  
77 0 0       0 $self->{init_done} = 1;
78 0         0  
79             return 1;
80             }
81 0         0  
82             ###########################################
83 0         0 ###########################################
84             my ($self) = @_;
85              
86             my $url = $self->file_url( { maxResults => 1 } );
87              
88             my $ua = LWP::UserAgent->new();
89 0     0 1 0  
90             my $req = HTTP::Request->new(
91 0         0 GET => $url->as_string,
92             );
93 0         0 $req->header( $self->{oauth}->authorization_headers() );
94             DEBUG "Fetching $url";
95 0         0  
96             my $resp = $ua->request($req);
97              
98 0         0 if ( $resp->is_success() ) {
99 0         0 DEBUG "API tested OK";
100             return 1;
101 0         0 }
102              
103 0 0       0 $self->error( $resp->message() );
104 0         0  
105 0         0 ERROR "API error: ", $resp->message();
106             return 0;
107             }
108 0         0  
109             ###########################################
110 0         0 ###########################################
111 0         0 my ( $self, $data ) = @_;
112              
113             return Net::Google::Drive::Simple::Item->new($data);
114             }
115              
116             ###########################################
117 2     2 1 3 ###########################################
118             my ( $self, $req, $noinit ) = @_;
119 2         10  
120             my $ua = LWP::UserAgent->new();
121             my $resp;
122              
123             my $RETRIES = 3;
124             my $SLEEP_INTERVAL = 10;
125 0     0 1 0  
126             {
127 0         0 # refresh token if necessary
128 0         0 if ( !$noinit ) {
129             $self->init();
130 0         0 }
131 0         0  
132             DEBUG "Fetching ", $req->url->as_string();
133              
134             $resp = $ua->request($req);
135 0 0       0  
  0         0  
136 0         0 # We want to check for success but resume is not an error
137             if ( !$resp->is_success() && $resp->code() != HTTP_CODE_RESUME() ) {
138             $self->error( $resp->message() );
139 0         0 warn "Failed with ", $resp->code(), ": ", $resp->message(), "\n";
140             if ( --$RETRIES >= 0 ) {
141 0         0 ERROR "Retrying in $SLEEP_INTERVAL seconds";
142             sleep $SLEEP_INTERVAL;
143             $self->{oauth}->token_expire();
144 0 0 0     0 $req->header( $self->{oauth}->authorization_headers() );
145 0         0 redo;
146 0         0 }
147 0 0       0 else {
148 0         0 ERROR "Out of retries.";
149 0         0 return $resp;
150 0         0 }
151 0         0 }
152 0         0  
153             DEBUG "Successfully fetched ", length( $resp->content() ), " bytes.";
154             }
155 0         0  
156 0         0 return $resp;
157             }
158              
159             ###########################################
160 0         0 ###########################################
161             my ( $self, $url, $info ) = @_;
162              
163 0         0 # default verb and headers
164             my $verb = $info->{'http_method'};
165             my @headers = (
166             $self->{'oauth'}->authorization_headers(),
167             @{ $info->{'extra_headers'} || [] },
168             );
169 4     4   9  
170             my $post_data;
171             if ( $info->{'body_parameters'} ) {
172 4         7 $post_data = to_json( $info->{'body_parameters'} );
173              
174             if ( !$info->{'multipart'} && !$info->{'resumable'} ) {
175 4 50       19 push @headers, 'Content-Type', 'application/json';
  4         22  
176             }
177             }
178 4         8  
179 4 100       10 # We might still have file content, with or without post data
180 2         10 # Handle GET / DELETE ("content" key might not actually existed)
181             my $content;
182 2 50 33     73 if ( $verb !~ /^( GET | DELETE )$/xms ) {
183 2         5  
184             # Try to copy over content
185             $content = $info->{'body_content'};
186              
187             # If this is not multipart, we can either have content or post_data
188             # but since we have no content, we use post_data and clear the var instead
189 4         7 if ( !$content && !$info->{'multipart'} ) {
190 4 100       42 $content = $post_data;
191             undef $post_data;
192             }
193 2         4 }
194              
195             if ( $info->{'multipart'} ) {
196              
197 2 50 33     11 # We have both $content and $post_data
198 2         3 # The $content is the file content
199 2         5 # The $post_data is the JSON content
200             # We need to create a new body from them
201              
202             my $part1 = "Content-type: application/json; charset=UTF-8\r\n\r\n" . $post_data;
203 4 50       14  
204             my $part2 = "Content-type: $info->{'body_parameters'}{'mimeType'}\r\nContent-Transfer-Encoding: base64\r\n\r\n" . MIME::Base64::encode_base64($content);
205              
206             my $body = "--my-boundary\r\n$part1\r\n" . "--my-boundary\r\n$part2\r\n" . "--my-boundary--\r\n";
207              
208             use bytes;
209             push @headers, 'Content-type' => 'multipart/related; boundary="my-boundary"',
210 0         0 'Content-Length' => length $body;
211              
212 0         0 $content = $body;
213             }
214 0         0  
215             my $req = HTTP::Request->new(
216 10     10   1326 $verb,
  10         43  
  10         70  
217 0         0 $url->as_string(),
218             \@headers,
219             $content,
220 0         0 );
221              
222             return $req;
223 4         15 }
224              
225             ###########################################
226             ###########################################
227             my ( $self, $req, $should_return_res ) = @_;
228              
229             my $res = $self->http_loop($req);
230 4         670 if ( $res->is_error() ) {
231             $self->error( $res->message() );
232             return $should_return_res ? $res : ();
233             }
234              
235             # were we asked to just return the response as is?
236 0     0   0 $should_return_res
237             and return $res;
238 0         0  
239 0 0       0 # v3 returns 204 on DELETE for no content
240 0         0 my $data = $res->code() == 204 ? {} : from_json( $res->content() );
241 0 0       0 return $data;
242             }
243              
244             # This is only for v2, v3 has something more flexible
245             ###########################################
246 0 0       0 ###########################################
247             my ( $self, $url, $post_data ) = @_;
248              
249 0 0       0 my @headers = ( $self->{'oauth'}->authorization_headers() );
250 0         0 my $verb = 'GET';
251             my $content;
252             if ($post_data) {
253             if ( ref $post_data eq 'ARRAY' ) {
254             ( $verb, $post_data ) = @{$post_data};
255             }
256             else {
257 0     0 1 0 $verb = 'POST';
258             }
259 0         0  
260 0         0 if ($post_data) {
261 0         0 push @headers, "Content-Type", "application/json";
262 0 0       0 $content = to_json($post_data);
263 0 0       0 }
264 0         0 }
  0         0  
265              
266             my $req = HTTP::Request->new(
267 0         0 $verb,
268             $url->as_string(),
269             \@headers,
270 0 0       0 $content,
271 0         0 );
272 0         0  
273             my $resp = $self->http_loop($req);
274              
275             if ( $resp->is_error() ) {
276 0         0 $self->error( $resp->message() );
277             return;
278             }
279              
280             my $data = from_json( $resp->content() );
281              
282             return $data;
283 0         0 }
284              
285 0 0       0 ###########################################
286 0         0 ###########################################
287 0         0 my ( $self, $file ) = @_;
288              
289             # There don't seem to be great implementations of mimetype
290 0         0 # detection on CPAN, so just use this one for now.
291              
292 0         0 if ( !$self->{magic} ) {
293             $self->{magic} = File::MMagic->new();
294             }
295              
296             return $self->{magic}->checktype_filename($file);
297             }
298 0     0 1 0  
299             ###########################################
300             ###########################################
301             my ( $self, $data ) = @_;
302              
303 0 0       0 my $idx = 0;
304 0         0  
305             if ( !defined $data ) {
306             die "no data in item_iterator";
307 0         0 }
308              
309             return sub {
310             {
311             my $next_item = $data->{items}->[ $idx++ ];
312              
313 1     1 1 3 return if !defined $next_item;
314              
315 1         12 if ( $next_item->{labels}->{trashed} ) {
316             DEBUG "Skipping $next_item->{ title } (trashed)";
317 1 50       14 redo;
318 0         0 }
319              
320             return $next_item;
321             }
322             };
323 3     3   4 }
  3         7  
324              
325 3 100       9 ###########################################
326             ###########################################
327 2 50       43 my ( $self, $opts ) = @_;
328 0         0  
329 0         0 $opts = {} if !defined $opts;
330              
331             my $default_opts = {
332 2         21 maxResults => 3000,
333             };
334 1         9  
335             $opts = {
336             %$default_opts,
337             %$opts,
338             };
339              
340 0     0 1   my $url = URI->new( $self->{api_file_url} );
341             $url->query_form($opts);
342 0 0          
343             return $url;
344 0           }
345              
346             ###########################################
347             ###########################################
348 0           my ( $self, $file_id ) = @_;
349              
350             LOGDIE 'Deletion requires file_id' if ( !defined $file_id );
351              
352             my $url = URI->new( $self->{api_file_url} . "/$file_id" );
353 0            
354 0           return $self->http_json($url);
355             }
356 0            
357             ###########################################
358             ###########################################
359             my $self = shift;
360             my $filename = shift;
361             my @stat = stat $filename;
362 0     0 1   my $remaining = $stat[7];
363             my $blksize = $stat[11] || 4096;
364 0 0          
365             die "$filename not a readable file with fixed size"
366 0           unless -r $filename
367             and $remaining;
368 0            
369             my $fh = IO::File->new( $filename, 'r' )
370             or die "Could not open $filename: $!";
371             $fh->binmode;
372              
373             return sub {
374 0     0     my $buffer;
375 0            
376 0           # upon retries the file is closed and we must reopen it
377 0           unless ( $fh->opened ) {
378 0   0       $fh = IO::File->new( $filename, 'r' )
379             or die "Could not open $filename: $!";
380 0 0 0       $fh->binmode;
381             $remaining = $stat[7];
382             }
383              
384 0 0         unless ( my $read = $fh->read( $buffer, $blksize ) ) {
385             die "Error while reading upload content $filename ($remaining remaining) $!"
386 0           if $! and $remaining;
387             $fh->close # otherwise, we found EOF
388             or die "close of upload content $filename failed: $!";
389 0     0     $buffer ||= ''; # LWP expects an empty string on finish, read returns 0
390             }
391             $remaining -= length($buffer);
392 0 0         return $buffer;
393 0 0         };
394             }
395 0            
396 0           1;
397              
398              
399 0 0         =pod
400 0 0 0        
401             =head1 DESCRIPTION
402 0 0          
403             This is a baseclass that the V2 and V3 implementations of the module use.
404 0   0       You shouldn't use this class directly.
405              
406 0           =head1 METHODS
407 0            
408 0           These are methods that are shared among L<Net::Google::Drive::Simple::V2>
409             and L<Net::Google::Drive::Simple::V3>.
410              
411             You wouldn't normally use these methods.
412              
413             =head2 C<new>
414              
415             Parent method to create one L<Net::Google::Drive::Simple> object.
416              
417             =head2 C<error>
418              
419             Set and retrieve the current error.
420              
421             =head2 C<init>
422              
423             Internal initialization to setup the connection.
424              
425             =head2 C<api_test>
426              
427             Used at init time to check that the connection is correct.
428              
429             =head2 C<data_factory>
430              
431             Set up an object of L<Net::Google::Drive::Simple::Item>.
432              
433             =head2 C<http_json>
434              
435             Make an HTTP request with a body.
436              
437             =head2 C<http_loop>
438              
439             Perform a request.
440              
441             =head2 C<file_metadata>
442              
443             my $metadata_hash_ref = $gd->file_metadata($fileId);
444              
445             Return metadata about the file with the specified ID from Google Drive.
446              
447             =head2 C<file_url>
448              
449             Retrieve a file URL.
450              
451             =head2 C<file_mime_type>
452              
453             Retrieve the mime type of a file.
454              
455             =head2 C<item_iterator>
456              
457             Create an iterator over items.
458              
459             =head2 C<path_resolve>
460              
461             Resolve paths to the folder ID.
462