File Coverage

blib/lib/App/Upfiles/FTPlazy.pm
Criterion Covered Total %
statement 26 133 19.5
branch 1 54 1.8
condition 0 45 0.0
subroutine 8 29 27.5
pod 0 23 0.0
total 35 284 12.3


line stmt bran cond sub pod time code
1             # Copyright 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2017, 2020 Kevin Ryde
2              
3             # This file is part of Upfiles.
4             #
5             # Upfiles is free software; you can redistribute it and/or modify it under
6             # the terms of the GNU General Public License as published by the Free
7             # Software Foundation; either version 3, or (at your option) any later
8             # version.
9             #
10             # Upfiles is distributed in the hope that it will be useful, but WITHOUT
11             # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12             # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
13             # more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Upfiles. If not, see .
17              
18             package App::Upfiles::FTPlazy;
19 1     1   651 use 5.010;
  1         4  
20 1     1   6 use strict;
  1         1  
  1         21  
21 1     1   6 use warnings;
  1         1  
  1         33  
22 1     1   4 use Carp;
  1         2  
  1         57  
23 1     1   622 use Locale::TextDomain ('App-Upfiles');
  1         20107  
  1         8  
24              
25             # uncomment this to run the ### lines
26             # use Smart::Comments;
27              
28             our $VERSION = 15;
29              
30             # Have croaks from Net::FTP reported against the caller (App::Upfiles)
31             # rather than here.
32             our @CARP_NOT = ('Net::FTP');
33              
34             sub new {
35 2     2 0 3210 my $class = shift;
36 2         13 return bless { verbose => 0,
37             want_dir => '/',
38             have_site_utime => 'unknown',
39             message => '',
40             code => 0,
41             @_ }, $class;
42             }
43              
44             sub message {
45 0     0 0 0 my ($self) = @_;
46 0 0       0 return (defined $self->{'ftp'} ? $self->{'ftp'}->message : $self->{'message'});
47             }
48             sub ok {
49 0     0 0 0 my $self = shift;
50 0         0 my $code = $self->code;
51 0   0     0 return $code >= 0 && $code < 400;
52             }
53             sub code {
54 0     0 0 0 my ($self) = @_;
55 0 0       0 return (defined $self->{'ftp'} ? $self->{'ftp'}->code : $self->{'code'});
56             }
57              
58             sub host {
59 0     0 0 0 my ($self, $host) = @_;
60 0 0       0 if (@_ < 2) { return $self->{'want_host'}; }
  0         0  
61              
62 0         0 $self->{'want_host'} = $host;
63 0         0 return 1;
64             }
65             sub ensure_host {
66 0     0 0 0 my ($self) = @_;
67 0 0       0 if (! defined $self->{'want_host'}) {
68 0         0 $self->{'message'} = 'No host() machine given';
69 0         0 return 0;
70             }
71 0 0 0     0 if (defined $self->{'got_host'}
72             && $self->{'got_host'} eq $self->{'want_host'}) {
73 0         0 return 1;
74             }
75              
76             # Net::FTP without SSL support quietly ignores SSL=>1, don't let that happen
77 0         0 require Net::FTP;
78 0 0 0     0 if ($self->{'use_SSL'} && ! Net::FTP->can('can_ssl')) {
79 0         0 croak "ftps use SSL but Net::FTP (version ",Net::FTP->VERSION,
80             ") does not have can_ssl()";
81             }
82              
83 0 0       0 if ($self->{'verbose'} >= 2) { print "OPEN $self->{'want_host'}\n"; }
  0         0  
84              
85             ### use_SSL: $self->{'use_SSL'}
86             ### use_TLS: $self->{'use_TLS'}
87 0 0       0 if ($self->{'use_SSL'}) {
88 0         0 require IO::Socket::SSL;
89 0 0       0 if (! $IO::Socket::SSL::DEBUG) {
90 0         0 $IO::Socket::SSL::DEBUG = $self->{'verbose'};
91             }
92             }
93              
94             ### open Net FTP ...
95 0         0 require Net::FTP;
96             my $ftp = Net::FTP->new ($self->{'want_host'},
97             Debug => ($self->{'verbose'} >= 2),
98 0         0 SSL => $self->{'use_SSL'},
99             );
100 0 0       0 if (! $ftp) {
101 0         0 $self->{'message'} = $@;
102 0         0 $self->{'code'} = 500;
103 0         0 return 0;
104             }
105              
106 0 0       0 if ($self->{'verbose'}) {
107             # IO::Socket::IP method
108 0         0 my ($host, $port) = $ftp->peerhost_service;
109 0         0 print "Connected $host $port\n";
110             }
111              
112 0 0       0 if ($self->{'use_TLS'}) {
113 0 0       0 if ($self->{'verbose'}) { print __("TLS\n"); }
  0         0  
114 0         0 $ftp->starttls;
115             }
116              
117 0         0 undef $self->{'got_username'};
118 0         0 $self->{'ftp'} = $ftp;
119 0         0 $self->{'got_host'} = $self->{'want_host'};
120 0         0 return 1;
121             }
122              
123             sub login {
124 0     0 0 0 my ($self, $username) = @_;
125 0         0 $self->{'want_username'} = $username;
126 0         0 return 1;
127             }
128             sub ensure_login {
129 0     0 0 0 my ($self) = @_;
130 0 0       0 if (! defined $self->{'want_username'}) {
131 0         0 $self->{'message'} = 'No login() username given';
132 0         0 $self->{'code'} = 500;
133 0         0 return 0;
134             }
135 0 0 0     0 if (defined $self->{'got_username'}
136             && $self->{'got_username'} eq $self->{'want_username'}) {
137 0         0 return 1;
138             }
139 0 0       0 if ($self->{'verbose'} >= 2) { print "LOGIN $self->{'want_username'}\n"; }
  0         0  
140 0 0       0 $self->{'ftp'}->login ($self->{'want_username'})
141             or return 0;
142 0         0 undef $self->{'got_binary'};
143 0         0 undef $self->{'got_cwd'};
144 0         0 $self->{'got_username'} = $self->{'want_username'};
145 0         0 return 1;
146             }
147              
148             sub binary {
149 0     0 0 0 my ($self) = @_;
150 0         0 $self->{'want_binary'} = 1;
151 0         0 return 1;
152             }
153             sub ensure_binary {
154 0     0 0 0 my ($self) = @_;
155 0 0       0 if (! defined $self->{'want_binary'}) {
156 0         0 return 1;
157             }
158 0 0 0     0 if (defined $self->{'got_binary'}
159             && $self->{'got_binary'} eq $self->{'want_binary'}) {
160 0         0 return 1;
161             }
162 0 0       0 my $method = ($self->{'want_binary'} ? 'binary' : 'ascii');
163 0 0       0 if ($self->{'verbose'} >= 2) { print "\U$method\E\n"; }
  0         0  
164 0 0       0 $self->{'ftp'}->$method
165             or return 0;
166 0         0 $self->{'got_binary'} = $self->{'want_binary'};
167 0         0 return 1;
168             }
169              
170             sub cwd {
171 4     4 0 2232 my ($self, $dir) = @_;
172              
173             # default root dir same as Net::FTP
174 4 50       12 if (! defined $dir) { $dir = '/'; }
  0         0  
175              
176             # relative to current want_dir
177 4         26 require File::Spec::Unix;
178 4         70 $dir = File::Spec::Unix->rel2abs ($dir, $self->{'want_dir'});
179 4         12 $dir = _collapse_dotdot_parent ($dir);
180              
181 4         7 $self->{'want_dir'} = $dir;
182 4         10 return 1;
183             }
184             sub ensure_cwd {
185 0     0 0 0 my ($self) = @_;
186 0 0 0     0 if (defined $self->{'got_dir'}
187             && $self->{'got_dir'} eq $self->{'want_dir'}) {
188 0         0 return 1;
189             }
190 0 0       0 if ($self->{'verbose'} >= 2) { print "CWD $self->{'want_dir'}\n"; }
  0         0  
191              
192 0 0       0 $self->{'ftp'}->cwd ($self->{'want_dir'})
193             or return 0;
194 0         0 $self->{'got_dir'} = $self->{'want_dir'};
195 0         0 return 1;
196             }
197             # this is wrong if the removed parent is a symlink, but prevents relative
198             # cwd()s accumulating an endlessly longer $self->{'want_path'}
199             sub _collapse_dotdot_parent {
200 4     4   7 my ($path) = @_;
201 4         20 while ($path =~ s{[^/]+/\.\.(/|$)}{}) {}
202 4         13 return File::Spec::Unix->canonpath($path);
203             }
204              
205             sub pwd {
206 0     0 0   my ($self) = @_;
207 0           return $self->{'want_dir'};
208             }
209              
210             sub ensure_all {
211 0     0 0   my ($self) = @_;
212 0   0       return $self->ensure_host
213             && $self->ensure_login
214             && $self->ensure_binary
215             && $self->ensure_cwd;
216             }
217              
218             sub put { # ($self, $local, $remote)
219 0     0 0   my $self = shift;
220             ### FTPlazy put(): @_
221 0   0       return $self->ensure_all && $self->{'ftp'}->put (@_);
222             }
223             sub delete {
224 0     0 0   my $self = shift; # ($self, $remote)
225 0   0       return $self->ensure_all && $self->{'ftp'}->delete (@_);
226             }
227             sub mkdir {
228 0     0 0   my $self = shift;
229 0   0       return $self->ensure_all && $self->{'ftp'}->mkdir (@_);
230             }
231             sub rmdir { # ($self, $remote)
232 0     0 0   my $self = shift;
233 0   0       return $self->ensure_all && $self->{'ftp'}->rmdir (@_);
234             }
235             sub rename { # ($self, $remote_oldname, $remote_newname)
236 0     0 0   my $self = shift;
237 0   0       return $self->ensure_all && $self->{'ftp'}->rename (@_);
238             }
239             sub site {
240 0     0 0   my $self = shift;
241 0   0       return $self->ensure_all && $self->{'ftp'}->site (@_);
242             }
243             sub quot {
244 0     0 0   my $self = shift;
245 0   0       return $self->ensure_all && $self->{'ftp'}->quot (@_);
246             }
247              
248             sub all_ok {
249 0     0 0   my ($self) = @_;
250 0   0       return (! $self->{'ftp'} || $self->{'ftp'}->pwd);
251             }
252              
253             sub mlsd {
254 0     0 0   my $self = shift;
255 0 0         $self->ensure_all || return;
256 0           return $self->{'ftp'}->_list_cmd("MLSD", @_);
257             }
258              
259             # sub mlsd {
260             # my ($self, $remote_dirname, $local_filename) = @_;
261             # $self->ensure_all;
262             # # ### MLSD: $remote_dirname
263             # # my $data = $self->{'ftp'}->_data_cmd("MLSD $remote_dirname")
264             # # or return undef;
265             # #
266             # # require File::Copy;
267             # # File::Copy::copy($data, $local_filename);
268             # # unless ($data->close) {
269             # # croak "Error closing data stream";
270             # # }
271             # #
272             # # ### MLSD message: $self->message
273             # # return undef;
274             # }
275              
276             1;
277             __END__