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