File Coverage

blib/lib/MToken/Client.pm
Criterion Covered Total %
statement 75 474 15.8
branch 0 186 0.0
condition 0 113 0.0
subroutine 25 51 49.0
pod 19 19 100.0
total 119 843 14.1


line stmt bran cond sub pod time code
1             package MToken::Client; # $Id: Client.pm 69 2019-06-09 16:17:44Z minus $
2 1     1   64452 use strict;
  1         10  
  1         34  
3 1     1   5 use feature qw/say/;
  1         3  
  1         120  
4 1     1   569 use utf8;
  1         15  
  1         4  
5              
6             =encoding utf-8
7              
8             =head1 NAME
9              
10             MToken::Client - Client for interaction with MToken server
11              
12             =head1 VIRSION
13              
14             Version 1.01
15              
16             =head1 SYNOPSIS
17              
18             use MToken::Client;
19              
20             my $clinet = new MToken::Client(
21             uri => "http://localhost/mtoken",
22             );
23             my $status = $clinet->check;
24              
25             if ($status) {
26             print STDOUT $client->response;
27             } else {
28             print STDERR $clinet->error;
29             }
30              
31             =head1 DESCRIPTION
32              
33             Client for interaction with MToken server
34              
35             =head2 new
36              
37             my $client = new MToken::Client(
38             uri => "http://localhost/mtoken",
39             user => $user, # optional
40             password => $password, # optional
41             timeout => $timeout, # default: 180
42             );
43              
44             Returns client
45              
46             =over 8
47              
48             =item B
49              
50             Timeout for LWP requests, in seconds.
51              
52             Default: 180 seconds (5 mins)
53              
54             =item B
55              
56             The LWP::UserAgent object
57              
58             =item B
59              
60             URI object, that describes URL of the WEB Server. See B attribute
61              
62             =item B
63              
64             Full URL of the WEB Server. See B attribute
65              
66             =item B
67              
68             Enable verbose mode. Possible boolean value: 0 or 1
69              
70             Add request and response data to trace stack if verbose is true
71              
72             Default: false
73              
74             =back
75              
76             =head1 METHODS
77              
78             =head2 check
79              
80             my $status = $client->check;
81              
82             Returns check-status of server. 0 - Error; 1 - Ok
83              
84             =head2 cleanup
85              
86             $client->cleanup;
87              
88             Cleanup all variable data in object and returns client object
89              
90             =head2 code
91              
92             my $code = $clinet->code;
93              
94             Returns HTTP code of the response
95              
96             =head2 credentials
97              
98             $client->credentials("username", "password", "realm")
99              
100             Set credentials for User Agent by Realm (name of basic authentication)
101              
102             =head2 del
103              
104             my $status = $clinet->del(
105             file => $filename,
106             );
107              
108             Request for deleting of the file on server by filename.
109             The method returns status of operation: 0 - Error; 1 - Ok
110              
111             See README file for details of data format
112              
113             =head2 download
114              
115             my $status = $clinet->download(
116             file => $filename,
117             );
118              
119             Request for download file on server by filename.
120             The method returns status of operation: 0 - Error; 1 - Ok
121              
122             See README file for details of data format
123              
124             =head2 error
125              
126             print $clinet->error;
127              
128             Returns error string
129              
130             =head2 info
131              
132             my $status = $clinet->info( $filename );
133              
134             Request for getting information about file on server by filename or file id.
135             The method returns info as hash
136              
137             =head2 line
138              
139             my $status_line = $clinet->line;
140              
141             Returns HTTP status line of response
142              
143             =head2 list
144              
145             my $status = $clinet->list( $filter );
146              
147             Request for getting list of files on server.
148             The method returns array of files
149              
150             =head2 remove
151              
152             my $status = $clinet->remove("filename");
153              
154             Remove file from server by name and returns status value
155              
156             =head2 req
157              
158             my $request = $clinet->req;
159              
160             Returns HTTP::Request object
161              
162             =head2 request
163              
164             my $json = $clinet->request("METHOD", "PATH", "DATA");
165              
166             Send request
167              
168             =head2 res
169              
170             my $response = $clinet->res;
171              
172             Returns HTTP::Response object
173              
174             =head2 status
175              
176             my $status = $clinet->status;
177              
178             Returns object status value. 0 - Error; 1 - Ok
179              
180             =head2 trace
181              
182             my $trace = $client->trace;
183             print $client->trace("New trace record");
184              
185             Gets trace stack or pushes new trace record to trace stack
186              
187             =head2 transaction
188              
189             print $client->transaction;
190              
191             Gets transaction string
192              
193             =head2 update
194              
195             my $status = $clinet->update("filename");
196              
197             Update file on server by name and returns status value
198              
199             =head2 upload
200              
201             $status = $clinet->upload(
202             file => $file,
203             filename=> $filename,
204             sha1 => $sha1, # Optional
205             md5 => $md5, # Optional
206             size => $filesize,
207             );
208              
209             Request for uploading of backup on server.
210             The method returns status of operation: 0 - Error; 1 - Ok
211              
212             See README file for details of data format
213              
214             =head1 HISTORY
215              
216             See C file
217              
218             =head1 DEPENDENCIES
219              
220             L, L, L
221              
222             =head1 TO DO
223              
224             See C file
225              
226             =head1 BUGS
227              
228             * none noted
229              
230             =head1 SEE ALSO
231              
232             L, L, L, L
233              
234             =head1 AUTHOR
235              
236             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
237              
238             =head1 COPYRIGHT
239              
240             Copyright (C) 1998-2019 D&D Corporation. All Rights Reserved
241              
242             =head1 LICENSE
243              
244             This program is free software; you can redistribute it and/or
245             modify it under the same terms as Perl itself.
246              
247             See C file and L
248              
249             =cut
250              
251 1     1   72 use vars qw/ $VERSION /;
  1         2  
  1         56  
