0 | 0 |
package Net::SFTP::Foreign;
|
1 | 1 |
|
2 | |
our $VERSION = '1.36';
|
|
2 |
our $VERSION = '1.38';
|
3 | 3 |
|
4 | 4 |
use strict;
|
5 | 5 |
use warnings;
|
|
16 | 16 |
my $windows;
|
17 | 17 |
|
18 | 18 |
BEGIN {
|
19 | |
$windows = $^O =~ /Win/;
|
|
19 |
$windows = $^O =~ /Win32/;
|
20 | 20 |
|
21 | 21 |
if ($^O =~ /solaris/i) {
|
22 | 22 |
$dirty_cleanup = 1 unless defined $dirty_cleanup;
|
23 | 23 |
}
|
24 | 24 |
}
|
25 | |
|
26 | |
sub _debug { print STDERR '# ', @_,"\n" }
|
27 | 25 |
|
28 | 26 |
sub _hexdump {
|
29 | 27 |
no warnings qw(uninitialized);
|
|
48 | 46 |
our @ISA = qw(Net::SFTP::Foreign::Common);
|
49 | 47 |
|
50 | 48 |
|
51 | |
use constant COPY_SIZE => 16384;
|
|
49 |
use constant DEFAULT_BLOCK_SIZE => 16384;
|
|
50 |
use constant DEFAULT_QUEUE_SIZE => ($windows ? 4 : 10);
|
52 | 51 |
|
53 | 52 |
sub _next_msg_id { shift->{_msg_id}++ }
|
54 | 53 |
|
|
98 | 97 |
|
99 | 98 |
sub _do_io_unix {
|
100 | 99 |
my ($sftp, $timeout) = @_;
|
|
100 |
|
|
101 |
$debug and $debug & 32 and _debug(sprintf "_do_io connected: %s", $sftp->{_connected} || 0);
|
101 | 102 |
|
102 | 103 |
return undef unless $sftp->{_connected};
|
103 | 104 |
|
|
128 | 129 |
my $rv1 = $rv;
|
129 | 130 |
my $wv1 = length($$bout) ? $wv : '';
|
130 | 131 |
|
|
132 |
$debug and $debug & 32 and _debug("_do_io select(-,-,-, $timeout)");
|
|
133 |
|
131 | 134 |
my $n = select($rv1, $wv1, undef, $timeout);
|
132 | 135 |
if ($n > 0) {
|
133 | 136 |
if (vec($wv1, $fnoout, 1)) {
|
134 | 137 |
my $written = syswrite($sftp->{ssh_out}, $$bout, 16384);
|
|
138 |
$debug and $debug & 32 and _debug (sprintf "_do_io write queue: %d, syswrite: %s, max: %d",
|
|
139 |
length $$bout,
|
|
140 |
(defined $written ? $written : 'undef'),
|
|
141 |
16384);
|
135 | 142 |
unless ($written) {
|
136 | 143 |
$sftp->_conn_lost;
|
137 | 144 |
return undef;
|
|
140 | 147 |
}
|
141 | 148 |
if (vec($rv1, $fnoin, 1)) {
|
142 | 149 |
my $read = sysread($sftp->{ssh_in}, $sftp->{_bin}, 16384, length($$bin));
|
|
150 |
$debug and $debug & 32 and _debug (sprintf "_do_io read sysread: %s, total read: %d",
|
|
151 |
(defined $read ? $read : 'undef'),
|
|
152 |
length $sftp->{_bin});
|
143 | 153 |
unless ($read) {
|
144 | 154 |
$sftp->_conn_lost;
|
145 | 155 |
return undef;
|
|
147 | 157 |
}
|
148 | 158 |
}
|
149 | 159 |
else {
|
|
160 |
$debug and $debug & 32 and _debug "_do_io select failed: $!";
|
150 | 161 |
next if ($n < 0 and $! == Errno::EINTR());
|
151 | 162 |
return undef;
|
152 | 163 |
}
|
|
187 | 198 |
sub _conn_lost {
|
188 | 199 |
my ($sftp, $status, $err, @str) = @_;
|
189 | 200 |
|
|
201 |
$debug and $debug & 32 and _debug("_conn_lost");
|
|
202 |
|
190 | 203 |
$sftp->{_status} or
|
191 | 204 |
$sftp->_set_status(defined $status ? $status : SSH2_FX_CONNECTION_LOST);
|
192 | 205 |
|
|
229 | 242 |
return $msg;
|
230 | 243 |
}
|
231 | 244 |
|
|
245 |
sub _ipc_open2_bug_workaround {
|
|
246 |
# in some cases, IPC::Open3::open2 returns from the child
|
|
247 |
my $pid = shift;
|
|
248 |
unless ($pid == $$) {
|
|
249 |
require POSIX;
|
|
250 |
POSIX::_exit(-1);
|
|
251 |
}
|
|
252 |
}
|
|
253 |
|
232 | 254 |
sub new {
|
233 | 255 |
${^TAINT} and &_catch_tainted_args;
|
234 | 256 |
|
|
238 | 260 |
|
239 | 261 |
my $sftp = { _msg_id => 0,
|
240 | 262 |
_queue_size => ($windows ? 4 : 10),
|
241 | |
_block_size => 16384,
|
242 | |
_read_ahead => 16384 * 4,
|
243 | 263 |
_bout => '',
|
244 | 264 |
_bin => '',
|
245 | 265 |
_connected => 1,
|
|
251 | 271 |
$sftp->_set_error;
|
252 | 272 |
|
253 | 273 |
my $transport = delete $opts{transport};
|
|
274 |
|
|
275 |
$sftp->{_block_size} = delete $opts{block_size} || DEFAULT_BLOCK_SIZE;
|
|
276 |
$sftp->{_read_ahead} = $sftp->{_block_size} * 4;
|
|
277 |
$sftp->{_queue_size} = delete $opts{queue_size} || DEFAULT_QUEUE_SIZE;
|
254 | 278 |
$sftp->{_timeout} = delete $opts{timeout};
|
255 | 279 |
$sftp->{_autoflush} = delete $opts{autoflush};
|
256 | 280 |
|
257 | |
my ($pass, $passphrase);
|
|
281 |
my ($pass, $passphrase, $expect_log_user);
|
258 | 282 |
|
259 | 283 |
my @open2_cmd;
|
260 | 284 |
unless (defined $transport) {
|
|
267 | 291 |
else {
|
268 | 292 |
$pass = delete $opts{password};
|
269 | 293 |
}
|
|
294 |
|
|
295 |
$expect_log_user = delete $opts{expect_log_user} || 0;
|
270 | 296 |
|
271 | 297 |
my $open2_cmd = delete $opts{open2_cmd};
|
272 | 298 |
if (defined $open2_cmd) {
|
|
277 | 303 |
defined $host or croak "sftp target host not defined";
|
278 | 304 |
|
279 | 305 |
my $ssh_cmd = delete $opts{ssh_cmd};
|
280 | |
@open2_cmd = defined $ssh_cmd ? $ssh_cmd : 'ssh';
|
|
306 |
$ssh_cmd = 'ssh' unless defined $ssh_cmd;
|
|
307 |
@open2_cmd = ($ssh_cmd);
|
|
308 |
|
|
309 |
my $ssh_cmd_interface = delete $opts{ssh_cmd_interface};
|
|
310 |
unless (defined $ssh_cmd_interface) {
|
|
311 |
$ssh_cmd_interface = ( $ssh_cmd =~ /\bplink(?:\.exe)?$/i
|
|
312 |
? 'plink'
|
|
313 |
: 'ssh');
|
|
314 |
}
|
281 | 315 |
|
282 | 316 |
my $port = delete $opts{port};
|
283 | |
push @open2_cmd, -p => $port if defined $port;
|
284 | |
|
285 | 317 |
my $user = delete $opts{user};
|
|
318 |
|
|
319 |
my $more = delete $opts{more};
|
|
320 |
carp "'more' argument looks like if it needs to be splited first"
|
|
321 |
if (defined $more and !ref($more) and $more =~ /^-\w\s+\S/);
|
|
322 |
|
|
323 |
if ($ssh_cmd_interface eq 'plink') {
|
|
324 |
$pass and !$passphrase
|
|
325 |
and croak "Password authentication via Expect is not supported for the plink client";
|
|
326 |
push @open2_cmd, -P => $port if defined $port;
|
|
327 |
}
|
|
328 |
elsif ($ssh_cmd_interface eq 'ssh') {
|
|
329 |
push @open2_cmd, -p => $port if defined $port;
|
|
330 |
}
|
|
331 |
else {
|
|
332 |
die "Unsupported ssh_cmd_interface '$ssh_cmd_interface'";
|
|
333 |
}
|
286 | 334 |
push @open2_cmd, -l => $user if defined $user;
|
287 | |
|
288 | |
my $more = delete $opts{more};
|
289 | |
if (defined $more) {
|
290 | |
if (!ref($more) and $more =~ /^-\w\s+\S/) {
|
291 | |
carp "'more' argument looks like it needs to be splited first"
|
292 | |
}
|
293 | |
push @open2_cmd, _ensure_list($more)
|
294 | |
}
|
295 | |
|
|
335 |
push @open2_cmd, _ensure_list($more) if defined $more;
|
296 | 336 |
push @open2_cmd, $host, -s => 'sftp';
|
297 | 337 |
}
|
298 | 338 |
}
|
|
314 | 354 |
_tcroak('Insecure $ENV{PATH}')
|
315 | 355 |
}
|
316 | 356 |
|
317 | |
my $pid = $$;
|
|
357 |
my $this_pid = $$;
|
318 | 358 |
local $@;
|
319 | 359 |
local $SIG{__DIE__};
|
320 | 360 |
|
|
323 | 363 |
# user has requested to use a password or a passphrase for authentication
|
324 | 364 |
# we use Expect to handle that
|
325 | 365 |
|
|
366 |
eval { require IO::Pty };
|
|
367 |
$@ and croak "password authentication is not available, IO::Pty and Expect are not installed";
|
326 | 368 |
eval { require Expect };
|
327 | 369 |
$@ and croak "password authentication is not available, Expect is not installed";
|
328 | 370 |
|
|
332 | 374 |
my $name = $passphrase ? 'Passphrase' : 'Password';
|
333 | 375 |
my $eto = $sftp->{_timeout} ? $sftp->{_timeout} * 4 : 120;
|
334 | 376 |
|
335 | |
my $conn = $sftp->{ssh_in} = $sftp->{ssh_out} = Expect->new;
|
336 | |
$sftp->{_ssh_out_is_not_dupped} = 1;
|
337 | |
|
338 | |
$conn->raw_pty(1);
|
339 | |
$conn->log_user(0);
|
340 | |
|
341 | |
my $ok = $conn->spawn(@open2_cmd);
|
342 | |
|
343 | |
if ($$ != $pid) {
|
344 | |
require POSIX;
|
345 | |
POSIX::_exit(-1);
|
|
377 |
my $pty = IO::Pty->new;
|
|
378 |
my $expect = Expect->init($pty);
|
|
379 |
$expect->raw_pty(1);
|
|
380 |
$expect->log_user($expect_log_user);
|
|
381 |
|
|
382 |
my $child = eval { open2($sftp->{ssh_in}, $sftp->{ssh_out}, '-') };
|
|
383 |
if (defined $child and !$child) {
|
|
384 |
$pty->make_slave_controlling_terminal;
|
|
385 |
exec @open2_cmd;
|
|
386 |
exit -1;
|
346 | 387 |
}
|
347 | |
|
348 | |
unless ($ok) {
|
349 | |
$sftp->_conn_failed("Spawning the SSH process failed", $conn->error);
|
|
388 |
_ipc_open2_bug_workaround $this_pid;
|
|
389 |
|
|
390 |
unless (defined $child) {
|
|
391 |
$sftp->_conn_failed("Bad ssh command", $!);
|
350 | 392 |
return $sftp;
|
351 | 393 |
}
|
352 | |
|
353 | |
$ok = $conn->expect($eto, ":");
|
354 | |
unless ($ok) {
|
355 | |
$sftp->_conn_failed("$name not requested as expected", $conn->error);
|
|
394 |
$sftp->{pid} = $child;
|
|
395 |
$sftp->{_expect} = $expect;
|
|
396 |
|
|
397 |
unless($expect->expect($eto, ":")) {
|
|
398 |
$sftp->_conn_failed("$name not requested as expected", $expect->error);
|
356 | 399 |
return $sftp;
|
357 | 400 |
}
|
358 | |
|
359 | |
$conn->send("$pass\n");
|
360 | |
$ok = $conn->expect($eto, "\n");
|
361 | |
unless ($ok) {
|
362 | |
$sftp->_conn_failed("$name interchange did not complete", $conn->error);
|
|
401 |
$expect->send("$pass\n");
|
|
402 |
|
|
403 |
unless ($expect->expect($eto, "\n")) {
|
|
404 |
$sftp->_conn_failed("$name interchange did not complete", $expect->error);
|
363 | 405 |
return $sftp;
|
364 | 406 |
}
|
365 | 407 |
}
|
366 | 408 |
else {
|
367 | |
warn "ssh cmd: @open2_cmd\n" if ($debug and $debug & 1);
|
|
409 |
_debug "ssh cmd: @open2_cmd\n" if ($debug and $debug & 1);
|
368 | 410 |
|
369 | 411 |
$sftp->{pid} = eval { open2($sftp->{ssh_in}, $sftp->{ssh_out}, @open2_cmd) };
|
370 | |
if ($pid != $$) { # that's to workaround a bug in IPC::Open3:
|
371 | |
require POSIX;
|
372 | |
POSIX::_exit(-1);
|
373 | |
}
|
|
412 |
_ipc_open2_bug_workaround $this_pid;
|
374 | 413 |
unless (defined $sftp->{pid}) {
|
375 | 414 |
$sftp->_conn_failed("Bad ssh command", $!);
|
376 | 415 |
return $sftp;
|
|
605 | 644 |
|
606 | 645 |
my ($sftp, $path, $flags, $a) = @_;
|
607 | 646 |
$path = $sftp->_rel2abs($path);
|
608 | |
$flags ||= 0;
|
609 | |
$a ||= Net::SFTP::Foreign::Attributes->new;
|
|
647 |
defined $flags or $flags = SSH2_FXF_READ;
|
|
648 |
defined $a or $a = Net::SFTP::Foreign::Attributes->new;
|
610 | 649 |
my $id = $sftp->_queue_new_msg(SSH2_FXP_OPEN, str => $path,
|
611 | 650 |
int32 => $flags, attr => $a);
|
612 | 651 |
|
|
664 | 703 |
|
665 | 704 |
unless ($size) {
|
666 | 705 |
return '' if defined $size;
|
667 | |
$size = COPY_SIZE;
|
|
706 |
$size = $sftp->{_block_size};
|
668 | 707 |
}
|
669 | 708 |
|
670 | 709 |
my $rfid = $sftp->_rfid($rfh);
|
|
806 | 845 |
my $len = length $$bout;
|
807 | 846 |
|
808 | 847 |
$sftp->flush($rfh, 'out')
|
809 | |
if ($len > COPY_SIZE or ($len and $sftp->{_autoflush} ));
|
|
848 |
if ($len > $sftp->{_block_size} or ($len and $sftp->{_autoflush} ));
|
810 | 849 |
|
811 | 850 |
return $datalen;
|
812 | 851 |
}
|
|
838 | 877 |
my $off = 0;
|
839 | 878 |
my $written = $sftp->_write($rfh, $start,
|
840 | 879 |
sub {
|
841 | |
my $data = substr($$bout, $off, COPY_SIZE);
|
|
880 |
my $data = substr($$bout, $off, $sftp->{_block_size});
|
842 | 881 |
$off += length $data;
|
843 | 882 |
$data;
|
844 | 883 |
} );
|
|
1329 | 1368 |
my $cb = delete $opts{callback};
|
1330 | 1369 |
my $umask = delete $opts{umask};
|
1331 | 1370 |
my $perm = delete $opts{perm};
|
1332 | |
my $copy_perms = delete $opts{copy_perms};
|
|
1371 |
my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
|
1333 | 1372 |
my $copy_time = delete $opts{copy_time};
|
1334 | 1373 |
my $overwrite = delete $opts{overwrite};
|
1335 | 1374 |
my $block_size = delete $opts{block_size} || $sftp->{_block_size};
|
|
1343 | 1382 |
croak "'perm' and 'umask' options can not be used simultaneously"
|
1344 | 1383 |
if (defined $perm and defined $umask);
|
1345 | 1384 |
|
1346 | |
croak "'perm' and 'copy_perms' options can not be used simultaneously"
|
1347 | |
if (defined $perm and defined $copy_perms);
|
|
1385 |
croak "'perm' and 'copy_perm' options can not be used simultaneously"
|
|
1386 |
if (defined $perm and defined $copy_perm);
|
1348 | 1387 |
|
1349 | 1388 |
my $numask;
|
1350 | 1389 |
|
|
1357 | 1396 |
}
|
1358 | 1397 |
|
1359 | 1398 |
$overwrite = 1 unless defined $overwrite;
|
1360 | |
$copy_perms = 1 unless (defined $perm or defined $copy_perms);
|
|
1399 |
$copy_perm = 1 unless (defined $perm or defined $copy_perm);
|
1361 | 1400 |
$copy_time = 1 unless defined $copy_time;
|
1362 | 1401 |
|
1363 | |
my $a = $sftp->stat($remote)
|
1364 | |
or return undef;
|
1365 | |
my $size = $a->size;
|
|
1402 |
my $size;
|
|
1403 |
my $a = $sftp->stat($remote);
|
|
1404 |
if (defined $a) {
|
|
1405 |
$size = $a->size
|
|
1406 |
}
|
|
1407 |
else {
|
|
1408 |
if ($copy_time or $copy_perm ) {
|
|
1409 |
return undef;
|
|
1410 |
}
|
|
1411 |
$sftp->_set_status;
|
|
1412 |
$sftp->_set_error;
|
|
1413 |
$size = -1;
|
|
1414 |
}
|
1366 | 1415 |
|
1367 | 1416 |
my $rfh = $sftp->open($remote, SSH2_FXF_READ);
|
1368 | 1417 |
defined $rfh or return undef;
|
|
1380 | 1429 |
return undef
|
1381 | 1430 |
}
|
1382 | 1431 |
|
1383 | |
if ($copy_perms) {
|
|
1432 |
if ($copy_perm) {
|
1384 | 1433 |
my $aperm = $a->perm;
|
1385 | 1434 |
$perm = 0666 unless defined $perm;
|
1386 | 1435 |
$a->perm =~ /^(\d+)$/ or die "perm is not numeric";
|
|
1429 | 1478 |
|
1430 | 1479 |
while (1) {
|
1431 | 1480 |
# request a new block if queue is not full
|
1432 | |
while (!@msgid or ($size > $askoff and @msgid < $queue_size and $n != 1)) {
|
|
1481 |
while (!@msgid or (($size == -1 or $size > $askoff) and @msgid < $queue_size and $n != 1)) {
|
1433 | 1482 |
|
1434 | 1483 |
my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
|
1435 | 1484 |
int64 => $askoff, int32 => $block_size);
|
|
1452 | 1501 |
unless ($msg) {
|
1453 | 1502 |
if ($sftp->{_status} == SSH2_FX_EOF) {
|
1454 | 1503 |
$sftp->_set_error();
|
1455 | |
next if $roff != $loff;
|
|
1504 |
$roff != $loff and next;
|
1456 | 1505 |
}
|
1457 | 1506 |
last;
|
1458 | 1507 |
}
|
|
1472 | 1521 |
}
|
1473 | 1522 |
|
1474 | 1523 |
if (defined $cb) {
|
1475 | |
$size = $loff if $loff > $size;
|
|
1524 |
# $size = $loff if ($loff > $size and $size != -1);
|
1476 | 1525 |
$cb->($sftp, $data, $roff, $size);
|
1477 | 1526 |
|
1478 | 1527 |
last if $sftp->error;
|
|
1549 | 1598 |
|
1550 | 1599 |
my $umask = delete $opts{umask};
|
1551 | 1600 |
my $perm = delete $opts{perm};
|
1552 | |
my $copy_perms = delete $opts{copy_perms};
|
|
1601 |
my $copy_perm = delete $opts{copy_perm} || delete $opts{copy_perms};
|
1553 | 1602 |
my $copy_time = delete $opts{copy_time};
|
1554 | 1603 |
my $overwrite = delete $opts{overwrite};
|
1555 | |
my $block_size = delete $opts{block_size} || COPY_SIZE;
|
1556 | |
my $queue_size = delete $opts{queue_size} || 10;
|
|
1604 |
my $block_size = delete $opts{block_size} || $sftp->{_block_size};
|
|
1605 |
my $queue_size = delete $opts{queue_size} || $sftp->{_queue_size};
|
1557 | 1606 |
|
1558 | 1607 |
%opts and croak "invalid option(s) '".CORE::join("', '", keys %opts)."'";
|
1559 | 1608 |
|
1560 | 1609 |
croak "'perm' and 'umask' options can not be used simultaneously"
|
1561 | 1610 |
if (defined $perm and defined $umask);
|
1562 | 1611 |
|
1563 | |
croak "'perm' and 'copy_perms' options can not be used simultaneously"
|
1564 | |
if (defined $perm and defined $copy_perms);
|
|
1612 |
croak "'perm' and 'copy_perm' options can not be used simultaneously"
|
|
1613 |
if (defined $perm and defined $copy_perm);
|
1565 | 1614 |
|
1566 | 1615 |
my $numask;
|
1567 | 1616 |
|
|
1573 | 1622 |
$numask = 0777 & ~$umask;
|
1574 | 1623 |
}
|
1575 | 1624 |
$overwrite = 1 unless defined $overwrite;
|
1576 | |
$copy_perms = 1 unless (defined $perm or defined $copy_perms);
|
|
1625 |
$copy_perm = 1 unless (defined $perm or defined $copy_perm);
|
1577 | 1626 |
$copy_time = 1 unless defined $copy_time;
|
1578 | 1627 |
|
1579 | 1628 |
my $fh;
|
|
1593 | 1642 |
return undef;
|
1594 | 1643 |
}
|
1595 | 1644 |
|
1596 | |
$perm = $lmode & $numask if defined $copy_perms;
|
|
1645 |
$perm = $lmode & $numask if $copy_perm;
|
1597 | 1646 |
|
1598 | 1647 |
my $attrs = Net::SFTP::Foreign::Attributes->new;
|
1599 | |
$attrs->set_perm($perm);
|
|
1648 |
$attrs->set_perm($perm) if defined $perm;
|
1600 | 1649 |
|
1601 | 1650 |
my $rfh = $sftp->open($remote,
|
1602 | 1651 |
SSH2_FXF_WRITE | SSH2_FXF_CREAT |
|
|
1605 | 1654 |
or return undef;
|
1606 | 1655 |
|
1607 | 1656 |
# open does not set the attributes for existant files so we do it again:
|
1608 | |
$sftp->fsetstat($rfh, $attrs)
|
1609 | |
or return undef;
|
|
1657 |
if (defined $perm) {
|
|
1658 |
$sftp->fsetstat($rfh, $attrs)
|
|
1659 |
or return undef;
|
|
1660 |
}
|
1610 | 1661 |
|
1611 | 1662 |
my $rfid = $sftp->_rfid($rfh);
|
1612 | 1663 |
defined $rfid or return undef;
|
|
1841 | 1892 |
my @parents = @res;
|
1842 | 1893 |
@res = ();
|
1843 | 1894 |
my $part = shift @parts;
|
1844 | |
my $re = _glob_to_regex($part, $strict_leading_dot, $ignore_case);
|
|
1895 |
my ($re, $has_wildcards) = _glob_to_regex($part, $strict_leading_dot, $ignore_case);
|
1845 | 1896 |
|
1846 | 1897 |
for my $parent (@parents) {
|
1847 | 1898 |
my $pfn = $parent->{filename};
|
1848 | |
$sftp->ls( $pfn,
|
1849 | |
ordered => $ordered,
|
1850 | |
_wanted => sub {
|
1851 | |
my $e = $_[1];
|
1852 | |
if ($e->{filename} =~ $re) {
|
1853 | |
my $fn = $e->{filename} = $sftp->join($pfn, $e->{filename});
|
1854 | |
if ( (@parts or $follow_links)
|
1855 | |
and S_ISLNK($e->{a}->perm) ) {
|
1856 | |
if (my $a = $sftp->stat($fn)) {
|
1857 | |
$e->{a} = $a;
|
1858 | |
}
|
1859 | |
else {
|
1860 | |
$sftp->_call_on_error($on_error, $e);
|
1861 | |
return undef;
|
1862 | |
}
|
1863 | |
}
|
1864 | |
if (@parts) {
|
1865 | |
push @res, $e if S_ISDIR($e->{a}->perm)
|
1866 | |
}
|
1867 | |
elsif (!$wanted or $wanted->($sftp, $e)) {
|
1868 | |
if ($wantarray) {
|
1869 | |
if ($realpath) {
|
1870 | |
$e->{realpath} = $sftp->realpath($e->{filename});
|
1871 | |
unless (defined $e->{realpath}) {
|
1872 | |
$sftp->_call_on_error($on_error, $e);
|
1873 | |
return undef;
|
|
1899 |
if ($has_wildcards) {
|
|
1900 |
$sftp->ls( $pfn,
|
|
1901 |
ordered => $ordered,
|
|
1902 |
_wanted => sub {
|
|
1903 |
my $e = $_[1];
|
|
1904 |
if ($e->{filename} =~ $re) {
|
|
1905 |
my $fn = $e->{filename} = $sftp->join($pfn, $e->{filename});
|
|
1906 |
if ( (@parts or $follow_links)
|
|
1907 |
and S_ISLNK($e->{a}->perm) ) {
|
|
1908 |
if (my $a = $sftp->stat($fn)) {
|
|
1909 |
$e->{a} = $a;
|
|
1910 |
}
|
|
1911 |
else {
|
|
1912 |
$sftp->_call_on_error($on_error, $e);
|
|
1913 |
return undef;
|
|
1914 |
}
|
|
1915 |
}
|
|
1916 |
if (@parts) {
|
|
1917 |
push @res, $e if S_ISDIR($e->{a}->perm)
|
|
1918 |
}
|
|
1919 |
elsif (!$wanted or $wanted->($sftp, $e)) {
|
|
1920 |
if ($wantarray) {
|
|
1921 |
if ($realpath) {
|
|
1922 |
my $rp = $e->{realpath} = $sftp->realpath($e->{filename});
|
|
1923 |
unless (defined $rp) {
|
|
1924 |
$sftp->_call_on_error($on_error, $e);
|
|
1925 |
return undef;
|
|
1926 |
}
|
1874 | 1927 |
}
|
|
1928 |
push @res, ($names_only
|
|
1929 |
? ($realpath ? $e->{realpath} : $e->{filename} )
|
|
1930 |
: $e);
|
1875 | 1931 |
}
|
1876 | |
push @res, ($names_only
|
1877 | |
? ($realpath ? $e->{realpath} : $e->{filename} )
|
1878 | |
: $e);
|
|
1932 |
$res++;
|
1879 | 1933 |
}
|
1880 | |
$res++;
|
1881 | |
}
|
1882 | |
}
|
1883 | |
return undef
|
1884 | |
} )
|
1885 | |
or $sftp->_call_on_error($on_error, $parent);
|
1886 | |
}
|
|
1934 |
}
|
|
1935 |
return undef
|
|
1936 |
} )
|
|
1937 |
or $sftp->_call_on_error($on_error, $parent);
|
|
1938 |
}
|
|
1939 |
else {
|
|
1940 |
my $fn = $sftp->join($pfn, $part);
|
|
1941 |
my $method = ((@parts or $follow_links) ? 'stat' : 'lstat');
|
|
1942 |
if (my $a = $sftp->$method($fn)) {
|
|
1943 |
my $e = { filename => $fn, a => $a };
|
|
1944 |
if (@parts) {
|
|
1945 |
push @res, $e if S_ISDIR($a->{perm})
|
|
1946 |
}
|
|
1947 |
elsif (!$wanted or $wanted->($sftp, $e)) {
|
|
1948 |
if ($wantarray) {
|
|
1949 |
if ($realpath) {
|
|
1950 |
my $rp = $fn = $e->{realpath} = $sftp->realpath($fn);
|
|
1951 |
unless (defined $rp) {
|
|
1952 |
$sftp->_call_on_error($on_error, $e);
|
|
1953 |
next;
|
|
1954 |
}
|
|
1955 |
}
|
|
1956 |
push @res, ($names_only ? $fn : $e)
|
|
1957 |
}
|
|
1958 |
$res++;
|
|
1959 |
}
|
|
1960 |
}
|
|
1961 |
}
|
|
1962 |
}
|
1887 | 1963 |
}
|
1888 | 1964 |
return wantarray ? @res : $res;
|
1889 | 1965 |
}
|
|
1949 | 2025 |
|
1950 | 2026 |
# my $cb = delete $opts{callback};
|
1951 | 2027 |
my $umask = delete $opts{umask};
|
1952 | |
my $copy_perms = delete $opts{copy_perms};
|
|
2028 |
my $copy_perm = delete $opts{copy_perm} || delete $opts{copy_perms};
|
1953 | 2029 |
my $copy_time = delete $opts{copy_time};
|
1954 | 2030 |
my $block_size = delete $opts{block_size};
|
1955 | 2031 |
my $queue_size = delete $opts{queue_size};
|
|
1971 | 2047 |
|
1972 | 2048 |
$umask = umask $umask if (defined $umask);
|
1973 | 2049 |
|
1974 | |
$copy_perms = 1 unless defined $copy_perms;
|
|
2050 |
$copy_perm = 1 unless defined $copy_perm;
|
1975 | 2051 |
$copy_time = 1 unless defined $copy_time;
|
1976 | 2052 |
|
1977 | 2053 |
require File::Spec;
|
|
1993 | 2069 |
return 1;
|
1994 | 2070 |
}
|
1995 | 2071 |
else {
|
1996 | |
if (CORE::mkdir $lpath, ($copy_perms ? $e->{a}->perm & 0777 : 0777)) {
|
|
2072 |
if (CORE::mkdir $lpath, ($copy_perm ? $e->{a}->perm & 0777 : 0777)) {
|
1997 | 2073 |
$count++;
|
1998 | 2074 |
return 1;
|
1999 | 2075 |
}
|
|
2045 | 2121 |
overwrite => $overwrite,
|
2046 | 2122 |
queue_size => $queue_size,
|
2047 | 2123 |
block_size => $block_size,
|
2048 | |
copy_perms => $copy_perms,
|
|
2124 |
copy_perm => $copy_perm,
|
2049 | 2125 |
copy_time => $copy_time)) {
|
2050 | 2126 |
$count++;
|
2051 | 2127 |
return undef;
|
|
2082 | 2158 |
|
2083 | 2159 |
# my $cb = delete $opts{callback};
|
2084 | 2160 |
my $umask = delete $opts{umask};
|
2085 | |
my $copy_perms = delete $opts{copy_perms};
|
|
2161 |
my $copy_perm = delete $opts{copy_perm} || delete $opts{copy_perms};
|
2086 | 2162 |
my $copy_time = delete $opts{copy_time};
|
2087 | 2163 |
my $block_size = delete $opts{block_size};
|
2088 | 2164 |
my $queue_size = delete $opts{queue_size};
|
|
2105 | 2181 |
my $qlocal = quotemeta $local;
|
2106 | 2182 |
my $relocal = qr/^$qlocal(.*)$/i;
|
2107 | 2183 |
|
2108 | |
$copy_perms = 1 unless defined $copy_perms;
|
|
2184 |
$copy_perm = 1 unless defined $copy_perm;
|
2109 | 2185 |
$copy_time = 1 unless defined $copy_time;
|
2110 | 2186 |
|
2111 | 2187 |
$umask = umask unless defined $umask;
|
|
2137 | 2213 |
}
|
2138 | 2214 |
else {
|
2139 | 2215 |
my $a = Net::SFTP::Foreign::Attributes->new;
|
2140 | |
$a->set_perm(($copy_perms ? $e->{a}->perm & 0777 : 0777) & $mask);
|
|
2216 |
$a->set_perm(($copy_perm ? $e->{a}->perm & 0777 : 0777) & $mask);
|
2141 | 2217 |
if ($sftp->mkdir($rpath, $a)) {
|
2142 | 2218 |
$count++;
|
2143 | 2219 |
return 1;
|
|
2185 | 2261 |
overwrite => $overwrite,
|
2186 | 2262 |
queue_size => $queue_size,
|
2187 | 2263 |
block_size => $block_size,
|
2188 | |
perm => ($copy_perms ? $e->{a}->perm : 0777) & $mask,
|
|
2264 |
perm => ($copy_perm ? $e->{a}->perm : 0777) & $mask,
|
2189 | 2265 |
copy_time => $copy_time)) {
|
2190 | 2266 |
$count++;
|
2191 | 2267 |
return undef;
|
|
2491 | 2567 |
|
2492 | 2568 |
=head1 NAME
|
2493 | 2569 |
|
2494 | |
Net::SFTP::Foreign - Secure File Transfer Protocol client
|
|
2570 |
Net::SFTP::Foreign - SSH File Transfer Protocol client
|
2495 | 2571 |
|
2496 | 2572 |
=head1 SYNOPSIS
|
2497 | 2573 |
|
|
2502 | 2578 |
|
2503 | 2579 |
=head1 DESCRIPTION
|
2504 | 2580 |
|
2505 | |
SFTP stands for Secure File Transfer Protocol and is a method of
|
|
2581 |
SFTP stands for SSH File Transfer Protocol and is a method of
|
2506 | 2582 |
transferring files between machines over a secure, encrypted
|
2507 | 2583 |
connection (as opposed to regular FTP, which functions over an
|
2508 | 2584 |
insecure connection). The security in SFTP comes through its
|
2509 | 2585 |
integration with SSH, which provides an encrypted transport layer over
|
2510 | 2586 |
which the SFTP commands are executed.
|
2511 | 2587 |
|
2512 | |
Net::SFTP::Foreign is a Perl client for the SFTP. It provides a subset
|
2513 | |
of the commands listed in the SSH File Transfer Protocol IETF draft,
|
2514 | |
which can be found at
|
|
2588 |
Net::SFTP::Foreign is a Perl client for the SFTP version 3. It
|
|
2589 |
provides a subset of the commands listed in the SSH File Transfer
|
|
2590 |
Protocol IETF draft, which can be found at
|
2515 | 2591 |
L<http://www.openssh.org/txt/draft-ietf-secsh-filexfer-02.txt> (also
|
2516 | |
included on this package distribution, on the C<rfc> directory).
|
|
2592 |
included on this package distribution, on the C<rfc> directory) plus
|
|
2593 |
some additional handy high level methods.
|
2517 | 2594 |
|
2518 | 2595 |
Net::SFTP::Foreign uses any compatible C<ssh> command installed on
|
2519 | |
your system (for instance, OpenSSH C<ssh>) to establish the secure
|
|
2596 |
the system (for instance, OpenSSH C<ssh>) to establish the secure
|
2520 | 2597 |
connection to the remote server.
|
2521 | 2598 |
|
2522 | 2599 |
Formerly, Net::SFTP::Foreign was a hacked version of Net::SFTP, but
|
|
2565 | 2642 |
success. C<$sftp-E<gt>error> can be used to explicitly check for
|
2566 | 2643 |
errors after every method call.
|
2567 | 2644 |
|
|
2645 |
Don't forget to read also the FAQ and BUGS sections at the end of this
|
|
2646 |
document!
|
|
2647 |
|
2568 | 2648 |
=over 4
|
2569 | 2649 |
|
2570 | 2650 |
=item Net::SFTP::Foreign->new($host, %args)
|
|
2573 | 2653 |
|
2574 | 2654 |
Opens a new SFTP connection with a remote host C<$host>, and returns a
|
2575 | 2655 |
Net::SFTP::Foreign object representing that open connection.
|
|
2656 |
|
|
2657 |
An explicit check for errors should be included always after the
|
|
2658 |
constructor call:
|
|
2659 |
|
|
2660 |
my $sftp = Net::SFTP::Foreign->new(...);
|
|
2661 |
$sftp->error and die "SSH connection failed: " . $sftp->error;
|
2576 | 2662 |
|
2577 | 2663 |
C<%args> can contain:
|
2578 | 2664 |
|
|
2601 | 2687 |
|
2602 | 2688 |
my $sftp = Net::SFTP::Foreign->new($host, more => '-v');
|
2603 | 2689 |
|
|
2690 |
Note that this option expects a single command argument or a reference
|
|
2691 |
to an array of arguments. For instance:
|
|
2692 |
|
|
2693 |
more => '-v' # RIGHT
|
|
2694 |
more => ['-v'] # RIGHT
|
|
2695 |
more => "-i $key" # WRONG!!!
|
|
2696 |
more => [-i => $key] # RIGHT
|
2604 | 2697 |
|
2605 | 2698 |
=item ssh_cmd =E<gt> $sshcmd
|
2606 | 2699 |
|
2607 | 2700 |
name of the external SSH client. By default C<ssh> is used.
|
|
2701 |
|
|
2702 |
For instance:
|
|
2703 |
|
|
2704 |
my $sftp = Net::SFTP::Foreign->new($host, ssh_cmd => 'plink');
|
|
2705 |
|
|
2706 |
=item ssh_cmd_interface =E<gt> 'plink' or 'ssh'
|
|
2707 |
|
|
2708 |
declares the command line interface that the SSH client used to
|
|
2709 |
connect to the remote host understands. Currently C<plink> and C<ssh>
|
|
2710 |
are supported.
|
|
2711 |
|
|
2712 |
This option would be rarely required as the module infers the
|
|
2713 |
interface from the SSH command name.
|
2608 | 2714 |
|
2609 | 2715 |
=item open2_cmd =E<gt> [@cmd]
|
2610 | 2716 |
|
|
2635 | 2741 |
|
2636 | 2742 |
=item transport =E<gt> [$in_fh, $out_fh, $pid]
|
2637 | 2743 |
|
2638 | |
This option allows to use an already open pipe or socket as the
|
2639 | |
transport for the SFTP protocol.
|
|
2744 |
allows to use an already open pipe or socket as the transport for the
|
|
2745 |
SFTP protocol.
|
2640 | 2746 |
|
2641 | 2747 |
It can be (ab)used to make this module work with password
|
2642 | 2748 |
authentication or with keys requiring a passphrase.
|
|
2646 | 2752 |
C<$pid> argument can be used to instruct this module to kill that
|
2647 | 2753 |
process if it doesn't exit by itself.
|
2648 | 2754 |
|
2649 | |
=item password => $password
|
2650 | |
|
2651 | |
=item passphrase => $passphrase
|
2652 | |
|
2653 | |
Use L<Expect> to handle password authentication or keys requiring a
|
|
2755 |
=item password =E<gt> $password
|
|
2756 |
|
|
2757 |
=item passphrase =E<gt> $passphrase
|
|
2758 |
|
|
2759 |
uses L<Expect> to handle password authentication or keys requiring a
|
2654 | 2760 |
passphrase. This is an experimental feature!
|
2655 | 2761 |
|
|
2762 |
=item expect_log_user =E<gt> $bool
|
|
2763 |
|
|
2764 |
activates password/passphrase authentication interaction loging (see
|
|
2765 |
C<Expect::log_user> method documentation).
|
|
2766 |
|
|
2767 |
=item block_size =E<gt> $default_block_size
|
|
2768 |
|
|
2769 |
=item queue_size =E<gt> $default_queue_size
|
|
2770 |
|
|
2771 |
default C<block_size> and C<queue_size> used for read and write
|
|
2772 |
operations (see the C<put> or C<get> documentation).
|
|
2773 |
|
2656 | 2774 |
=back
|
2657 | |
|
2658 | |
An explicit check for errors should be included always after the
|
2659 | |
constructor call:
|
2660 | |
|
2661 | |
my $sftp = Net::SFTP::Foreign->new(...);
|
2662 | |
$sftp->error and die "SSH connection failed: " . $sftp->error;
|
2663 | 2775 |
|
2664 | 2776 |
=item $sftp-E<gt>error
|
2665 | 2777 |
|
|
2707 | 2819 |
determines if access and modification time attributes have to be
|
2708 | 2820 |
copied from remote file. Default is to copy them.
|
2709 | 2821 |
|
2710 | |
=item copy_perms =E<gt> $bool
|
|
2822 |
=item copy_perm =E<gt> $bool
|
2711 | 2823 |
|
2712 | 2824 |
determines if permision attributes have to be copied from remote
|
2713 | 2825 |
file. Default is to copy them after applying the local process umask.
|
|
2726 | 2838 |
|
2727 | 2839 |
size of the blocks the file is being splittered on for
|
2728 | 2840 |
transfer. Incrementing this value can improve performance but some
|
2729 | |
servers limit its size.
|
|
2841 |
servers limit the maximum size.
|
|
2842 |
|
|
2843 |
=item queue_size =E<gt> $size
|
|
2844 |
|
|
2845 |
read and write requests are pipelined in order to maximize transfer
|
|
2846 |
throughput. This option allows to set the maximum number of requests
|
|
2847 |
that can be concurrently waiting for a server response.
|
2730 | 2848 |
|
2731 | 2849 |
=item callback =E<gt> $callback
|
2732 | 2850 |
|
|
2745 | 2863 |
my($sftp, $data, $offset, $size) = @_;
|
2746 | 2864 |
print "Read $offset / $size bytes\r";
|
2747 | 2865 |
}
|
2748 | |
|
2749 | |
=back
|
2750 | 2866 |
|
2751 | 2867 |
The C<abort> method can be called from inside the callback to abort
|
2752 | 2868 |
the transfer:
|
|
2759 | 2875 |
}
|
2760 | 2876 |
|
2761 | 2877 |
|
|
2878 |
=back
|
|
2879 |
|
2762 | 2880 |
=item $sftp-E<gt>get_content($remote)
|
2763 | 2881 |
|
2764 | 2882 |
Returns the content of the remote file.
|
|
2777 | 2895 |
determines if access and modification time attributes have to be
|
2778 | 2896 |
copied from remote file. Default is to copy them.
|
2779 | 2897 |
|
2780 | |
=item copy_perms =E<gt> $bool
|
|
2898 |
=item copy_perm =E<gt> $bool
|
2781 | 2899 |
|
2782 | 2900 |
determines if permision attributes have to be copied from remote
|
2783 | 2901 |
file. Default is to copy them after applying the local process umask.
|
|
2798 | 2916 |
transfer. Incrementing this value can improve performance but some
|
2799 | 2917 |
servers limit its size and if this limit is overpassed the command
|
2800 | 2918 |
will fail.
|
|
2919 |
|
|
2920 |
=item queue_size =E<gt> $size
|
|
2921 |
|
|
2922 |
read and write requests are pipelined in order to maximize transfer
|
|
2923 |
throughput. This option allows to set the maximum number of requests
|
|
2924 |
that can be concurrently waiting for a server response.
|
2801 | 2925 |
|
2802 | 2926 |
=item callback =E<gt> $callback
|
2803 | 2927 |
|
|
3100 | 3224 |
use umask C<$umask> to set permissions on the files and directories
|
3101 | 3225 |
created.
|
3102 | 3226 |
|
3103 | |
=item copy_perms =E<gt> $bool;
|
|
3227 |
=item copy_perm =E<gt> $bool;
|
3104 | 3228 |
|
3105 | 3229 |
if set to a true value, file and directory permissions are copied to
|
3106 | 3230 |
the remote server (after applying the umask). On by default.
|
|
3164 | 3288 |
use umask C<$umask> to set permissions on the files and directories
|
3165 | 3289 |
created.
|
3166 | 3290 |
|
3167 | |
=item copy_perms =E<gt> $bool;
|
|
3291 |
=item copy_perm =E<gt> $bool;
|
3168 | 3292 |
|
3169 | 3293 |
if set to a true value, file and directory permissions are copied
|
3170 | 3294 |
to the remote server (after applying the umask). On by default.
|
|
3559 | 3683 |
my $sftp = Net::SFTP::Foreign->new($host,
|
3560 | 3684 |
more => [qw(-i /home/foo/.ssh/id_dsa)]);
|
3561 | 3685 |
|
|
3686 |
=item Plink and password authentication
|
|
3687 |
|
|
3688 |
B<Q>: Why password authentication is not supported for the plink SSH
|
|
3689 |
client?
|
|
3690 |
|
|
3691 |
B<A>: A bug in plink breaks it.
|
|
3692 |
|
|
3693 |
As a work around, you can use plink C<-pw> argument to pass the
|
|
3694 |
password on the command line, but it is B<highly insecure>, anyone
|
|
3695 |
with a shell account on the machine would be able to get the password.
|
|
3696 |
Use at your own risk!:
|
|
3697 |
|
|
3698 |
# HIGHLY INSECURE!!!
|
|
3699 |
my $sftp = Net::SFTP::Foreign->new('foo@bar',
|
|
3700 |
ssh_cmd => 'plink',
|
|
3701 |
more => [-pw => $password]);
|
|
3702 |
$sftp->error and die $sftp->error;
|
|
3703 |
|
|
3704 |
=item Plink
|
|
3705 |
|
|
3706 |
B<Q>: What is C<plink>?
|
|
3707 |
|
|
3708 |
B<A>: Plink is a command line tool distributed with the
|
|
3709 |
L<PuTTY|http://the.earth.li/~sgtatham/putty/> SSH client. Very popular
|
|
3710 |
between MS Windows users, it is also available for Linux and other
|
|
3711 |
Unixes now.
|
|
3712 |
|
3562 | 3713 |
=back
|
3563 | 3714 |
|
|
3715 |
|
|
3716 |
|
3564 | 3717 |
=head1 BUGS
|
3565 | 3718 |
|
3566 | |
Doesn't work on VMS. The problem is related to L<IPC::Open2> not
|
3567 | |
working on VMS. Patches are welcome!
|
|
3719 |
These are the currently known bugs:
|
|
3720 |
|
|
3721 |
=over 4
|
|
3722 |
|
|
3723 |
=item - Doesn't work on VMS:
|
|
3724 |
|
|
3725 |
The problem is related to L<IPC::Open2> not working on VMS. Patches
|
|
3726 |
are welcome!
|
|
3727 |
|
|
3728 |
=item - Dirty cleanup:
|
3568 | 3729 |
|
3569 | 3730 |
On some operative systems, closing the pipes used to comunicate with
|
3570 | |
the slave ssh process does not terminate it and a work around has to
|
|
3731 |
the slave SSH process does not terminate it and a work around has to
|
3571 | 3732 |
be applied. If you find that your scripts hung when the $sftp object
|
3572 | 3733 |
gets out of scope, try setting C<$Net::SFTP::Foreign::dirty_cleanup>
|
3573 | 3734 |
to a true value and also send me a report including the value of
|
3574 | 3735 |
C<$^O> on your machine and the OpenSSH version.
|
3575 | 3736 |
|
3576 | 3737 |
From version 0.90_18 upwards, a dirty cleanup is performed anyway when
|
3577 | |
the ssh process does not terminate by itself in 8 seconds or less.
|
3578 | |
|
3579 | |
Support for Windows OSs is still experimental!
|
|
3738 |
the SSH process does not terminate by itself in 8 seconds or less.
|
|
3739 |
|
|
3740 |
=back
|
|
3741 |
|
|
3742 |
Support for MS Windows OSs is still experimental!
|
3580 | 3743 |
|
3581 | 3744 |
Support for taint mode is experimental!
|
3582 | 3745 |
|
3583 | 3746 |
Support for setcwd/cwd is experimental!
|
3584 | 3747 |
|
3585 | |
Support for password/passphrase handling via Expect is also experimental!
|
|
3748 |
Support for password/passphrase handling via Expect is also
|
|
3749 |
experimental. On Windows it only works under the cygwin version of
|
|
3750 |
Perl.
|
|
3751 |
|
|
3752 |
|
3586 | 3753 |
|
3587 | 3754 |
To report bugs, please, send me and email or use
|
3588 | 3755 |
L<http://rt.cpan.org>.
|