File Coverage

blib/lib/Doit/Lwp.pm
Criterion Covered Total %
statement 35 52 67.3
branch 15 32 46.8
condition 4 8 50.0
subroutine 6 7 85.7
pod 1 3 33.3
total 61 102 59.8


line stmt bran cond sub pod time code
1             # -*- perl -*-
2              
3             #
4             # Author: Slaven Rezic
5             #
6             # Copyright (C) 2017,2018 Slaven Rezic. All rights reserved.
7             # This package is free software; you can redistribute it and/or
8             # modify it under the same terms as Perl itself.
9             #
10             # Mail: slaven@rezic.de
11             # WWW: http://www.rezic.de/eserte/
12             #
13              
14             package Doit::Lwp; # Convention: all commands here should be prefixed with 'lwp_'
15              
16 1     1   6 use strict;
  1         2  
  1         27  
17 1     1   4 use warnings;
  1         2  
  1         42  
18             our $VERSION = '0.012';
19              
20 1     1   4 use Doit::Log;
  1         2  
  1         527  
21              
22 1     1 0 8 sub new { bless {}, shift }
23 1     1 0 3 sub functions { qw(lwp_mirror) }
24              
25             {
26             my $ua; # XXX cache in object?
27             sub _get_cached_ua {
28 0     0   0 my($self) = @_;
29 0 0       0 return $ua if $ua;
30 0         0 require LWP::UserAgent;
31 0         0 $ua = LWP::UserAgent->new; # XXX options?
32             }
33             }
34              
35             sub lwp_mirror {
36 4     4 1 16 my($self, $url, $filename, %opts) = @_;
37 4 50       12 if (!defined $url) { error "url is mandatory" }
  0         0  
38 4 50       10 if (!defined $filename) { error "filename is mandatory" }
  0         0  
39 4   50     19 my $refresh = delete $opts{refresh} || 'always';
40 4 50       25 if ($refresh !~ m{^(always|never)$}) { error "refresh may be 'always' or 'never'" }
  0         0  
41 4         8 my $debug = delete $opts{debug};
42 4         8 my $ua = delete $opts{ua};
43 4 50       10 error "Unhandled options: " . join(" ", %opts) if %opts;
44              
45 4 50 66     82 if (-e $filename && $refresh eq 'never') {
46 0         0 info "$url -> $filename already exists, do not refresh";
47 0         0 return 0;
48             }
49              
50 4   33     13 $ua ||= _get_cached_ua;
51              
52 4 50       25 if ($self->is_dry_run) {
53 0         0 info "mirror $url -> $filename (dry-run)";
54             } else {
55 4         27 info "mirror $url -> $filename";
56 4         421 my $resp = $ua->mirror($url, $filename);
57 4 50       639546 if (ref $ua eq 'HTTP::Tiny') {
58 4 100       15 if ($debug) {
59 2         659 require Data::Dumper;
60 2         5559 info "Response: " . Data::Dumper->new([$resp],[qw()])->Indent(1)->Useqq(1)->Sortkeys(1)->Terse(1)->Dump;
61             }
62 4 100       610 if (!$resp->{success}) {
    100          
63 2         7 my $msg = "mirroring failed: $resp->{status} $resp->{reason}";
64 2 100       9 if ($resp->{status} == 599) {
65 1         3 $msg .= ": $resp->{content}";
66             }
67 2         7 error $msg;
68             } elsif ($resp->{status} == 304) {
69 1         10 return 0;
70             } else {
71 1         9 return 1;
72             }
73             } else {
74 0 0         if ($debug) {
75 0           info "Response: " . $resp->as_string;
76             }
77 0 0         if ($resp->code == 304) {
    0          
    0          
78 0           return 0;
79             } elsif (!$resp->is_success) {
80 0           error "mirroring failed: " . $resp->status_line;
81             } elsif ($resp->header('X-Died')) {
82 0           error "mirroring failed: " . $resp->header('X-Died');
83             } else {
84 0           return 1;
85             }
86             }
87             }
88             }
89              
90             1;
91              
92             __END__