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