File Coverage

blib/lib/Net/SFTP/Foreign/Common.pm
Criterion Covered Total %
statement 22 246 8.9
branch 1 190 0.5
condition 0 72 0.0
subroutine 7 26 26.9
pod 0 7 0.0
total 30 541 5.5


line stmt bran cond sub pod time code
1             package Net::SFTP::Foreign::Common;
2              
3             our $VERSION = '1.76_02';
4              
5 3     3   20 use strict;
  3         8  
  3         84  
6 3     3   15 use warnings;
  3         6  
  3         76  
7 3     3   15 use Carp;
  3         14  
  3         337  
8              
9             BEGIN {
10             # Some versions of Scalar::Util are crippled
11 3     3   20 require Scalar::Util;
12 3         86 eval { Scalar::Util->import(qw(dualvar tainted)); 1 }
  3         103  
13 3 50       96 or do {
14 0         0 *tainted = sub { croak "The version of Scalar::Util installed on your system "
15 0         0 . "does not provide 'tainted'" };
16 0         0 *dualvar = sub { $_[0] };
  0         0  
17             };
18             }
19              
20 3     3   19 use Net::SFTP::Foreign::Helpers qw(_gen_wanted _ensure_list _debug _glob_to_regex _is_lnk _is_dir $debug);
  3         4  
  3         409  
21 3     3   20 use Net::SFTP::Foreign::Constants qw(:status);
  3         5  
  3         4124  