252             $VERSION = '1.01';
253              
254 1     1   5 use Carp;
  1         2  
  1         55  
255 1     1   628 use CTK::Util qw/ :BASE /;
  1         156951  
  1         443  
256 1     1   446 use CTK::TFVals qw/ :ALL /;
  1         1932  
  1         251  
257 1     1   420 use CTK::ConfGenUtil;
  1         990  
  1         90  
258 1     1   478 use Time::HiRes qw/gettimeofday/;
  1         1351  
  1         4  
259 1     1   1840 use Try::Tiny;
  1         1878  
  1         55  
260 1     1   417 use MToken::Util;
  1         2  
  1         92  
261 1     1   409 use MToken::Const qw/DIR_TMP PWCACHE_FILE/;
  1         2  
  1         72  
262 1     1   516 use CTK::Serializer;
  1         30258  
  1         41  
263 1     1   9 use File::Basename qw/basename/;
  1         3  
  1         45  
264              
265             # LWP (libwww)
266 1     1   6 use URI;
  1         3  
  1         34  
267 1     1   446 use HTTP::Request;
  1         15278  
  1         35  
268 1     1   460 use HTTP::Response;
  1         6725  
  1         34  
269 1     1   7 use HTTP::Headers;
  1         3  
  1         38  
270 1     1   463 use HTTP::Headers::Util;
  1         902  
  1         53  
271 1     1   460 use HTTP::Request::Common qw//;
  1         2129  
  1         56  
272              
273             use constant {
274 1         4608 HTTP_TIMEOUT => 180,
275             MAX_REDIRECT => 10,
276             TRANSACTION_MASK => "%s%s >>> %s [%s in %s%s]", # GET /auth >>> 200 OK [1.04 KB in 0.0242 seconds (43.1 KB/sec)]
277             SERIALIZE_FORMAT => 'json',
278             CONTENT_TYPE => "application/json",
279             NO_JSON_RESPONSE => 1,
280             SR_ATTRS => {
281             json => [
282             { # For serialize
283             utf8 => 0,
284             pretty => 1,
285             allow_nonref => 1,
286             allow_blessed => 1,
287             },
288             { # For deserialize
289             utf8 => 0,
290             allow_nonref => 1,
291             allow_blessed => 1,
292             },
293             ],
294             },
295 1     1   7 };
  1         4  
296              
297             $SIG{INT} = sub { die "Interrupted\n"; };
298             $| = 1; # autoflush
299              
300             sub new {
301 0     0 1   my $class = shift;
302 0           my %args = @_;
303              
304             # General
305 0   0       $args{verbose} ||= 0; # Display content
306 0           $args{status} = 1; # 0 - error, 1 - ok
307 0           $args{error} = ""; # string
308 0           $args{code} = 0; # integer
309 0           $args{line} = ""; # line
310 0           $args{res_time} = 0;
311 0           $args{trace_redirects} = [];
312 0           $args{trace} = [];
313              
314             # TimeOut
315 0   0       $args{timeout} ||= HTTP_TIMEOUT; # TimeOut
316              
317             # Other defaults
318 0           $args{req} = undef;
319 0           $args{res} = undef;
320              
321             # Serializer
322 0           my $sr = new CTK::Serializer(SERIALIZE_FORMAT, attrs => SR_ATTRS);
323 0 0         croak(sprintf("Can't create json serializer: %s", $sr->error)) unless $sr->status;
324 0           $args{sr} = $sr;
325              
326             # Initial URI & URL
327 0 0         if ($args{uri}) {
328 0           $args{url} = scalar($args{uri}->canonical->as_string);
329             } else {
330 0 0         if ($args{url}) {
331 0           $args{uri} = new URI($args{url});
332             } else {
333 0           croak("Can't defined URL or URI");
334             }
335             }
336 0           my $userinfo = $args{uri}->userinfo;
337              
338             # User Agent
339 0           my $ua = $args{ua};
340 0 0         unless ($ua) {
341             my %uaopt = (
342             agent => __PACKAGE__."/".$VERSION,
343             max_redirect => MAX_REDIRECT,
344             timeout => $args{timeout},
345 0           requests_redirectable => ['GET','HEAD'],
346             protocols_allowed => ['http', 'https'],
347             );
348 0           $ua = new MToken::Client::UserAgent(%uaopt);
349 0           $ua->default_header('Cache-Control' => "no-cache");
350 0           $args{ua} = $ua;
351             }
352 0           $ua->{x_userinfo} = $userinfo;
353              
354             # URL Replacement (Redirect)
355 0           $args{redirect} = {};
356 0           my @trace_redirects = ();
357 0           my $turl = $args{url};
358 0 0         if ($args{redirect}->{$turl}) {
359 0           $args{url} = $args{redirect}->{$turl};
360 0           $args{uri} = new URI($args{url});
361             } else {
362 0           my $tres = $args{ua}->head($args{url});
363 0           my $dst_url;
364 0           foreach my $r ($tres->redirects) { # Redirects detected!
365 0 0         next unless $r->header('location');
366 0           my $dst_uri = new URI($r->header('location'));
367 0 0         $dst_uri->userinfo($userinfo) if $userinfo;
368 0           $dst_url = $dst_uri->canonical->as_string;
369 0           my $src_url = $r->request->uri->canonical->as_string;
370 0           push @trace_redirects, sprintf("Redirect detected (%s): %s ==> %s", $r->status_line, $src_url, $dst_url);
371             }
372 0 0         if ($dst_url) {
373 0           $args{redirect}->{$turl} = $dst_url; # Set SRC_URL -> DST_URL
374 0           $args{url} = $dst_url;
375 0           $args{uri} = new URI($dst_url);
376             }
377             }
378 0           $args{trace_redirects} = [@trace_redirects];
379              
380 0           my $self = bless {%args}, $class;
381 0           return $self;
382             }
383             sub credentials {
384 0     0 1   my $self = shift;
385 0           my $user = shift;
386 0           my $password = shift;
387 0   0       my $realm = shift || $self->{realm};
388              
389 0           $self->{user} = $user;
390 0           $self->{password} = $password;
391             #$self->req->authorization_basic( $user, $password ) if defined $user;
392 0 0         $self->{ua}->credentials($self->{uri}->host_port, $realm, $user, $password) if defined $user;
393             #$self->{ua}->add_handler( request_prepare => sub {
394             # my($req, $ua, $h) = @_;
395             # $req->authorization_basic( $user, $password ) if defined $user;
396             # return $req;
397             # } );
398              
399 0           return 1;
400             }
401              
402             sub error {
403 0     0 1   my $self = shift;
404 0           my $e = shift;
405 0 0         $self->{error} = $e if defined $e;
406 0           return $self->{error};
407             }
408             sub status {
409 0     0 1   my $self = shift;
410 0           my $s = shift;
411 0 0         $self->{status} = $s if defined $s;
412 0           return $self->{status};
413             }
414             sub code {
415 0     0 1   my $self = shift;
416 0           my $c = shift;
417 0 0         $self->{code} = $c if defined $c;
418 0           return $self->{code};
419             }
420             sub line {
421 0     0 1   my $self = shift;
422 0           my $l = shift;
423 0 0         $self->{line} = $l if defined $l;
424 0           return $self->{line};
425             }
426             sub req {
427 0     0 1   my $self = shift;
428 0           return $self->{req};
429             }
430             sub res {
431 0     0 1   my $self = shift;
432 0           return $self->{res};
433             }
434             sub transaction {
435 0     0 1   my $self = shift;
436 0           my $res = $self->res;
437 0 0         return 'NOOP' unless $res;
438 0   0       my $length = $res->content_length || 0;
439 0   0       my $rtime = $self->{res_time} // 0;
440 0 0 0       return sprintf(TRANSACTION_MASK,
441             $self->req->method, # Method
442             sprintf(" %s", _hide_pasword($res->request->uri)->canonical->as_string), # URL
443             $self->line // "ERROR", # Line
444             _fbytes($length), # Length
445             _fduration($rtime), # Duration
446             $rtime ? sprintf(" (%s/sec)", _fbytes($length/$rtime)) : "",
447             )
448             }
449             sub trace {
450 0     0 1   my $self = shift;
451 0           my $v = shift;
452 0 0         if (defined($v)) {
453 0           my $a = $self->{trace};
454 0           push @$a, lf_normalize($v);
455 0           return lf_normalize($v);
456             }
457 0   0       my $trace = $self->{trace} || [];
458 0           return join("\n",@$trace);
459             }
460              
461             sub cleanup {
462 0     0 1   my $self = shift;
463 0   0       my $status = shift || 0;
464 0           $self->{status} = $status;
465 0           $self->{error} = "";
466 0           $self->{code} = 0;
467 0           $self->{line} = "";
468 0           $self->{res_time} = 0;
469 0           undef $self->{req};
470 0           $self->{req} = undef;
471 0           undef $self->{res};
472 0           $self->{res} = undef;
473 0           undef $self->{trace};
474 0   0       my $trace = $self->{trace_redirects} || [];
475 0           $self->{trace} = [@$trace];
476 0           return $self;
477             }
478              
479             sub request {
480 0     0 1   my $self = shift;
481 0   0       my $method = shift || "GET";
482 0           my $path = shift;
483 0           my $data = shift;
484 0           my $no_json_response = shift;
485 0           $self->cleanup;
486              
487 0           my $ua = $self->{ua}; # UserAgent
488 0           my $sr = $self->{sr}; # Serializer
489 0           my $start_time = gettimeofday()*1;
490              
491             # URI
492 0           my $uri = $self->{uri}->clone;
493 0 0         $uri->path($path) if defined $path;
494              
495             # Prepare Request
496 0           my $req = new HTTP::Request(uc($method), $uri);
497 0 0         if ($method eq "POST") {
    0          
498 0 0 0       unless (defined($data) && ( is_hash($data) or !ref($data) )) {
      0        
499 0           croak("Data not specified! Please use HASH-ref or text data");
500             }
501 0           my ($req_content, $boundary);
502 0 0         if (is_hash($data)) { # form-data
503 0           my $ct = "multipart/form-data"; # "application/x-www-form-urlencoded"
504 0           ($req_content, $boundary) = HTTP::Request::Common::form_data($data, HTTP::Request::Common::boundary(6), $req);
505 0           $req->header('Content-Type' =>
506             HTTP::Headers::Util::join_header_words( $ct, undef, boundary => $boundary )
507             ); # might be redundant
508             } else {
509 0           $req->header('Content-Type', CONTENT_TYPE);
510 0           $req_content = $data;
511             }
512 0 0 0       if (defined($req_content) && !ref($req_content)) {
513 0           Encode::_utf8_on($req_content);
514 0           $req->header('Content-Length' => length(Encode::encode("utf8", $req_content)));
515 0           $req->content(Encode::encode("utf8", $req_content));
516             } else {
517 0           $req->header('Content-Length' => 0);
518             }
519             } elsif ($method eq "PUT") {
520 0           $req->header('Content-Type', 'application/octet-stream');
521 0 0         if (length($data)) { # File for uploading!
522 0           my $file = $data;
523 0   0       my $sizef = (-s $file) || 0;
524 0           $req->header('Content-Length', $sizef);
525 0           my $fh;
526             $req->content(sub {
527 0 0   0     unless ($fh) {
528 0 0         open($fh, "<", $file) || croak("Can't open file $file: $!");
529 0           binmode($fh);
530             }
531 0           my $buf = "";
532 0           my $n = read($fh, $buf, 1024);
533 0 0         if ($n) {
534 0           $sizef -= $n;
535             #say(sprintf("sizef=%d; n=%d", $sizef, $n));
536 0           return $buf;
537             }
538 0           close($fh);
539 0           return "";
540 0           });
541             } else {
542 0           $req->header('Content-Length', 0);
543             }
544             }
545 0           $self->{req} = $req;
546              
547             # Send Request
548 0 0 0       my $is_callback = ($data && ref($data) eq 'CODE') ? 1 : 0;
549 0 0         my $res = $is_callback ? $ua->request($req, $data) : $ua->request($req);
550 0           $self->{res} = $res;
551 0           $self->{res_time} = sprintf("%.*f",4, gettimeofday()*1 - $start_time) * 1;
552 0           my ($stat, $line, $code);
553 0           my $req_string = sprintf("%s %s", $method, _hide_pasword($res->request->uri)->canonical->as_string);
554 0 0         $stat = $res->is_success ? 1 : 0;
555 0           $self->status($stat);
556 0           $code = $res->code;
557 0           $self->code($code);
558 0           $line = $res->status_line;
559 0           $self->line($line);
560 0 0         $self->error(sprintf("%s >>> %s", $req_string, $line)) unless $stat;
561              
562             # Tracing
563             {
564             # Request
565 0           $self->trace($req_string);
  0            
566 0           $self->trace($res->request->headers_as_string);
567             $self->trace(
568             sprintf("-----BEGIN REQUEST CONTENT-----\n%s\n-----END REQUEST CONTENT-----", $req->content)
569 0 0 0       ) if ($self->{verbose} && defined($req->content) && length($req->content));
      0        
570              
571             # Response
572 0           $self->trace($line);
573 0           $self->trace($res->headers_as_string);
574             $self->trace(
575             sprintf("-----BEGIN RESPONSE CONTENT-----\n%s\n-----END RESPONSE CONTENT-----", $res->content)
576 0 0 0       ) if ($self->{verbose} && defined($res->content) && length($res->content));
      0        
577             }
578              
579             # Return
580 0 0 0       return () if $no_json_response || $method eq "HEAD";
581              
582             # DeSerialization
583 0   0       my $content = $res->decoded_content // '';
584 0 0         return () unless length($content);
585 0           my $structure = $sr->deserialize($content);
586 0 0         unless ($sr->status) {
587 0 0         if ($stat) {
588 0           $self->status(0);
589 0           $self->error($sr->error);
590             }
591 0           return ();
592             }
593 0 0 0       my %json = %$structure if $structure && ref($structure) eq 'HASH';
594 0 0         if ($stat) {
595 0           my $err = _check_response($structure);
596 0 0         if ($err) {
597 0           $self->status(0);
598 0           $self->error($err);
599 0           return %json;
600             }
601             }
602 0           return %json;
603             }
604              
605             sub check {
606 0     0 1   my $self = shift;
607 0           $self->request("HEAD", @_);
608 0 0         unless ($self->status) {
609 0   0       my $code = $self->code || 500;
610 0 0         if ($code >=400) {
611 0           my $cachefn = File::Spec->catfile(DIR_TMP, PWCACHE_FILE);
612 0 0 0       if (-e $cachefn and -f $cachefn) {
613 0           unlink $cachefn;
614 0           $self->request("HEAD", @_);
615             }
616             }
617             }
618 0 0         return 0 unless $self->status;
619 0           return 1;
620             }
621             sub list {
622 0     0 1   my $self = shift;
623 0           my $filter = shift;
624 0           my %json = $self->request("GET");
625 0 0         return unless $self->status;
626 0   0       my $files = $json{data}{files} || [];
627 0 0 0       return @$files unless defined $filter and $filter ne "";
628 0 0         return grep { $_->{filename} && index($_->{filename}, $filter) >= 0 } @$files;
  0            
629             }
630             sub info {
631 0     0 1   my $self = shift;
632 0           my $filename_or_id = shift;
633 0           my ($id,$filename);
634 0 0 0       if ($filename_or_id && $filename_or_id =~ /^([0-9]{8})$/) {
    0          
635 0           $id = $1
636             } elsif ($filename_or_id) {
637 0           $filename = basename($filename_or_id);
638             } else {
639 0           $self->error("Incorrect filename or ID");
640 0           $self->status(0);
641 0           return ();
642             }
643              
644 0           my %json = $self->request("GET");
645 0 0         return () unless $self->status;
646 0   0       my $files = $json{data}{files} || [];
647 0           my $ret;
648 0 0         if ($id) {
649 0 0         ($ret) = grep { $_->{date_sfx} && $_->{date_sfx} == $id } @$files;
  0            
650 0 0         return () unless $ret;
651 0           return %$ret;
652             }
653 0 0         ($ret) = grep { $_->{filename} && $_->{filename} eq $filename } @$files;
  0            
654 0 0         return () unless $ret;
655 0           return %$ret;
656             }
657             sub upload {
658             # Returns status
659 0     0 1   my $self = shift;
660 0           my $file = shift;
661 0 0 0       unless (defined($file) && length($file)) {
662 0           $self->error("Incorrect file");
663 0           $self->status(0);
664 0           return 0;
665             }
666 0           my $filename = basename($file);
667 0           my $req_object = "index_post";
668 0           my %json = $self->request("POST", undef, {
669             object => $req_object,
670             md5 => MToken::Util::md5sum($file),
671             sha1 => MToken::Util::sha1sum($file),
672             size => MToken::Util::filesize($file),
673             file1 => [
674             $file, $filename,
675             #"Content-Type" => 'text/html',
676             ],
677             });
678 0   0       my $res_object = $json{response_object} || '';
679 0 0         if ($req_object ne $res_object) {
680 0           $self->status(0);
681 0           $self->error(sprintf("Object mismatch: Expected: %s; Got: %s", $req_object, $res_object));
682             }
683 0           return $self->status;
684             }
685             sub update {
686 0     0 1   my $self = shift;
687 0           my $file = shift;
688 0 0 0       unless (defined($file) && length($file)) {
689 0           $self->error("Incorrect file");
690 0           $self->status(0);
691 0           return 0;
692             }
693 0           my $filename = basename($file);
694              
695 0           my $curpath = "";
696 0 0         if ($self->{updpath}) {
697 0           $curpath = $self->{updpath};
698             } else {
699 0   0       $curpath = $self->{uri}->path || "";
700 0           $curpath =~ s/\/+$//;
701 0           $self->{updpath} = $curpath;
702             }
703              
704 0           my $req_object = "file_put";
705 0           my %json = $self->request("PUT", join("/", $curpath, $filename), $file);
706 0   0       my $res_object = $json{response_object} || '';
707 0 0         if ($req_object ne $res_object) {
708 0           $self->status(0);
709 0           $self->error(sprintf("Object mismatch: Expected: %s; Got: %s", $req_object, $res_object));
710 0           return 0;
711             }
712              
713 0           my $out_md5 = $json{data}{out}{out_md5};
714 0 0         if ($out_md5) {
715 0   0       my $in_md5 = MToken::Util::md5sum($file) || '';
716 0 0         unless ($in_md5 eq $out_md5) {
717 0           $self->status(0);
718 0           $self->error(sprintf("File md5sum mismatch: Expected: %s; Got: %s", $in_md5, $out_md5));
719              
720             }
721             }
722 0           my $out_sha1 = $json{data}{out}{out_sha1};;
723 0 0         if ($out_sha1) {
724 0           my $in_sha1 = MToken::Util::sha1sum($file);
725 0 0         unless ($in_sha1 eq $out_sha1) {
726 0           $self->status(0);
727 0           $self->error(sprintf("File sha1sum mismatch: Expected: %s; Got: %s", $in_sha1, $out_sha1));
728             }
729             }
730              
731 0           return $self->status;
732             }
733             sub remove {
734 0     0 1   my $self = shift;
735 0           my $file = shift;
736 0 0 0       unless (defined($file) && length($file)) {
737 0           $self->error("Incorrect file");
738 0           $self->status(0);
739 0           return 0;
740             }
741 0           my $filename = basename($file);
742              
743 0           my $curpath = "";
744 0 0         if ($self->{rmvpath}) {
745 0           $curpath = $self->{rmvpath};
746             } else {
747 0   0       $curpath = $self->{uri}->path || "";
748 0           $curpath =~ s/\/+$//;
749 0           $self->{rmvpath} = $curpath;
750             }
751              
752 0           my %json = $self->request("DELETE", join("/", $curpath, $filename));
753 0           return $self->status;
754             }
755             sub download {
756             # Returns message or undef
757 0     0 1   my $self = shift;
758 0           my $file = shift; # name of file we download into
759 0 0 0       unless (defined($file) && length($file)) {
760 0           $self->error("Incorrect file");
761 0           $self->status(0);
762 0           return;
763             }
764 0           my $filename = basename($file);
765              
766 0           my $curpath = "";
767 0 0         if ($self->{dldpath}) {
768 0           $curpath = $self->{dldpath};
769             } else {
770 0   0       $curpath = $self->{uri}->path || "";
771 0           $curpath =~ s/\/+$//;
772 0           $self->{dldpath} = $curpath;
773             }
774              
775 0           my $f_init;
776             my $length; # total number of bytes to download
777 0           my $size = 0; # number of bytes received
778              
779             $self->request("GET", join("/", $curpath, $filename), sub {
780 0     0     my $buf = shift;
781 0 0         unless(defined $f_init) {
782 0           my $res = shift;
783 0           $f_init = 1;
784 0 0         unless(fileno(FILE_DOWNLOAD)) {
785 0 0         open(FILE_DOWNLOAD, ">", $file) || croak("Can't open $file: $!");
786             }
787 0           binmode FILE_DOWNLOAD;
788 0           $length = $res->content_length;
789             }
790 0 0         print FILE_DOWNLOAD $buf or croak("Can't write to $file: $!");
791 0           $size += length($buf);
792 0           }, NO_JSON_RESPONSE);
793 0           my $msg;
794 0 0         if (fileno(FILE_DOWNLOAD)) {
795 0 0         close(FILE_DOWNLOAD) || croak("Can't write to $file: $!");
796 0 0 0       if ($length && $size != $length) {
797 0           unlink($file);
798 0           $self->error(srintf("File %s error. %s of %s received", $file, _fbytes($size), _fbytes($length)));
799 0           $self->status(0);
800 0           return;
801             } else {
802 0           $msg = sprintf("File %s: %s received", $file, _fbytes($size));
803             }
804             }
805 0           my $res = $self->res;
806 0 0 0       if ($res->header("X-Died") || !$res->is_success) {
807 0 0         if (my $died = $res->header("X-Died")) {
808 0           $self->error($died);
809             } else {
810 0           $self->error("Can't get file");
811             }
812 0           unlink($file);
813 0           $self->status(0);
814 0           return;
815             }
816              
817 0 0         return $self->status ? $msg : undef;
818             }
819              
820             sub _check_response {
821             # Returns error string when status = 0 and error is not empty
822 0     0     my $res = shift;
823             # Returns:
824             # "..." - errors!
825             # undef - no errors
826 0           my @error;
827 0 0         if (is_hash($res)) {
828 0 0         return undef if value($res => "status"); # OK
829 0           my $errors = array($res => "error");
830 0           foreach my $err (@$errors) {
831 0 0         if (is_hash($err)) {
832 0           push @error, sprintf("E%04d %s", uv2zero(value($err => "code")), uv2null(value($err => "message")));
833             }
834             }
835             } else {
836 0           return "The response has not valid JSON format";
837             }
838 0           return join "; ", @error;
839             }
840             sub _fduration {
841 0   0 0     my $msecs = shift || 0;
842 0           my $secs = int($msecs);
843 0           my $hours = int($secs / (60*60));
844 0           $secs -= $hours * 60*60;
845 0           my $mins = int($secs / 60);
846 0           $secs %= 60;
847 0 0         if ($hours) {
    0          
    0          
848 0           return sprintf("%d hours %d minutes", $hours, $mins);
849             } elsif ($mins >= 2) {
850 0           return sprintf("%d minutes", $mins);
851             } elsif ($secs < 2*60) {
852 0           return sprintf("%.4f seconds", $msecs);
853             } else {
854 0           $secs += $mins * 60;
855 0           return sprintf("%d seconds", $secs);
856             }
857             }
858             sub _fbytes {
859 0     0     my $n = int(shift);
860 0 0         if ($n >= 1024 * 1024) {
    0          
861 0           return sprintf "%.3g MB", $n / (1024.0 * 1024);
862             } elsif ($n >= 1024) {
863 0           return sprintf "%.3g KB", $n / 1024.0;
864             } else {
865 0           return "$n bytes";
866             }
867             }
868             sub _hide_pasword {
869 0     0     my $src = shift;
870 0           my $uri_wop = $src->clone;
871 0           my $info = $uri_wop->userinfo();
872 0 0         if ($info) {
873 0           $info =~ s/:.*//;
874 0           $uri_wop->userinfo(sprintf("%s:*****", $info));
875             }
876 0           return $uri_wop;
877             }
878              
879             1;
880              
881             # We make our own specialization of LWP::UserAgent that asks for
882             # user/password if document is protected.
883             package # Hide it from PAUSE
884             MToken::Client::UserAgent;
885 1     1   677 use LWP::UserAgent;
  1         12382  
  1         33  