22              
23             my %status_str = ( SSH2_FX_OK, "OK",
24             SSH2_FX_EOF, "End of file",
25             SSH2_FX_NO_SUCH_FILE, "No such file or directory",
26             SSH2_FX_PERMISSION_DENIED, "Permission denied",
27             SSH2_FX_FAILURE, "Failure",
28             SSH2_FX_BAD_MESSAGE, "Bad message",
29             SSH2_FX_NO_CONNECTION, "No connection",
30             SSH2_FX_CONNECTION_LOST, "Connection lost",
31             SSH2_FX_OP_UNSUPPORTED, "Operation unsupported" );
32              
33             our $debug;
34              
35             sub _set_status {
36 0     0     my $sftp = shift;
37 0           my $code = shift;
38 0 0         if ($code) {
39 0           my $str;
40 0 0         if (@_) {
41 0           $str = join ': ', @_;
42 0 0 0       ($str) = $str =~ /(.*)/
43             if (${^TAINT} && tainted $str);
44             }
45 0 0 0       unless (defined $str and length $str) {
46 0   0       $str = $status_str{$code} || "Unknown status ($code)";
47             }
48 0 0 0       $debug and $debug & 64 and _debug("_set_status code: $code, str: $str");
49 0           return $sftp->{_status} = dualvar($code, $str);
50             }
51             else {
52 0           return $sftp->{_status} = 0;
53             }
54             }
55              
56 0     0 0   sub status { shift->{_status} }
57              
58             sub _set_error {
59 0     0     my $sftp = shift;
60 0           my $code = shift;
61 0 0         if ($code) {
    0          
62 0           my $str;
63 0 0         if (@_) {
64 0           $str = join ': ', @_;
65 0 0 0       ($str) = $str =~ /(.*)/
66             if (${^TAINT} && tainted $str);
67             }
68             else {
69 0 0         $str = $code ? "Unknown error $code" : "OK";
70             }
71 0 0 0       $debug and $debug & 64 and _debug("_set_err code: $code, str: $str");
72 0           my $error = $sftp->{_error} = dualvar $code, $str;
73              
74             # FIXME: use a better approach to determine when some error is fatal
75 0 0         croak $error if $sftp->{_autodie};
76             }
77             elsif ($sftp->{_error}) {
78             # FIXME: use a better approach to determine when some error is fatal
79 0 0         if ($sftp->{_error} != Net::SFTP::Foreign::Constants::SFTP_ERR_CONNECTION_BROKEN()) {
80 0           $sftp->{_error} = 0;
81             }
82             }
83             return $sftp->{_error}
84 0           }
85              
86             sub _clear_error_and_status {
87 0     0     my $sftp = shift;
88 0           $sftp->_set_error;
89 0           $sftp->_set_status;
90             }
91              
92             sub _copy_error {
93 0     0     my ($sftp, $other) = @_;
94 0 0 0       unless ($sftp->{_error} and
95             $sftp->{_error} == Net::SFTP::Foreign::Constants::SFTP_ERR_CONNECTION_BROKEN()) {
96 0           $sftp->{_error} = $other->{_error};
97             }
98             }
99              
100 0     0 0   sub error { shift->{_error} }
101              
102             sub die_on_error {
103 0     0 0   my $sftp = shift;
104 0 0         $sftp->{_error} and croak(@_ ? "@_: $sftp->{_error}" : $sftp->{_error});
    0          
105             }
106              
107             sub _ok_or_autodie {
108 0     0     my $sftp = shift;
109 0 0         return 1 unless $sftp->{_error};
110 0 0         $sftp->{_autodie} and croak $sftp->{_error};
111 0           undef;
112             }
113              
114             sub _set_errno {
115 0     0     my $sftp = shift;
116 0 0         if ($sftp->{_error}) {
117 0           my $status = $sftp->{_status} + 0;
118 0           my $error = $sftp->{_error} + 0;
119 0 0         if ($status == SSH2_FX_EOF) {
    0          
    0          
    0          
    0          
    0          
120 0           return;
121             }
122             elsif ($status == SSH2_FX_NO_SUCH_FILE) {
123 0           $! = Errno::ENOENT();
124             }
125             elsif ($status == SSH2_FX_PERMISSION_DENIED) {
126 0           $! = Errno::EACCES();
127             }
128             elsif ($status == SSH2_FX_BAD_MESSAGE) {
129 0           $! = Errno::EBADMSG();
130             }
131             elsif ($status == SSH2_FX_OP_UNSUPPORTED) {
132 0           $! = Errno::ENOTSUP()
133             }
134             elsif ($status) {
135 0           $! = Errno::EIO()
136             }
137             }
138             }
139              
140             sub _best_effort {
141 0     0     my $sftp = shift;
142 0           my $best_effort = shift;
143 0           my $method = shift;
144 0 0         local ($sftp->{_error}, $sftp->{_autodie}) if $best_effort;
145 0           $sftp->$method(@_);
146 0 0 0       return (($best_effort or not $sftp->{_error}) ? 1 : undef);
147             }
148              
149             sub _call_on_error {
150 0     0     my ($sftp, $on_error, $entry) = @_;
151 0 0 0       $on_error and $sftp->error
152             and $on_error->($sftp, $entry);
153 0           $sftp->_clear_error_and_status;
154             }
155              
156             # this method code is a little convoluted because we are trying to
157             # keep in memory as few entries as possible!!!
158             sub find {
159 0 0   0 0   @_ >= 1 or croak 'Usage: $sftp->find($remote_dirs, %opts)';
160              
161 0           my $self = shift;
162 0 0         my %opts = @_ & 1 ? ('dirs', @_) : @_;
163              
164 0           $self->_clear_error_and_status;
165              
166 0           my $dirs = delete $opts{dirs};
167 0           my $follow_links = delete $opts{follow_links};
168 0           my $on_error = delete $opts{on_error};
169 0 0         local $self->{_autodie} if $on_error;
170 0           my $realpath = delete $opts{realpath};
171 0           my $ordered = delete $opts{ordered};
172 0           my $names_only = delete $opts{names_only};
173 0           my $atomic_readdir = delete $opts{atomic_readdir};
174             my $wanted = _gen_wanted( delete $opts{wanted},
175 0           delete $opts{no_wanted} );
176             my $descend = _gen_wanted( delete $opts{descend},
177 0           delete $opts{no_descend} );
178              
179 0 0         %opts and croak "invalid option(s) '".CORE::join("', '", keys %opts)."'";
180              
181 0 0         $dirs = '.' unless defined $dirs;
182              
183 0           my $wantarray = wantarray;
184 0           my (@res, $res);
185 0           my %done;
186 0           my %rpdone; # used to detect cycles
187              
188 0           my @dirs = _ensure_list $dirs;
189 0 0         my @queue = map { { filename => $_ } } ($ordered ? sort @dirs : @dirs);
  0            
190              
191             # we use a clousure instead of an auxiliary method to have access
192             # to the state:
193              
194             my $task = sub {
195 0     0     my $entry = shift;
196 0           my $fn = $entry->{filename};
197 0           for (1) {
198 0   0       my $follow = ($follow_links and _is_lnk($entry->{a}->perm));
199              
200 0 0 0       if ($follow or $realpath) {
201 0 0         unless (defined $entry->{realpath}) {
202 0           my $rp = $entry->{realpath} = $self->realpath($fn);
203 0 0 0       next unless (defined $rp and not $rpdone{$rp}++);
204             }
205             }
206              
207 0 0         if ($follow) {
208 0           my $a = $self->stat($fn);
209 0 0         if (defined $a) {
210 0           $entry->{a} = $a;
211             # we queue it for reprocessing as it could be a directory
212 0           unshift @queue, $entry;
213             }
214 0           next;
215             }
216              
217 0 0 0       if (!$wanted or $wanted->($self, $entry)) {
218 0 0         if ($wantarray) {
219             push @res, ( $names_only
220             ? ( exists $entry->{realpath}
221             ? $entry->{realpath}
222             : $entry->{filename} )
223 0 0         : $entry )
    0          
224             }
225             else {
226 0           $res++;
227             }
228             }
229             }
230             continue {
231 0           $self->_call_on_error($on_error, $entry)
232             }
233 0           };
234              
235 0           my $try;
236 0           while (@queue) {
237 3     3   22 no warnings 'uninitialized';
  3         5  
  3         3751  
238 0           $try = shift @queue;
239 0           my $fn = $try->{filename};
240              
241 0 0 0       my $a = $try->{a} ||= $self->lstat($fn)
242             or next;
243              
244 0 0 0       next if (_is_dir($a->perm) and $done{$fn}++);
245              
246 0           $task->($try);
247              
248 0 0         if (_is_dir($a->perm)) {
249 0 0 0       if (!$descend or $descend->($self, $try)) {
250 0 0 0       if ($ordered or $atomic_readdir) {
251             my $ls = $self->ls( $fn,
252             ordered => $ordered,
253             _wanted => sub {
254 0     0     my $child = $_[1]->{filename};
255 0 0         if ($child !~ /^\.\.?$/) {
256 0           $_[1]->{filename} = $self->join($fn, $child);
257 0           return 1;
258             }
259 0           undef;
260             })
261 0 0         or next;
262 0           unshift @queue, @$ls;
263             }
264             else {
265             $self->ls( $fn,
266             _wanted => sub {
267 0     0     my $entry = $_[1];
268 0           my $child = $entry->{filename};
269 0 0         if ($child !~ /^\.\.?$/) {
270 0           $entry->{filename} = $self->join($fn, $child);
271              
272 0 0         if (_is_dir($entry->{a}->perm)) {
273 0           push @queue, $entry;
274             }
275             else {
276 0           $task->($entry);
277             }
278             }
279 0           undef } )
280 0 0         or next;
281             }
282             }
283             }
284             }
285             continue {
286 0           $self->_call_on_error($on_error, $try)
287             }
288              
289 0 0         return wantarray ? @res : $res;
290             }
291              
292              
293             sub glob {
294 0 0   0 0   @_ >= 2 or croak 'Usage: $sftp->glob($pattern, %opts)';
295 0 0         ${^TAINT} and &_catch_tainted_args;
296              
297 0           my ($sftp, $glob, %opts) = @_;
298 0 0         return () if $glob eq '';
299              
300 0           my $on_error = delete $opts{on_error};
301 0 0         local $sftp->{_autodie} if $on_error;
302 0           my $follow_links = delete $opts{follow_links};
303 0           my $ignore_case = delete $opts{ignore_case};
304 0           my $names_only = delete $opts{names_only};
305 0           my $realpath = delete $opts{realpath};
306 0           my $ordered = delete $opts{ordered};
307             my $wanted = _gen_wanted( delete $opts{wanted},
308 0           delete $opts{no_wanted});
309 0           my $strict_leading_dot = delete $opts{strict_leading_dot};
310 0 0         $strict_leading_dot = 1 unless defined $strict_leading_dot;
311              
312 0 0         %opts and _croak_bad_options(keys %opts);
313              
314 0           my $wantarray = wantarray;
315              
316 0           my (@parts, $top);
317 0 0         if (ref $glob eq 'Regexp') {
318 0           @parts = ($glob);
319 0           $top = '.';
320             }
321             else {
322 0           @parts = ($glob =~ m{\G/*([^/]+)}g);
323 0 0         push @parts, '.' unless @parts;
324 0 0         $top = ( $glob =~ m|^/| ? '/' : '.');
325             }
326 0           my @res = ( {filename => $top} );
327 0           my $res = 0;
328              
329 0   0       while (@parts and @res) {
330 0           my @parents = @res;
331 0           @res = ();
332 0           my $part = shift @parts;
333 0           my ($re, $has_wildcards);
334 0 0         if (ref $part eq 'Regexp') {
335 0           $re = $part;
336 0           $has_wildcards = 1;
337             }
338             else {
339 0           ($re, $has_wildcards) = _glob_to_regex($part, $strict_leading_dot, $ignore_case);
340             }
341              
342 0           for my $parent (@parents) {
343 0           my $pfn = $parent->{filename};
344 0 0         if ($has_wildcards) {
345             $sftp->ls( $pfn,
346             ordered => $ordered,
347             _wanted => sub {
348 0     0     my $e = $_[1];
349 0 0         if ($e->{filename} =~ $re) {
350 0           my $fn = $e->{filename} = $sftp->join($pfn, $e->{filename});
351 0 0 0       if ( (@parts or $follow_links)
      0        
352             and _is_lnk($e->{a}->perm) ) {
353 0 0         if (my $a = $sftp->stat($fn)) {
354 0           $e->{a} = $a;
355             }
356             else {
357 0 0         $on_error and $sftp->_call_on_error($on_error, $e);
358 0           return undef;
359             }
360             }
361 0 0 0       if (@parts) {
    0          
362             push @res, $e if _is_dir($e->{a}->perm)
363 0 0         }
364             elsif (!$wanted or $wanted->($sftp, $e)) {
365 0 0         if ($wantarray) {
366 0 0         if ($realpath) {
367 0           my $rp = $e->{realpath} = $sftp->realpath($e->{filename});
368 0 0         unless (defined $rp) {
369 0 0         $on_error and $sftp->_call_on_error($on_error, $e);
370 0           return undef;
371             }
372             }
373             push @res, ($names_only
374             ? ($realpath ? $e->{realpath} : $e->{filename} )
375 0 0         : $e);
    0          
376             }
377 0           $res++;
378             }
379             }
380             return undef
381 0           } )
382 0 0 0       or ($on_error and $sftp->_call_on_error($on_error, $parent));
383             }
384             else {
385 0           my $fn = $sftp->join($pfn, $part);
386 0 0 0       my $method = ((@parts or $follow_links) ? 'stat' : 'lstat');
387 0 0         if (my $a = $sftp->$method($fn)) {
388 0           my $e = { filename => $fn, a => $a };
389 0 0 0       if (@parts) {
    0          
390             push @res, $e if _is_dir($a->{perm})
391 0 0         }
392             elsif (!$wanted or $wanted->($sftp, $e)) {
393 0 0         if ($wantarray) {
394 0 0         if ($realpath) {
395 0           my $rp = $fn = $e->{realpath} = $sftp->realpath($fn);
396 0 0         unless (defined $rp) {
397 0 0         $on_error and $sftp->_call_on_error($on_error, $e);
398 0           next;
399             }
400             }
401 0 0         push @res, ($names_only ? $fn : $e)
402             }
403 0           $res++;
404             }
405             }
406             }
407             }
408             }
409 0 0         return wantarray ? @res : $res;
410             }
411              
412             sub test_d {
413 0     0 0   my ($sftp, $name) = @_;
414             {
415 0           local $sftp->{_autodie};
  0            
416 0           my $a = $sftp->stat($name);
417 0 0         return _is_dir($a->perm) if $a;
418             }
419 0 0         if ($sftp->{_status} == SSH2_FX_NO_SUCH_FILE) {
420 0           $sftp->_clear_error_and_status;
421 0           return undef;
422             }
423 0           $sftp->_ok_or_autodie;
424             }
425              
426             sub test_e {
427 0     0 0   my ($sftp, $name) = @_;
428             {
429 0           local $sftp->{_autodie};
  0            
430 0 0         $sftp->stat($name) and return 1;
431             }
432 0 0         if ($sftp->{_status} == SSH2_FX_NO_SUCH_FILE) {
433 0           $sftp->_clear_error_and_status;
434 0           return undef;
435             }
436 0           $sftp->_ok_or_autodie;
437             }
438              
439             1;
440