886 1     1   8 use MToken::Const;
  1         3  
  1         104  
887 1     1   6 use MToken::Util qw/parse_credentials tcd_save tcd_load/;
  1         2  
  1         78  
888 1     1   6 use base 'LWP::UserAgent';
  1         4  
  1         470  
889             sub get_basic_credentials {
890 0     0     my($self, $realm, $uri, $proxy) = @_;
891 0           my $uri2 = $uri->clone;
892 0 0         $uri2->userinfo($self->{x_userinfo}) if $self->{x_userinfo};
893 0           my $netloc = $uri->host_port;
894 0           my ($user, $password) = (parse_credentials($uri2->as_string));
895 0           my $cachefn = File::Spec->catfile(DIR_TMP, PWCACHE_FILE);
896 0 0 0       if ($user) {
    0 0        
    0          
897 0           return ($user, $password);
898             } elsif (-f $cachefn and -r _ and -s _) {
899 0   0       my $pair = tcd_load($cachefn) // "";
900 0           ($user, $password) = split(/\:/, $pair);
901 0 0 0       unless (defined($user) && length($user)) {
902 0           unlink($cachefn);
903 0           return (undef, undef);
904             }
905 0           return ($user, $password);
906             } elsif (-t) {
907 0           print STDERR "Enter username for $realm at $netloc: ";
908 0           $user = ;
909 0           chomp($user);
910 0 0         return (undef, undef) unless length $user;
911 0           print STDERR "Password: ";
912 0           system("stty -echo") unless MSWIN;
913 0           $password = ;
914 0           system("stty echo") unless MSWIN;
915 0           print STDERR "\n"; # because we disabled echo
916 0           chomp($password);
917 0 0         tcd_save($cachefn, sprintf("%s:%s", $user, $password))
918             if $password !~ /\:/; # See also MToken::Client::check function!
919 0           return ($user, $password);
920             } else {
921 0           return (undef, undef);
922             }
923             #return if $proxy;
924             #return $self->credentials($uri->host_port, $realm);
925             }
926              
927             1;