0 | 0 |
package Net::SFTP::Foreign;
|
1 | 1 |
|
2 | |
our $VERSION = '1.67';
|
|
2 |
our $VERSION = '1.69';
|
3 | 3 |
|
4 | 4 |
use strict;
|
5 | 5 |
use warnings;
|
|
9 | 9 |
|
10 | 10 |
use Symbol ();
|
11 | 11 |
use Errno ();
|
12 | |
use Scalar::Util;
|
|
12 |
use Fcntl;
|
13 | 13 |
|
14 | 14 |
BEGIN {
|
15 | 15 |
if ($] >= 5.008) {
|
|
31 | 31 |
our $debug;
|
32 | 32 |
BEGIN { *Net::SFTP::Foreign::Helpers::debug = \$debug };
|
33 | 33 |
use Net::SFTP::Foreign::Helpers qw(_is_reg _is_lnk _is_dir _debug
|
34 | |
_sort_entries _gen_wanted _gen_converter
|
35 | |
_hexdump _ensure_list _catch_tainted_args);
|
|
34 |
_sort_entries _gen_wanted
|
|
35 |
_gen_converter _hexdump
|
|
36 |
_ensure_list _catch_tainted_args
|
|
37 |
_file_part);
|
36 | 38 |
use Net::SFTP::Foreign::Constants qw( :fxp :flags :att
|
37 | 39 |
:status :error
|
38 | 40 |
SSH2_FILEXFER_VERSION );
|
|
45 | 47 |
my $windows;
|
46 | 48 |
|
47 | 49 |
BEGIN {
|
48 | |
$windows = $^O =~ /Win32/;
|
|
50 |
$windows = $^O =~ /Win(?:32|64)/;
|
49 | 51 |
|
50 | 52 |
if ($^O =~ /solaris/i) {
|
51 | 53 |
$dirty_cleanup = 1 unless defined $dirty_cleanup;
|
|
1243 | 1245 |
my ($sftp, $old, $new, %opts) = @_;
|
1244 | 1246 |
|
1245 | 1247 |
my $overwrite = delete $opts{overwrite};
|
|
1248 |
my $numbered = delete $opts{numbered};
|
|
1249 |
croak "'overwrite' and 'numbered' options can not be used together"
|
|
1250 |
if ($overwrite and $numbered);
|
1246 | 1251 |
%opts and _croak_bad_options(keys %opts);
|
1247 | 1252 |
|
1248 | 1253 |
if ($overwrite) {
|
|
1250 | 1255 |
$sftp->status != SSH2_FX_OP_UNSUPPORTED and return undef;
|
1251 | 1256 |
}
|
1252 | 1257 |
|
1253 | |
# we are optimistic here and try to rename it without testing if a
|
1254 | |
# file of the same name already exists first
|
1255 | |
$sftp->_rename($old, $new) and return 1;
|
1256 | |
|
1257 | |
if ($overwrite and $sftp->status == SSH2_FX_FAILURE) {
|
1258 | |
if ($sftp->realpath($old) eq $sftp->realpath($new)) {
|
1259 | |
$sftp->_set_status(SSH2_FX_FAILURE);
|
1260 | |
$sftp->_set_error(SFTP_ERR_REMOTE_RENAME_FAILED,
|
1261 | |
"Couldn't rename, both '$old' and '$new' point to the same file");
|
1262 | |
return undef;
|
|
1258 |
for (1) {
|
|
1259 |
local $sftp->{_autodie};
|
|
1260 |
# we are optimistic here and try to rename it without testing
|
|
1261 |
# if a file of the same name already exists first
|
|
1262 |
if (!$sftp->_rename($old, $new) and
|
|
1263 |
$sftp->status == SSH2_FX_FAILURE) {
|
|
1264 |
if ($numbered and $sftp->test_e($new)) {
|
|
1265 |
_inc_numbered($new);
|
|
1266 |
redo;
|
|
1267 |
}
|
|
1268 |
elsif ($overwrite) {
|
|
1269 |
my $rp_old = $sftp->realpath($old);
|
|
1270 |
my $rp_new = $sftp->realpath($new);
|
|
1271 |
if (defined $rp_old and defined $rp_new and $rp_old eq $rp_new) {
|
|
1272 |
$sftp->_clear_error;
|
|
1273 |
}
|
|
1274 |
elsif ($sftp->remove($new)) {
|
|
1275 |
$overwrite = 0;
|
|
1276 |
redo;
|
|
1277 |
}
|
|
1278 |
}
|
1263 | 1279 |
}
|
1264 | |
|
1265 | |
$sftp->remove($new);
|
1266 | |
return $sftp->_rename($old, $new);
|
1267 | |
}
|
1268 | |
return undef;
|
|
1280 |
}
|
|
1281 |
$sftp->_ok_or_autodie;
|
1269 | 1282 |
}
|
1270 | 1283 |
|
1271 | 1284 |
sub atomic_rename {
|
|
1332 | 1345 |
my $method = shift;
|
1333 | 1346 |
sub {
|
1334 | 1347 |
my $sftp = shift;
|
1335 | |
my $oerror = $sftp->{_error};
|
1336 | |
my $ostatus = $sftp->{_status};
|
1337 | |
my $ret = $sftp->$method(@_);
|
1338 | |
if ($oerror) {
|
1339 | |
$sftp->{_error} = $oerror;
|
1340 | |
$sftp->{_status} = $ostatus;
|
1341 | |
}
|
1342 | |
$ret;
|
|
1348 |
local ($sftp->{_error}, $sftp->{_status}) if $sftp->{_error};
|
|
1349 |
$sftp->$method(@_);
|
1343 | 1350 |
}
|
1344 | 1351 |
}
|
1345 | 1352 |
|
1346 | 1353 |
*_close_save_status = _gen_save_status_method('close');
|
1347 | 1354 |
*_closedir_save_status = _gen_save_status_method('closedir');
|
1348 | |
|
|
1355 |
*_remove_save_status = _gen_save_status_method('remove');
|
|
1356 |
|
|
1357 |
sub _inc_numbered {
|
|
1358 |
$_[0] =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e or
|
|
1359 |
$_[0] =~ s{((?:\.[^\.]*)?)$}{(1)$1};
|
|
1360 |
$debug and $debug & 128 and _debug("numbering to: $_[0]");
|
|
1361 |
}
|
1349 | 1362 |
|
1350 | 1363 |
## High-level client -> server methods.
|
1351 | 1364 |
|
|
1356 | 1369 |
|
1357 | 1370 |
# returns true on success, undef on failure
|
1358 | 1371 |
sub get {
|
1359 | |
@_ >= 3 or croak 'Usage: $sftp->get($remote, $local, %opts)';
|
|
1372 |
@_ >= 2 or croak 'Usage: $sftp->get($remote, $local, %opts)';
|
1360 | 1373 |
${^TAINT} and &_catch_tainted_args;
|
1361 | 1374 |
|
1362 | 1375 |
my ($sftp, $remote, $local, %opts) = @_;
|
|
1376 |
defined $remote or croak "remote file path is undefined";
|
|
1377 |
|
|
1378 |
$sftp->_clear_error_and_status;
|
|
1379 |
|
1363 | 1380 |
$remote = $sftp->_rel2abs($remote);
|
|
1381 |
$local = _file_part($remote) unless defined $local;
|
1364 | 1382 |
my $local_is_fh = (ref $local and $local->isa('GLOB'));
|
1365 | |
|
1366 | |
$sftp->_clear_error_and_status;
|
1367 | 1383 |
|
1368 | 1384 |
my $cb = delete $opts{callback};
|
1369 | 1385 |
my $umask = delete $opts{umask};
|
|
1378 | 1394 |
my $dont_save = delete $opts{dont_save};
|
1379 | 1395 |
my $conversion = delete $opts{conversion};
|
1380 | 1396 |
my $numbered = delete $opts{numbered};
|
|
1397 |
my $cleanup = delete $opts{cleanup};
|
|
1398 |
my $atomic = delete $opts{atomic};
|
1381 | 1399 |
|
1382 | 1400 |
croak "'perm' and 'umask' options can not be used simultaneously"
|
1383 | 1401 |
if (defined $perm and defined $umask);
|
|
1387 | 1405 |
if ($resume and $append);
|
1388 | 1406 |
croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'"
|
1389 | 1407 |
if ($numbered and ($overwrite or $resume or $append));
|
1390 | |
|
|
1408 |
croak "'atomic' can not be used with 'resume' or 'append'"
|
|
1409 |
if ($atomic and ($resume or $append));
|
1391 | 1410 |
if ($local_is_fh) {
|
1392 | 1411 |
my $append = 'option can not be used when target is a file handle';
|
1393 | 1412 |
$resume and croak "'resume' $append";
|
1394 | 1413 |
$overwrite and croak "'overwrite' $append";
|
1395 | 1414 |
$numbered and croak "'numbered' $append";
|
1396 | 1415 |
$dont_save and croak "'dont_save' $append";
|
|
1416 |
$atomic and croak "'croak' $append";
|
1397 | 1417 |
}
|
1398 | 1418 |
%opts and _croak_bad_options(keys %opts);
|
1399 | 1419 |
|
|
1416 | 1436 |
$overwrite = 1 unless (defined $overwrite or $local_is_fh or $numbered);
|
1417 | 1437 |
$copy_perm = 1 unless (defined $perm or defined $copy_perm or $local_is_fh);
|
1418 | 1438 |
$copy_time = 1 unless (defined $copy_time or $local_is_fh);
|
1419 | |
|
1420 | |
my $size;
|
1421 | |
my $a = $sftp->stat($remote);
|
1422 | |
if (defined $a) {
|
1423 | |
$size = $a->size
|
1424 | |
}
|
1425 | |
else {
|
1426 | |
return undef if ($copy_time or $copy_perm);
|
1427 | |
$size = -1;
|
1428 | |
}
|
|
1439 |
$cleanup = ($atomic || $numbered) unless defined $cleanup;
|
|
1440 |
|
|
1441 |
my $a = do {
|
|
1442 |
local $sftp->{_autodie};
|
|
1443 |
$sftp->stat($remote);
|
|
1444 |
};
|
|
1445 |
my ($rperm, $size, $atime, $mtime) = ($a ? ($a->perm, $a->size, $a->atime, $a->mtime) : ());
|
|
1446 |
$size = -1 unless defined $size;
|
|
1447 |
|
|
1448 |
if ($copy_time and not defined $atime) {
|
|
1449 |
$sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED,
|
|
1450 |
"Not enough information on stat, amtime not included");
|
|
1451 |
return undef;
|
|
1452 |
}
|
|
1453 |
|
|
1454 |
if ($copy_perm) {
|
|
1455 |
if (defined $rperm) {
|
|
1456 |
$perm = $rperm;
|
|
1457 |
}
|
|
1458 |
else {
|
|
1459 |
$sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED,
|
|
1460 |
"Not enough information on stat, mode not included");
|
|
1461 |
return undef
|
|
1462 |
}
|
|
1463 |
}
|
|
1464 |
$sftp->_clear_error_and_status;
|
1429 | 1465 |
|
1430 | 1466 |
if ($resume and $resume eq 'auto') {
|
1431 | 1467 |
undef $resume;
|
1432 | |
if (my @lstat = CORE::stat $local) {
|
1433 | |
if (defined $a and $a->mtime <= $lstat[9]) {
|
1434 | |
$resume = 1;
|
|
1468 |
if (defined $mtime) {
|
|
1469 |
if (my @lstat = CORE::stat $local) {
|
|
1470 |
$resume = ($mtime <= $lstat[9]);
|
1435 | 1471 |
}
|
1436 | 1472 |
}
|
1437 | 1473 |
}
|
|
1474 |
|
|
1475 |
my ($atomic_numbered, $atomic_local, $atomic_cleanup);
|
1438 | 1476 |
|
1439 | 1477 |
my ($rfh, $fh);
|
1440 | 1478 |
my $askoff = 0;
|
|
1445 | 1483 |
defined $rfh or return undef;
|
1446 | 1484 |
}
|
1447 | 1485 |
else {
|
1448 | |
unless ($local_is_fh or $overwrite or $append or $resume) {
|
1449 | |
while (-e $local) {
|
1450 | |
if ($numbered) {
|
1451 | |
my $old = $local;
|
1452 | |
$local =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e
|
1453 | |
or $local =~ s{((?:\.[^\.]*)?)$}{(1)$1};
|
1454 | |
$debug and $debug & 128 and _debug("numbering: $old => $local");
|
1455 | |
}
|
1456 | |
else {
|
1457 | |
$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
|
1458 | |
"local file $local already exists");
|
1459 | |
return undef
|
1460 | |
}
|
|
1486 |
unless ($local_is_fh or $overwrite or $append or $resume or $numbered) {
|
|
1487 |
if (-e $local) {
|
|
1488 |
$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
|
|
1489 |
"local file $local already exists");
|
|
1490 |
return undef
|
1461 | 1491 |
}
|
1462 | 1492 |
}
|
1463 | 1493 |
|
1464 | |
if ($copy_perm) {
|
1465 | |
my $aperm = $a->perm;
|
1466 | |
$aperm = 0666 unless defined $aperm;
|
1467 | |
$aperm =~ /^(\d+)$/ or die "perm is not numeric";
|
1468 | |
$perm = int $1;
|
|
1494 |
if ($atomic) {
|
|
1495 |
$atomic_local = $local;
|
|
1496 |
$local .= sprintf("(%d).tmp", rand(10000));
|
|
1497 |
$atomic_numbered = $numbered;
|
|
1498 |
$numbered = 1;
|
|
1499 |
$debug and $debug & 128 and _debug("temporal local file name: $local");
|
1469 | 1500 |
}
|
1470 | 1501 |
|
1471 | |
$perm = (0666 & $neg_umask)
|
1472 | |
unless (defined $perm or $local_is_fh);
|
|
1502 |
$perm = (0666 & $neg_umask) unless defined $perm or $local_is_fh;
|
1473 | 1503 |
|
1474 | 1504 |
if ($resume) {
|
1475 | |
if (CORE::open $fh, '>', $local) {
|
|
1505 |
if (CORE::open $fh, '+<', $local) {
|
1476 | 1506 |
binmode $fh;
|
1477 | 1507 |
CORE::seek($fh, 0, 2);
|
1478 | 1508 |
$askoff = CORE::tell $fh;
|
|
1506 | 1536 |
$lstart = 0 unless ($lstart and $lstart > 0);
|
1507 | 1537 |
}
|
1508 | 1538 |
else {
|
1509 | |
my $lumask = ~$perm & 0666;
|
1510 | |
umask $lumask;
|
1511 | |
unlink $local unless $append;
|
1512 | |
unless (CORE::open $fh, ($append ? '>>' : '>'), $local) {
|
1513 | |
umask $oldumask;
|
1514 | |
$sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
|
1515 | |
"Can't open $local", $!);
|
1516 | |
return undef;
|
1517 | |
}
|
1518 | |
umask $oldumask;
|
|
1539 |
my $flags = Fcntl::O_CREAT|Fcntl::O_WRONLY;
|
|
1540 |
$flags |= Fcntl::O_APPEND if $append;
|
|
1541 |
$flags |= Fcntl::O_EXCL if ($numbered or (!$overwrite and !$append));
|
|
1542 |
|
|
1543 |
my $lumask = ~$perm & 0777;
|
|
1544 |
|
|
1545 |
unlink $local if ($overwrite and !$numbered);
|
|
1546 |
|
|
1547 |
while (1) {
|
|
1548 |
umask $lumask;
|
|
1549 |
sysopen ($fh, $local, $flags, $perm) and last;
|
|
1550 |
my $err = $!;
|
|
1551 |
umask $oldumask;
|
|
1552 |
unless ($numbered and -e $local) {
|
|
1553 |
$sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
|
|
1554 |
"Can't open $local", $err);
|
|
1555 |
return undef;
|
|
1556 |
}
|
|
1557 |
_inc_numbered($local);
|
|
1558 |
}
|
|
1559 |
umask $oldumask;
|
|
1560 |
$$numbered = $local if ref $numbered;
|
1519 | 1561 |
binmode $fh;
|
1520 | |
$lstart = CORE::tell $fh if $append;
|
|
1562 |
$lstart = sysseek($fh, 0, 1) if $append;
|
1521 | 1563 |
}
|
1522 | 1564 |
}
|
1523 | 1565 |
|
|
1525 | 1567 |
local ($@, $SIG{__DIE__}, $SIG{__WARN__});
|
1526 | 1568 |
my $e = eval { chmod($perm & $neg_umask, $local) };
|
1527 | 1569 |
if ($@ or $e <= 0) {
|
|
1570 |
my $err = $!;
|
|
1571 |
unlink $local;
|
1528 | 1572 |
$sftp->_set_error(SFTP_ERR_LOCAL_CHMOD_FAILED,
|
1529 | |
"Can't chmod $local", ($@ ? $@ : $!));
|
|
1573 |
"Can't chmod $local", ($@ ? $@ : $err));
|
1530 | 1574 |
return undef
|
1531 | 1575 |
}
|
1532 | 1576 |
}
|
|
1535 | 1579 |
my $converter = _gen_converter $conversion;
|
1536 | 1580 |
|
1537 | 1581 |
my $rfid = $sftp->_rfid($rfh);
|
1538 | |
defined $rfid or return undef;
|
|
1582 |
defined $rfid or die "internal error: rfid not defined";
|
1539 | 1583 |
|
1540 | 1584 |
my @msgid;
|
1541 | 1585 |
my @askoff;
|
|
1544 | 1588 |
my $n = 0;
|
1545 | 1589 |
local $\;
|
1546 | 1590 |
do {
|
1547 | |
# disable autodie here in order to do not leave unhandled
|
|
1591 |
# Disable autodie here in order to do not leave unhandled
|
1548 | 1592 |
# responses queued on the connection in case of failure.
|
1549 | 1593 |
local $sftp->{_autodie};
|
|
1594 |
|
|
1595 |
# Again, once this point is reached, all code paths should end
|
|
1596 |
# through the CLEANUP block.
|
1550 | 1597 |
|
1551 | 1598 |
while (1) {
|
1552 | 1599 |
# request a new block if queue is not full
|
|
1610 | 1657 |
}
|
1611 | 1658 |
}
|
1612 | 1659 |
}
|
1613 | |
};
|
1614 | |
|
1615 | |
$sftp->_get_msg for (@msgid);
|
1616 | |
|
1617 | |
if ($sftp->error) {
|
1618 | |
# we are out of the pipeline loop, so we can now safely
|
1619 | |
# rethrow any error when autodie is on.
|
1620 | |
croak $sftp->error if $sftp->{_autodie};
|
1621 | |
return undef
|
1622 | |
}
|
1623 | |
|
1624 | |
# if a converter is in place, and aditional call has to be
|
1625 | |
# performed in order to flush any pending buffered data
|
1626 | |
if ($converter) {
|
1627 | |
my $data = '';
|
1628 | |
my $adjustment_before = $adjustment;
|
1629 | |
$adjustment += $converter->($data);
|
1630 | |
|
1631 | |
if (length($data) and defined $cb) {
|
1632 | |
# $size = $loff if ($loff > $size and $size != -1);
|
1633 | |
$cb->($sftp, $data, $askoff + $adjustment_before, $size + $adjustment);
|
1634 | |
return undef if $sftp->error;
|
1635 | |
}
|
1636 | |
|
1637 | |
if (length($data) and !$dont_save) {
|
1638 | |
unless (print $fh $data) {
|
1639 | |
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
|
1640 | |
"unable to write data to local file $local", $!);
|
1641 | |
return undef;
|
|
1660 |
|
|
1661 |
$sftp->_get_msg for (@msgid);
|
|
1662 |
|
|
1663 |
goto CLEANUP if $sftp->{_error};
|
|
1664 |
|
|
1665 |
# if a converter is in place, and aditional call has to be
|
|
1666 |
# performed in order to flush any pending buffered data
|
|
1667 |
if ($converter) {
|
|
1668 |
my $data = '';
|
|
1669 |
my $adjustment_before = $adjustment;
|
|
1670 |
$adjustment += $converter->($data);
|
|
1671 |
|
|
1672 |
if (length($data) and defined $cb) {
|
|
1673 |
# $size = $loff if ($loff > $size and $size != -1);
|
|
1674 |
$cb->($sftp, $data, $askoff + $adjustment_before, $size + $adjustment);
|
|
1675 |
goto CLEANUP if $sftp->{_error};
|
1642 | 1676 |
}
|
1643 | |
}
|
1644 | |
}
|
1645 | |
|
1646 | |
# we call the callback one last time with an empty string;
|
1647 | |
if (defined $cb) {
|
1648 | |
my $data = '';
|
1649 | |
$cb->($sftp, $data, $askoff + $adjustment, $size + $adjustment);
|
1650 | |
return undef if $sftp->error;
|
1651 | |
if (length($data) and !$dont_save) {
|
1652 | |
unless (print $fh $data) {
|
1653 | |
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
|
1654 | |
"unable to write data to local file $local", $!);
|
1655 | |
return undef;
|
1656 | |
}
|
1657 | |
}
|
1658 | |
}
|
1659 | |
|
1660 | |
unless ($dont_save) {
|
1661 | |
unless ($local_is_fh or CORE::close $fh) {
|
1662 | |
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
|
1663 | |
"unable to write data to local file $local", $!);
|
1664 | |
return undef;
|
1665 | |
}
|
1666 | |
|
1667 | |
# we can be running on taint mode, so some checks are
|
1668 | |
# performed to untaint data from the remote side.
|
1669 | |
|
1670 | |
if ($copy_time) {
|
1671 | |
if ($a->flags & SSH2_FILEXFER_ATTR_ACMODTIME) {
|
1672 | |
$a->atime =~ /^(\d+)$/ or die "Bad atime from remote file $remote";
|
1673 | |
my $atime = int $1;
|
1674 | |
$a->mtime =~ /^(\d+)$/ or die "Bad mtime from remote file $remote";
|
1675 | |
my $mtime = int $1;
|
1676 | |
|
1677 | |
unless (utime $atime, $mtime, $local) {
|
1678 | |
$sftp->_set_error(SFTP_ERR_LOCAL_UTIME_FAILED,
|
1679 | |
"Can't utime $local", $!);
|
1680 | |
return undef;
|
|
1677 |
|
|
1678 |
if (length($data) and !$dont_save) {
|
|
1679 |
unless (print $fh $data) {
|
|
1680 |
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
|
|
1681 |
"unable to write data to local file $local", $!);
|
|
1682 |
goto CLEANUP;
|
1681 | 1683 |
}
|
1682 | 1684 |
}
|
1683 | 1685 |
}
|
1684 | |
}
|
1685 | |
|
1686 | |
return !$sftp->{_error}
|
|
1686 |
|
|
1687 |
# we call the callback one last time with an empty string;
|
|
1688 |
if (defined $cb) {
|
|
1689 |
my $data = '';
|
|
1690 |
$cb->($sftp, $data, $askoff + $adjustment, $size + $adjustment);
|
|
1691 |
return undef if $sftp->error;
|
|
1692 |
if (length($data) and !$dont_save) {
|
|
1693 |
unless (print $fh $data) {
|
|
1694 |
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
|
|
1695 |
"unable to write data to local file $local", $!);
|
|
1696 |
goto CLEANUP;
|
|
1697 |
}
|
|
1698 |
}
|
|
1699 |
}
|
|
1700 |
|
|
1701 |
unless ($dont_save) {
|
|
1702 |
unless ($local_is_fh or CORE::close $fh) {
|
|
1703 |
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
|
|
1704 |
"unable to write data to local file $local", $!);
|
|
1705 |
goto CLEANUP;
|
|
1706 |
}
|
|
1707 |
|
|
1708 |
# we can be running on taint mode, so some checks are
|
|
1709 |
# performed to untaint data from the remote side.
|
|
1710 |
|
|
1711 |
if ($copy_time and not utime($atime, $mtime, $local)) {
|
|
1712 |
$sftp->_set_error(SFTP_ERR_LOCAL_UTIME_FAILED,
|
|
1713 |
"Can't utime $local", $!);
|
|
1714 |
goto CLEANUP;
|
|
1715 |
}
|
|
1716 |
}
|
|
1717 |
|
|
1718 |
if ($atomic) {
|
|
1719 |
if (!$overwrite) {
|
|
1720 |
while (1) {
|
|
1721 |
# performing a non-overwriting atomic rename is
|
|
1722 |
# quite burdensome: first, link is tried, if that
|
|
1723 |
# fails, non-overwriting is favoured over
|
|
1724 |
# atomicity and an empty file is used to lock the
|
|
1725 |
# path before atempting an overwriting rename.
|
|
1726 |
if (link $local, $atomic_local) {
|
|
1727 |
unlink $local;
|
|
1728 |
last;
|
|
1729 |
}
|
|
1730 |
my $err = $!;
|
|
1731 |
unless (-e $atomic_local) {
|
|
1732 |
if (sysopen my $lock, $atomic_local,
|
|
1733 |
Fcntl::O_CREAT|Fcntl::O_EXCL|Fcntl::O_WRONLY,
|
|
1734 |
0600) {
|
|
1735 |
$atomic_cleanup = 1;
|
|
1736 |
goto OVERWRITE;
|
|
1737 |
}
|
|
1738 |
$err = $!;
|
|
1739 |
unless (-e $atomic_local) {
|
|
1740 |
$sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
|
|
1741 |
"Can't open $local", $err);
|
|
1742 |
goto CLEANUP;
|
|
1743 |
}
|
|
1744 |
}
|
|
1745 |
unless ($numbered) {
|
|
1746 |
$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
|
|
1747 |
"local file $atomic_local already exists");
|
|
1748 |
goto CLEANUP;
|
|
1749 |
}
|
|
1750 |
_inc_numbered($atomic_local);
|
|
1751 |
}
|
|
1752 |
}
|
|
1753 |
else {
|
|
1754 |
OVERWRITE:
|
|
1755 |
unless (CORE::rename $local, $atomic_local) {
|
|
1756 |
$sftp->_set_error(SFTP_ERR_LOCAL_RENAME_FAILED,
|
|
1757 |
"Unable to rename temporal file to its final position '$atomic_local'", $!);
|
|
1758 |
|
|
1759 |
goto CLEANUP;
|
|
1760 |
}
|
|
1761 |
}
|
|
1762 |
$$atomic_numbered = $local if ref $atomic_numbered;
|
|
1763 |
}
|
|
1764 |
|
|
1765 |
CLEANUP:
|
|
1766 |
if ($cleanup and $sftp->{_error}) {
|
|
1767 |
unlink $local;
|
|
1768 |
unlink $atomic_local if $atomic_cleanup;
|
|
1769 |
}
|
|
1770 |
|
|
1771 |
}; # autodie flag is restored here!
|
|
1772 |
|
|
1773 |
$sftp->_ok_or_autodie;
|
1687 | 1774 |
}
|
1688 | 1775 |
|
1689 | 1776 |
# return file contents on success, undef on failure
|
|
1698 | 1785 |
my $rfh = $sftp->open($name)
|
1699 | 1786 |
or return undef;
|
1700 | 1787 |
|
1701 | |
return scalar $sftp->readline($rfh, undef);
|
|
1788 |
scalar $sftp->readline($rfh, undef);
|
1702 | 1789 |
}
|
1703 | 1790 |
|
1704 | 1791 |
sub put {
|
1705 | |
@_ >= 3 or croak 'Usage: $sftp->put($local, $remote, %opts)';
|
|
1792 |
@_ >= 2 or croak 'Usage: $sftp->put($local, $remote, %opts)';
|
1706 | 1793 |
${^TAINT} and &_catch_tainted_args;
|
1707 | 1794 |
|
1708 | 1795 |
my ($sftp, $local, $remote, %opts) = @_;
|
|
1796 |
defined $local or croak "local file path is undefined";
|
|
1797 |
|
|
1798 |
$sftp->_clear_error_and_status;
|
|
1799 |
|
|
1800 |
my $local_is_fh = (ref $local and $local->isa('GLOB'));
|
|
1801 |
unless (defined $remote) {
|
|
1802 |
$local_is_fh and croak "unable to infer remote file name when a file handler is passed as local";
|
|
1803 |
$remote = (File::Spec->splitpath($local))[2];
|
|
1804 |
}
|
1709 | 1805 |
$remote = $sftp->_rel2abs($remote);
|
1710 | |
my $local_is_fh = (ref $local and $local->isa('GLOB'));
|
1711 | |
|
1712 | |
$sftp->_clear_error_and_status;
|
1713 | 1806 |
|
1714 | 1807 |
my $cb = delete $opts{callback};
|
1715 | |
|
1716 | 1808 |
my $umask = delete $opts{umask};
|
1717 | 1809 |
my $perm = delete $opts{perm};
|
1718 | |
my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
|
|
1810 |
my $copy_perm = delete $opts{copy_perm};
|
|
1811 |
$copy_perm = delete $opts{copy_perms} unless defined $copy_perm;
|
1719 | 1812 |
my $copy_time = delete $opts{copy_time};
|
1720 | 1813 |
my $overwrite = delete $opts{overwrite};
|
1721 | 1814 |
my $resume = delete $opts{resume};
|
|
1725 | 1818 |
my $conversion = delete $opts{conversion};
|
1726 | 1819 |
my $late_set_perm = delete $opts{late_set_perm};
|
1727 | 1820 |
my $numbered = delete $opts{numbered};
|
|
1821 |
my $atomic = delete $opts{atomic};
|
|
1822 |
my $cleanup = delete $opts{cleanup};
|
1728 | 1823 |
|
1729 | 1824 |
croak "'perm' and 'umask' options can not be used simultaneously"
|
1730 | 1825 |
if (defined $perm and defined $umask);
|
|
1736 | 1831 |
if ($resume and $overwrite);
|
1737 | 1832 |
croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'"
|
1738 | 1833 |
if ($numbered and ($overwrite or $resume or $append));
|
|
1834 |
croak "'atomic' can not be used with 'resume' or 'append'"
|
|
1835 |
if ($atomic and ($resume or $append));
|
1739 | 1836 |
|
1740 | 1837 |
%opts and _croak_bad_options(keys %opts);
|
1741 | 1838 |
|
|
1743 | 1840 |
$copy_perm = 1 unless (defined $perm or defined $copy_perm or $local_is_fh);
|
1744 | 1841 |
$copy_time = 1 unless (defined $copy_time or $local_is_fh);
|
1745 | 1842 |
$late_set_perm = $sftp->{_late_set_perm} unless defined $late_set_perm;
|
|
1843 |
$cleanup = ($atomic || $numbered) unless defined $cleanup;
|
1746 | 1844 |
|
1747 | 1845 |
my $neg_umask;
|
1748 | 1846 |
if (defined $perm) {
|
|
1906 | 2004 |
}
|
1907 | 2005 |
}
|
1908 | 2006 |
|
|
2007 |
my ($atomic_numbered, $atomic_remote);
|
|
2008 |
|
1909 | 2009 |
unless (defined $rfh) {
|
|
2010 |
if ($atomic) {
|
|
2011 |
# check that does not exist a file of the same name that
|
|
2012 |
# would block the rename operation at the end
|
|
2013 |
if (!($numbered or $overwrite) and
|
|
2014 |
$sftp->test_e($remote)) {
|
|
2015 |
$sftp->_set_status(SSH2_FX_FAILURE);
|
|
2016 |
$sftp->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS,
|
|
2017 |
"Remote file '$remote' already exists");
|
|
2018 |
return undef;
|
|
2019 |
}
|
|
2020 |
$atomic_remote = $remote;
|
|
2021 |
$remote .= sprintf("(%d).tmp", rand(10000));
|
|
2022 |
$atomic_numbered = $numbered;
|
|
2023 |
$numbered = 1;
|
|
2024 |
$debug and $debug & 128 and _debug("temporal remote file name: $remote");
|
|
2025 |
}
|
1910 | 2026 |
if ($numbered) {
|
1911 | |
while ($sftp->stat($remote)) {
|
1912 | |
my $old = $remote;
|
1913 | |
$remote =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e
|
1914 | |
or $remote =~ s{((?:\.[^\.]*)?)$}{(1)$1};
|
1915 | |
$debug and $debug & 128 and _debug("numbering remote: $old => $local");
|
|
2027 |
while (1) {
|
|
2028 |
local $sftp->{_autodie};
|
|
2029 |
$rfh = $sftp->open($remote,
|
|
2030 |
SSH2_FXF_WRITE | SSH2_FXF_CREAT | SSH2_FXF_EXCL,
|
|
2031 |
$attrs);
|
|
2032 |
last if ($rfh or
|
|
2033 |
$sftp->status != SSH2_FX_FAILURE or
|
|
2034 |
!$sftp->test_e($remote));
|
|
2035 |
_inc_numbered($remote);
|
1916 | 2036 |
}
|
|
2037 |
$sftp->_ok_or_autodie;
|
|
2038 |
$$numbered = $remote if ref $numbered;
|
1917 | 2039 |
}
|
1918 | |
|
1919 | |
$rfh = $sftp->open($remote,
|
1920 | |
SSH2_FXF_WRITE | SSH2_FXF_CREAT |
|
1921 | |
($append ? 0 : ($overwrite ? SSH2_FXF_TRUNC : SSH2_FXF_EXCL)),
|
1922 | |
$attrs)
|
1923 | |
or return undef;
|
1924 | |
}
|
1925 | |
|
1926 | |
# In some SFTP server implementations, open does not set the
|
1927 | |
# attributes for existent files so we do it again. The
|
1928 | |
# $late_set_perm work around is for some servers that do not
|
1929 | |
# support changing the permissions of open files
|
1930 | |
if (defined $perm and !$late_set_perm) {
|
1931 | |
$sftp->fsetstat($rfh, $attrs)
|
1932 | |
or return undef;
|
1933 | |
}
|
1934 | |
|
1935 | |
my $rfid = $sftp->_rfid($rfh);
|
1936 | |
defined $rfid or return undef;
|
1937 | |
|
1938 | |
# In append mode we add the size of the remote file in writeoff,
|
1939 | |
# if lsize is undef, we initialize it to $writeoff:
|
1940 | |
$lsize += $writeoff if ($append or not defined $lsize);
|
1941 | |
|
1942 | |
# when a converter is used, the EOF can become delayed by the
|
1943 | |
# buffering introduced, we use $eof_t to account for that.
|
1944 | |
my ($eof, $eof_t);
|
1945 | |
my @msgid;
|
|
2040 |
else {
|
|
2041 |
$rfh = $sftp->open($remote,
|
|
2042 |
SSH2_FXF_WRITE | SSH2_FXF_CREAT |
|
|
2043 |
($append ? 0 : ($overwrite ? SSH2_FXF_TRUNC : SSH2_FXF_EXCL)),
|
|
2044 |
$attrs)
|
|
2045 |
or return undef;
|
|
2046 |
}
|
|
2047 |
}
|
|
2048 |
|
|
2049 |
$sftp->_ok_or_autodie or return undef;
|
|
2050 |
# Once this point is reached and for the remaining of the sub,
|
|
2051 |
# code should never return but jump into the CLEANUP block.
|
|
2052 |
|
1946 | 2053 |
do {
|
1947 | |
local $sftp->{_autodie};
|
|
2054 |
local $sftp->{autodie};
|
|
2055 |
|
|
2056 |
# In some SFTP server implementations, open does not set the
|
|
2057 |
# attributes for existent files so we do it again. The
|
|
2058 |
# $late_set_perm work around is for some servers that do not
|
|
2059 |
# support changing the permissions of open files
|
|
2060 |
if (defined $perm and !$late_set_perm) {
|
|
2061 |
$sftp->fsetstat($rfh, $attrs) or goto CLEANUP;
|
|
2062 |
}
|
|
2063 |
|
|
2064 |
my $rfid = $sftp->_rfid($rfh);
|
|
2065 |
defined $rfid or die "internal error: rfid is undef";
|
|
2066 |
|
|
2067 |
# In append mode we add the size of the remote file in
|
|
2068 |
# writeoff, if lsize is undef, we initialize it to $writeoff:
|
|
2069 |
$lsize += $writeoff if ($append or not defined $lsize);
|
|
2070 |
|
|
2071 |
# when a converter is used, the EOF can become delayed by the
|
|
2072 |
# buffering introduced, we use $eof_t to account for that.
|
|
2073 |
my ($eof, $eof_t);
|
|
2074 |
my @msgid;
|
1948 | 2075 |
OK: while (1) {
|
1949 | 2076 |
if (!$eof and @msgid < $queue_size) {
|
1950 | 2077 |
my ($data, $len);
|
|
2040 | 2167 |
$sftp->_get_msg for (@msgid);
|
2041 | 2168 |
|
2042 | 2169 |
$sftp->_close_save_status($rfh);
|
|
2170 |
|
|
2171 |
goto CLEANUP if $sftp->{_error};
|
|
2172 |
|
|
2173 |
# for servers that does not support setting permissions on open files
|
|
2174 |
if (defined $perm and $late_set_perm) {
|
|
2175 |
$sftp->setstat($remote, $attrs);
|
|
2176 |
}
|
|
2177 |
|
|
2178 |
if ($copy_time) {
|
|
2179 |
$attrs = Net::SFTP::Foreign::Attributes->new;
|
|
2180 |
$attrs->set_amtime($latime, $lmtime);
|
|
2181 |
$sftp->setstat($remote, $attrs) or goto CLEANUP;
|
|
2182 |
}
|
|
2183 |
|
|
2184 |
if ($atomic) {
|
|
2185 |
$sftp->rename($remote, $atomic_remote,
|
|
2186 |
overwrite => $overwrite,
|
|
2187 |
numbered => $atomic_numbered) or goto CLEANUP;
|
|
2188 |
}
|
|
2189 |
|
|
2190 |
CLEANUP:
|
|
2191 |
if ($cleanup and $sftp->{_error}) {
|
|
2192 |
warn "cleanup $remote";
|
|
2193 |
$sftp->_remove_save_status($remote);
|
|
2194 |
}
|
2043 | 2195 |
};
|
2044 | |
|
2045 | |
if ($sftp->error) {
|
2046 | |
croak $sftp->error if $sftp->{_autodie};
|
2047 | |
return undef;
|
2048 | |
}
|
2049 | |
|
2050 | |
# for servers that does not support setting permissions on open files
|
2051 | |
if (defined $perm and $late_set_perm) {
|
2052 | |
$sftp->setstat($remote, $attrs)
|
2053 | |
or return undef;
|
2054 | |
}
|
2055 | |
|
2056 | |
if ($copy_time) {
|
2057 | |
$attrs = Net::SFTP::Foreign::Attributes->new;
|
2058 | |
$attrs->set_amtime($latime, $lmtime);
|
2059 | |
$sftp->setstat($remote, $attrs);
|
2060 | |
}
|
2061 | |
|
2062 | |
return $sftp->{_error} == 0;
|
|
2196 |
$sftp->_ok_or_autodie;
|
2063 | 2197 |
}
|
2064 | 2198 |
|
2065 | 2199 |
sub ls {
|
|
2274 | 2408 |
|
2275 | 2409 |
my $link = $sftp->readlink($remote) or return undef;
|
2276 | 2410 |
|
|
2411 |
# TODO: this is too weak, may contain race conditions.
|
2277 | 2412 |
if ($numbered) {
|
2278 | |
while (-e $local) {
|
2279 | |
my $old = $local;
|
2280 | |
$local =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e
|
2281 | |
or $local =~ s{((?:\.[^\.]*)?)$}{(1)$1};
|
2282 | |
$debug and $debug & 128 and _debug("numbering: $old => $local");
|
2283 | |
}
|
|
2413 |
_inc_numbered($local) while -e $local;
|
2284 | 2414 |
}
|
2285 | 2415 |
elsif (-e $local) {
|
2286 | 2416 |
if ($overwrite) {
|
|
2298 | 2428 |
"creation of symlink '$local' failed", $!);
|
2299 | 2429 |
return undef;
|
2300 | 2430 |
}
|
|
2431 |
$$numbered = $local if ref $numbered;
|
|
2432 |
|
2301 | 2433 |
1;
|
2302 | 2434 |
}
|
2303 | 2435 |
|
|
2330 | 2462 |
return undef;
|
2331 | 2463 |
}
|
2332 | 2464 |
|
2333 | |
if ($numbered) {
|
2334 | |
while ($sftp->stat($remote)) {
|
2335 | |
my $old = $remote;
|
2336 | |
$remote =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e
|
2337 | |
or $remote =~ s{((?:\.[^\.]*)?)$}{(1)$1};
|
2338 | |
$debug and $debug & 128 and _debug("numbering remote: $old => $local");
|
2339 | |
}
|
2340 | |
}
|
2341 | |
$sftp->remove($remote) if $overwrite;
|
2342 | |
$sftp->symlink($remote, $target);
|
|
2465 |
while (1) {
|
|
2466 |
local $sftp->{_autodie};
|
|
2467 |
$sftp->symlink($remote, $target);
|
|
2468 |
if ($sftp->error and
|
|
2469 |
$sftp->status == SSH2_FX_FAILURE) {
|
|
2470 |
if ($numbered and $sftp->test_e($remote)) {
|
|
2471 |
_inc_numbered($remote);
|
|
2472 |
redo;
|
|
2473 |
}
|
|
2474 |
elsif ($overwrite and $sftp->_remove_save_status($remote)) {
|
|
2475 |
$overwrite = 0;
|
|
2476 |
redo;
|
|
2477 |
}
|
|
2478 |
}
|
|
2479 |
last
|
|
2480 |
}
|
|
2481 |
$$numbered = $remote if ref $numbered;
|
|
2482 |
$sftp->_ok_or_autodie;
|
2343 | 2483 |
}
|
2344 | 2484 |
|
2345 | 2485 |
sub rget {
|
2346 | |
@_ >= 3 or croak 'Usage: $sftp->rget($remote, $local, %opts)';
|
|
2486 |
@_ >= 2 or croak 'Usage: $sftp->rget($remote, $local, %opts)';
|
2347 | 2487 |
${^TAINT} and &_catch_tainted_args;
|
2348 | |
|
2349 | 2488 |
my ($sftp, $remote, $local, %opts) = @_;
|
|
2489 |
|
|
2490 |
defined $remote or croak "remote file path is undefined";
|
|
2491 |
$local = File::Spec->curdir unless defined $local;
|
2350 | 2492 |
|
2351 | 2493 |
# my $cb = delete $opts{callback};
|
2352 | 2494 |
my $umask = delete $opts{umask};
|
2353 | 2495 |
my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
|
2354 | 2496 |
my $copy_time = delete $opts{copy_time};
|
2355 | |
my $block_size = delete $opts{block_size};
|
2356 | |
my $queue_size = delete $opts{queue_size};
|
2357 | |
my $overwrite = delete $opts{overwrite};
|
2358 | 2497 |
my $newer_only = delete $opts{newer_only};
|
2359 | 2498 |
my $on_error = delete $opts{on_error};
|
2360 | 2499 |
local $sftp->{_autodie} if $on_error;
|
2361 | 2500 |
my $ignore_links = delete $opts{ignore_links};
|
2362 | |
my $conversion = delete $opts{conversion};
|
2363 | |
my $resume = delete $opts{resume};
|
2364 | |
my $numbered = delete $opts{numbered};
|
2365 | |
|
2366 | |
if ($resume and $conversion) {
|
2367 | |
carp "resume option is useless when data conversion has also been requested";
|
2368 | |
undef $resume;
|
2369 | |
}
|
2370 | 2501 |
|
2371 | 2502 |
# my $relative_links = delete $opts{relative_links};
|
2372 | 2503 |
|
2373 | 2504 |
my $wanted = _gen_wanted( delete $opts{wanted},
|
2374 | 2505 |
delete $opts{no_wanted} );
|
|
2506 |
|
|
2507 |
my %get_opts = (map { $_ => delete $opts{$_} }
|
|
2508 |
qw(block_size queue_size overwrite conversion
|
|
2509 |
resume numbered atomic));
|
|
2510 |
|
|
2511 |
if ($get_opts{resume} and $get_opts{conversion}) {
|
|
2512 |
carp "resume option is useless when data conversion has also been requested";
|
|
2513 |
delete $get_opts{resume};
|
|
2514 |
}
|
|
2515 |
|
|
2516 |
my %get_symlink_opts = (map { $_ => $get_opts{$_} }
|
|
2517 |
qw(overwrite numbered));
|
2375 | 2518 |
|
2376 | 2519 |
%opts and _croak_bad_options(keys %opts);
|
2377 | 2520 |
|
|
2432 | 2575 |
($lpath) = $lpath =~ /(.*)/ if ${^TAINT};
|
2433 | 2576 |
if (_is_lnk($e->{a}->perm) and !$ignore_links) {
|
2434 | 2577 |
if ($sftp->get_symlink($fn, $lpath,
|
2435 | |
overwrite => $overwrite,
|
2436 | |
numbered => $numbered,
|
2437 | |
copy_time => $copy_time)) {
|
|
2578 |
copy_time => $copy_time,
|
|
2579 |
%get_symlink_opts)) {
|
2438 | 2580 |
$count++;
|
2439 | 2581 |
return undef;
|
2440 | 2582 |
}
|
|
2447 | 2589 |
}
|
2448 | 2590 |
else {
|
2449 | 2591 |
if ($sftp->get($fn, $lpath,
|
2450 | |
overwrite => $overwrite,
|
2451 | |
numbered => $numbered,
|
2452 | |
queue_size => $queue_size,
|
2453 | |
block_size => $block_size,
|
2454 | 2592 |
copy_perm => $copy_perm,
|
2455 | 2593 |
copy_time => $copy_time,
|
2456 | |
conversion => $conversion,
|
2457 | |
resume => $resume )) {
|
|
2594 |
%get_opts)) {
|
2458 | 2595 |
$count++;
|
2459 | 2596 |
return undef;
|
2460 | 2597 |
}
|
|
2483 | 2620 |
}
|
2484 | 2621 |
|
2485 | 2622 |
sub rput {
|
2486 | |
@_ >= 3 or croak 'Usage: $sftp->rput($local, $remote, %opts)';
|
|
2623 |
@_ >= 2 or croak 'Usage: $sftp->rput($local, $remote, %opts)';
|
2487 | 2624 |
${^TAINT} and &_catch_tainted_args;
|
2488 | 2625 |
|
2489 | 2626 |
my ($sftp, $local, $remote, %opts) = @_;
|
|
2627 |
|
|
2628 |
defined $local or croak "local path is undefined";
|
|
2629 |
$remote = '.' unless defined $remote;
|
2490 | 2630 |
|
2491 | 2631 |
# my $cb = delete $opts{callback};
|
2492 | 2632 |
my $umask = delete $opts{umask};
|
2493 | 2633 |
my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
|
2494 | 2634 |
my $copy_time = delete $opts{copy_time};
|
2495 | |
my $block_size = delete $opts{block_size};
|
2496 | |
my $queue_size = delete $opts{queue_size};
|
2497 | |
my $overwrite = delete $opts{overwrite};
|
2498 | |
my $numbered = delete $opts{numbered};
|
|
2635 |
|
2499 | 2636 |
my $newer_only = delete $opts{newer_only};
|
2500 | 2637 |
my $on_error = delete $opts{on_error};
|
2501 | 2638 |
local $sftp->{_autodie} if $on_error;
|
2502 | 2639 |
my $ignore_links = delete $opts{ignore_links};
|
2503 | |
my $conversion = delete $opts{conversion};
|
2504 | |
my $resume = delete $opts{resume};
|
2505 | |
my $late_set_perm = delete $opts{late_set_perm};
|
2506 | |
|
2507 | |
# my $relative_links = delete $opts{relative_links};
|
2508 | 2640 |
|
2509 | 2641 |
my $wanted = _gen_wanted( delete $opts{wanted},
|
2510 | 2642 |
delete $opts{no_wanted} );
|
|
2643 |
|
|
2644 |
my %put_opts = (map { $_ => delete $opts{$_} }
|
|
2645 |
qw(block_size queue_size overwrite conversion
|
|
2646 |
resume numbered late_set_perm atomic));
|
|
2647 |
|
|
2648 |
my %put_symlink_opts = (map { $_ => $put_opts{$_} }
|
|
2649 |
qw(overwrite numbered));
|
2511 | 2650 |
|
2512 | 2651 |
%opts and _croak_bad_options(keys %opts);
|
2513 | 2652 |
|
|
2587 | 2726 |
my (undef, $d, $f) = File::Spec->splitpath($1);
|
2588 | 2727 |
my $rpath = $sftp->join($remote, File::Spec->splitdir($d), $f);
|
2589 | 2728 |
if (_is_lnk($e->{a}->perm) and !$ignore_links) {
|
2590 | |
if ($sftp->put_symlink($fn, $remote,
|
2591 | |
overwrite => $overwrite,
|
2592 | |
numbered => $numbered)) {
|
|
2729 |
if ($sftp->put_symlink($fn, $rpath,
|
|
2730 |
%put_symlink_opts)) {
|
2593 | 2731 |
$count++;
|
2594 | 2732 |
return undef;
|
2595 | 2733 |
}
|
|
2605 | 2743 |
}
|
2606 | 2744 |
else {
|
2607 | 2745 |
if ($sftp->put($fn, $rpath,
|
2608 | |
overwrite => $overwrite,
|
2609 | |
numbered => $numbered,
|
2610 | |
queue_size => $queue_size,
|
2611 | |
block_size => $block_size,
|
2612 | 2746 |
perm => ($copy_perm ? $e->{a}->perm : 0777) & $mask,
|
2613 | 2747 |
copy_time => $copy_time,
|
2614 | |
conversion => $conversion,
|
2615 | |
resume => $resume,
|
2616 | |
late_set_perm => $late_set_perm )) {
|
|
2748 |
%put_opts)) {
|
2617 | 2749 |
$count++;
|
2618 | 2750 |
return undef;
|
2619 | 2751 |
}
|
|
2644 | 2776 |
@_ >= 2 or croak 'Usage: $sftp->mget($remote, $localdir, %opts)';
|
2645 | 2777 |
${^TAINT} and &_catch_tainted_args;
|
2646 | 2778 |
|
2647 | |
my $sftp = shift;
|
2648 | |
my $remote = shift;
|
2649 | |
my $localdir = (@_ & 1 ? shift : undef);
|
2650 | |
my %opts = @_;
|
|
2779 |
my ($sftp, $remote, $localdir, %opts) = @_;
|
|
2780 |
|
|
2781 |
defined $remote or croak "remote pattern is undefined";
|
2651 | 2782 |
|
2652 | 2783 |
my $on_error = $opts{on_error};
|
2653 | 2784 |
local $sftp->{_autodie} if $on_error;
|
|
2662 | 2793 |
|
2663 | 2794 |
my %get_opts = (map { $_ => delete $opts{$_} }
|
2664 | 2795 |
qw(umask copy_perm copy_time block_size queue_size
|
2665 | |
overwrite conversion resume numbered));
|
|
2796 |
overwrite conversion resume numbered atomic));
|
2666 | 2797 |
|
2667 | 2798 |
%opts and _croak_bad_options(keys %opts);
|
2668 | 2799 |
|
|
2700 | 2831 |
|
2701 | 2832 |
sub mput {
|
2702 | 2833 |
@_ >= 2 or croak 'Usage: $sftp->mput($local, $remotedir, %opts)';
|
2703 | |
my $sftp = shift;
|
2704 | |
my $local = shift;
|
2705 | |
my $remotedir = (@_ & 1 ? shift : undef);
|
2706 | |
my %opts = @_;
|
|
2834 |
|
|
2835 |
my ($sftp, $local, $remotedir, %opts) = @_;
|
|
2836 |
|
|
2837 |
defined $local or die "local pattern is undefined";
|
2707 | 2838 |
|
2708 | 2839 |
my $on_error = $opts{on_error};
|
2709 | 2840 |
local $sftp->{_autodie} if $on_error;
|
|
2717 | 2848 |
|
2718 | 2849 |
my %put_opts = (map { $_ => delete $opts{$_} }
|
2719 | 2850 |
qw(umask copy_perm copy_time block_size queue_size
|
2720 | |
overwrite conversion resume numbered late_set_perm));
|
|
2851 |
overwrite conversion resume numbered late_set_perm atomic));
|
2721 | 2852 |
|
2722 | 2853 |
%opts and _croak_bad_options(keys %opts);
|
2723 | 2854 |
|
|
3035 | 3166 |
$debug and $debug & 4 and Net::SFTP::Foreign::_debug("$self->DESTROY called (sftp: ".($sftp||'').")");
|
3036 | 3167 |
|
3037 | 3168 |
if ($self->_check and $sftp) {
|
|
3169 |
local $sftp->{_autodie};
|
3038 | 3170 |
$sftp->_close_save_status($self)
|
3039 | 3171 |
}
|
3040 | 3172 |
}
|
|
3075 | 3207 |
$debug and $debug & 4 and Net::SFTP::Foreign::_debug("$self->DESTROY called (sftp: ".($sftp||'').")");
|
3076 | 3208 |
|
3077 | 3209 |
if ($self->_check and $sftp) {
|
|
3210 |
local $sftp->{_autodie};
|
3078 | 3211 |
$sftp->_closedir_save_status($self)
|
3079 | 3212 |
}
|
3080 | 3213 |
}
|
|
3232 | 3365 |
|
3233 | 3366 |
port number where the remote SSH server is listening
|
3234 | 3367 |
|
|
3368 |
=item ssh1 =E<gt> 1
|
|
3369 |
|
|
3370 |
use old SSH1 approach for starting the remote SFTP server.
|
|
3371 |
|
3235 | 3372 |
=item more =E<gt> [@more_ssh_args]
|
3236 | 3373 |
|
3237 | 3374 |
additional args passed to C<ssh> command.
|
|
3249 | 3386 |
more => "-c $cipher" # wrong!!!
|
3250 | 3387 |
more => [-c => $cipher] # right
|
3251 | 3388 |
|
|
3389 |
=item timeout =E<gt> $seconds
|
|
3390 |
|
|
3391 |
when this parameter is set, the connection is dropped if no data
|
|
3392 |
arrives on the SSH socket for the given time while waiting for some
|
|
3393 |
command to complete.
|
|
3394 |
|
|
3395 |
When the timeout expires, the current method is aborted and
|
|
3396 |
the SFTP connection becomes invalid.
|
|
3397 |
|
|
3398 |
=item fs_encoding =E<gt> $encoding
|
|
3399 |
|
|
3400 |
Version 3 of the SFTP protocol (the one supported by this module)
|
|
3401 |
knows nothing about the character encoding used on the remote
|
|
3402 |
filesystem to represent file and directory names.
|
|
3403 |
|
|
3404 |
This option allows to select the encoding used in the remote
|
|
3405 |
machine. The default value is C<utf8>.
|
|
3406 |
|
|
3407 |
For instance:
|
|
3408 |
|
|
3409 |
$sftp = Net::SFTP::Foreign->new('user@host', fs_encoding => 'latin1');
|
|
3410 |
|
|
3411 |
will convert any path name passed to any method in this package to its
|
|
3412 |
C<latin1> representation before sending it to the remote side.
|
|
3413 |
|
|
3414 |
Note that this option will not affect file contents in any way.
|
|
3415 |
|
|
3416 |
This feature is not supported in perl 5.6 due to incomplete Unicode
|
|
3417 |
support in the interpreter.
|
|
3418 |
|
|
3419 |
=item key_path =E<gt> $filename
|
|
3420 |
|
|
3421 |
asks C<ssh> to use the key in the given file for authentication.
|
|
3422 |
|
|
3423 |
=item password =E<gt> $password
|
|
3424 |
|
|
3425 |
=item passphrase =E<gt> $passphrase
|
|
3426 |
|
|
3427 |
uses L<Expect> to handle password authentication or keys requiring a
|
|
3428 |
passphrase.
|
|
3429 |
|
|
3430 |
Note that password authentication on Windows OSs only works when the
|
|
3431 |
Cygwin port of Perl is used.
|
|
3432 |
|
|
3433 |
=item expect_log_user =E<gt> $bool
|
|
3434 |
|
|
3435 |
activates password/passphrase authentication interaction logging (see
|
|
3436 |
C<Expect::log_user> method documentation).
|
|
3437 |
|
|
3438 |
=item ssh_cmd =E<gt> $sshcmd
|
|
3439 |
|
|
3440 |
=item ssh_cmd =E<gt> \@sshcmd
|
|
3441 |
|
|
3442 |
name of the external SSH client. By default C<ssh> is used.
|
|
3443 |
|
|
3444 |
For instance:
|
|
3445 |
|
|
3446 |
$sftp = Net::SFTP::Foreign->new($host, ssh_cmd => 'plink');
|
|
3447 |
|
|
3448 |
When an array reference is used, its elements are inserted at the
|
|
3449 |
beginning of the system call. That allows, for instance, to connect to
|
|
3450 |
the target host through some SSH proxy:
|
|
3451 |
|
|
3452 |
$sftp = Net::SFTP::Foreign->new($host,
|
|
3453 |
ssh_cmd => qw(ssh -l user proxy.server ssh));
|
|
3454 |
|
|
3455 |
But note that the module will not handle password authentication for
|
|
3456 |
those proxies.
|
|
3457 |
|
3252 | 3458 |
=item ssh_cmd_interface =E<gt> 'plink' or 'ssh' or 'tectia'
|
3253 | 3459 |
|
3254 | 3460 |
declares the command line interface that the SSH client used to
|
|
3257 | 3463 |
|
3258 | 3464 |
This option would be rarely required as the module infers the
|
3259 | 3465 |
interface from the SSH command name.
|
3260 | |
|
3261 | |
=item timeout =E<gt> $seconds
|
3262 | |
|
3263 | |
when this parameter is set, the connection is dropped if no data
|
3264 | |
arrives on the SSH socket for the given time while waiting for some
|
3265 | |
command to complete.
|
3266 | |
|
3267 | |
When the timeout expires, the current method is aborted and
|
3268 | |
the SFTP connection becomes invalid.
|
3269 | |
|
3270 | |
=item fs_encoding =E<gt> $encoding
|
3271 | |
|
3272 | |
Version 3 of the SFTP protocol (the one supported by this module)
|
3273 | |
knows nothing about the character encoding used on the remote
|
3274 | |
filesystem to represent file and directory names.
|
3275 | |
|
3276 | |
This option allows to select the encoding used in the remote
|
3277 | |
machine. The default value is C<utf8>.
|
3278 | |
|
3279 | |
For instance:
|
3280 | |
|
3281 | |
$sftp = Net::SFTP::Foreign->new('user@host', fs_encoding => 'latin1');
|
3282 | |
|
3283 | |
will convert any path name passed to any method in this package to its
|
3284 | |
C<latin1> representation before sending it to the remote side.
|
3285 | |
|
3286 | |
Note that this option will not affect file contents in any way.
|
3287 | |
|
3288 | |
This feature is not supported in perl 5.6 due to incomplete Unicode
|
3289 | |
support in the interpreter.
|
3290 | |
|
3291 | |
=item key_path =E<gt> $filename
|
3292 | |
|
3293 | |
asks C<ssh> to use the key in the given file for authentication.
|
3294 | |
|
3295 | |
=item password =E<gt> $password
|
3296 | |
|
3297 | |
=item passphrase =E<gt> $passphrase
|
3298 | |
|
3299 | |
uses L<Expect> to handle password authentication or keys requiring a
|
3300 | |
passphrase.
|
3301 | |
|
3302 | |
Note that password authentication on Windows OSs only works when the
|
3303 | |
Cygwin port of Perl is used.
|
3304 | |
|
3305 | |
=item expect_log_user =E<gt> $bool
|
3306 | |
|
3307 | |
activates password/passphrase authentication interaction logging (see
|
3308 | |
C<Expect::log_user> method documentation).
|
3309 | |
|
3310 | |
=item ssh_cmd =E<gt> $sshcmd
|
3311 | |
|
3312 | |
name of the external SSH client. By default C<ssh> is used.
|
3313 | |
|
3314 | |
For instance:
|
3315 | |
|
3316 | |
my $sftp = Net::SFTP::Foreign->new($host, ssh_cmd => 'plink');
|
3317 | |
|
3318 | |
=item ssh1 =E<gt> 1
|
3319 | |
|
3320 | |
use old SSH1 approach for starting the remote SFTP server.
|
3321 | 3466 |
|
3322 | 3467 |
=item transport =E<gt> $fh
|
3323 | 3468 |
|
|
3584 | 3729 |
will copy the remote file as "data.txt" the first time and as
|
3585 | 3730 |
"data(1).txt" the second one.
|
3586 | 3731 |
|
|
3732 |
If a scalar reference is passed as the numbered value, the final
|
|
3733 |
target will be stored in the value pointed by the reference. For
|
|
3734 |
instance:
|
|
3735 |
|
|
3736 |
my $target;
|
|
3737 |
$sftp->get("data.txt", "data.txt", numbered => \$target);
|
|
3738 |
say "file was saved as $target" unless $sftp->error
|
|
3739 |
|
|
3740 |
=item atomic =E<gt> 1
|
|
3741 |
|
|
3742 |
The remote file contents are transferred into a temporal file that
|
|
3743 |
once the copy completes is renamed to the target destination.
|
|
3744 |
|
|
3745 |
If not-overwrite of remote files is also requested, an empty file may
|
|
3746 |
appear at the target destination before the rename operation is
|
|
3747 |
performed. This is due to limitations of some operating/file systems.
|
|
3748 |
|
|
3749 |
=item cleanup =E<gt> 1
|
|
3750 |
|
|
3751 |
If the transfer fails, remove the incomplete file.
|
|
3752 |
|
|
3753 |
This option is set to by default when there is not possible to resume
|
|
3754 |
the transfer afterwards (i.e., when using `atomic` or `numbered`
|
|
3755 |
options).
|
|
3756 |
|
3587 | 3757 |
=item conversion =E<gt> $conversion
|
3588 | 3758 |
|
3589 | 3759 |
on the fly data conversion of the file contents can be performed with
|
|
3627 | 3797 |
|
3628 | 3798 |
=item block_size =E<gt> $bytes
|
3629 | 3799 |
|
3630 | |
size of the blocks the file is being splittered on for
|
3631 | |
transfer. Incrementing this value can improve performance but some
|
3632 | |
servers limit the maximum size.
|
|
3800 |
size of the blocks the file is being split on for transfer.
|
|
3801 |
Incrementing this value can improve performance but some servers limit
|
|
3802 |
the maximum size.
|
3633 | 3803 |
|
3634 | 3804 |
=item queue_size =E<gt> $size
|
3635 | 3805 |
|
|
3696 | 3866 |
sets the permision mask of the file to be $perm, umask and local
|
3697 | 3867 |
permissions are ignored.
|
3698 | 3868 |
|
|
3869 |
=item overwrite =E<gt> 0
|
|
3870 |
|
|
3871 |
by default C<put> will overwrite any pre-existent file with the same
|
|
3872 |
name at the remote side. Setting this flag to zero will make the
|
|
3873 |
method fail in that case.
|
|
3874 |
|
|
3875 |
=item numbered =E<gt> 1
|
|
3876 |
|
|
3877 |
when required, adds a sequence number to local file names in order to
|
|
3878 |
avoid overwriting pre-existent files. Off by default.
|
|
3879 |
|
3699 | 3880 |
=item append =E<gt> 1
|
3700 | 3881 |
|
3701 | 3882 |
appends the local file at the end of the remote file instead of
|
3702 | 3883 |
overwriting it. If the remote file does not exist a new one is
|
3703 | |
created.
|
|
3884 |
created. Off by default.
|
3704 | 3885 |
|
3705 | 3886 |
=item resume =E<gt> 1 | 'auto'
|
3706 | 3887 |
|
|
3708 | 3889 |
|
3709 | 3890 |
If the C<auto> value is given, the transfer will be resumed only when
|
3710 | 3891 |
the remote file is newer than the local one.
|
|
3892 |
|
|
3893 |
=item atomic =E<gt> 1
|
|
3894 |
|
|
3895 |
The local file contents are transferred into a temporal file that
|
|
3896 |
once the copy completes is renamed to the target destination.
|
|
3897 |
|
|
3898 |
This operation relies on the SSH server to perform an
|
|
3899 |
overwriting/non-overwritting atomic rename operation free of race
|
|
3900 |
conditions.
|
|
3901 |
|
|
3902 |
OpenSSH server does it correctly on top of Linux/UNIX native file
|
|
3903 |
systems (i.e. ext[234], ffs or zfs) but has problems on file systems
|
|
3904 |
not supporting hard links (i.e. FAT) or on operating systems with
|
|
3905 |
broken POSIX semantics as Windows.
|
|
3906 |
|
|
3907 |
=item cleanup =E<gt> 1
|
|
3908 |
|
|
3909 |
If the transfer fails, attempts to remove the incomplete file.
|
|
3910 |
|
|
3911 |
Cleanup may fail if for example the SSH connection gets broken.
|
|
3912 |
|
|
3913 |
This option is set to by default when there is not possible to resume
|
|
3914 |
the transfer afterwards (i.e., when using `atomic` or `numbered`
|
|
3915 |
options).
|
|
3916 |
|
3711 | 3917 |
|
3712 | 3918 |
=item conversion =E<gt> $conversion
|
3713 | 3919 |
|
|
3738 | 3944 |
|
3739 | 3945 |
=item block_size =E<gt> $bytes
|
3740 | 3946 |
|
3741 | |
size of the blocks the file is being splittered on for
|
3742 | |
transfer. Incrementing this value can improve performance but some
|
3743 | |
servers limit its size and if this limit is overpassed the command
|
3744 | |
will fail.
|
|
3947 |
size of the blocks the file is being split on for transfer.
|
|
3948 |
Incrementing this value can improve performance but some servers limit
|
|
3949 |
its size and if this limit is overpassed the command will fail.
|
3745 | 3950 |
|
3746 | 3951 |
=item queue_size =E<gt> $size
|
3747 | 3952 |
|
|
3797 | 4002 |
|
3798 | 4003 |
=item wanted =E<gt> qr/.../
|
3799 | 4004 |
|
3800 | |
Only elements which filename match the regular expression are included
|
|
4005 |
Only elements whose filename matchs the regular expression are included
|
3801 | 4006 |
on the listing.
|
3802 | 4007 |
|
3803 | 4008 |
=item wanted =E<gt> sub {...}
|
|
4083 | 4288 |
|
4084 | 4289 |
=item numbered =E<gt> $bool
|
4085 | 4290 |
|
4086 | |
when required adds a sequence number to local file names in order to
|
4087 | |
avoid overwriting already existent files. Off by default.
|
|
4291 |
when required, adds a sequence number to local file names in order to
|
|
4292 |
avoid overwriting pre-existent remote files. Off by default.
|
4088 | 4293 |
|
4089 | 4294 |
=item newer_only =E<gt> $bool
|
4090 | 4295 |
|
|
4111 | 4316 |
it is not possible to copy child files without creating the directory
|
4112 | 4317 |
first!).
|
4113 | 4318 |
|
|
4319 |
=item atomic =E<gt> 1
|
|
4320 |
|
4114 | 4321 |
=item block_size =E<gt> $block_size
|
4115 | 4322 |
|
4116 | 4323 |
=item queue_size =E<gt> $queue_size
|
|
4178 | 4385 |
If a directory is discarded all of its contents are also discarded (as
|
4179 | 4386 |
it is not possible to copy child files without creating the directory
|
4180 | 4387 |
first!).
|
|
4388 |
|
|
4389 |
=item atomic =E<gt> 1
|
4181 | 4390 |
|
4182 | 4391 |
=item block_size =E<gt> $block_size
|
4183 | 4392 |
|
|
4609 | 4818 |
|
4610 | 4819 |
=item conversion =E<gt> 'dos2unix'
|
4611 | 4820 |
|
4612 | |
Converts LF+CR line endings (as commonly used under MS-DOS) to LF
|
|
4821 |
Converts CR+LF line endings (as commonly used under MS-DOS) to LF
|
4613 | 4822 |
(Unix).
|
4614 | 4823 |
|
4615 | 4824 |
=item conversion =E<gt> 'unix2dos'
|
4616 | 4825 |
|
4617 | |
Converts LF line endings (Unix) to LF+CR (DOS).
|
|
4826 |
Converts LF line endings (Unix) to CR+LF (DOS).
|
4618 | 4827 |
|
4619 | 4828 |
=item conversion =E<gt> sub { CONVERT $_[0] }
|
4620 | 4829 |
|
4621 | |
When a callback is given, it is called repeatly as chunks of data
|
|
4830 |
When a callback is given, it is invoked repeatly as chunks of data
|
4622 | 4831 |
become available. It has to change C<$_[0]> in place in order to
|
4623 | 4832 |
perform the conversion.
|
4624 | 4833 |
|
|
4826 | 5035 |
|
4827 | 5036 |
=item - Doesn't work on VMS:
|
4828 | 5037 |
|
4829 | |
The problem is related to L<IPC::Open2> not working on VMS. Patches
|
|
5038 |
The problem is related to L<IPC::Open3> not working on VMS. Patches
|
4830 | 5039 |
are welcome!
|
4831 | 5040 |
|
4832 | 5041 |
=item - Dirty cleanup:
|
|
4848 | 5057 |
interacting with SFTP servers that follow the SFTP specification, the
|
4849 | 5058 |
C<symlink> method will interpret its arguments in reverse order.
|
4850 | 5059 |
|
|
5060 |
=item - IPC::Open3 bugs on Windows
|
|
5061 |
|
|
5062 |
On Windows the IPC::Open3 module is used to spawn the slave SSH
|
|
5063 |
process. That module has several nasty bugs (related to STDIN, STDOUT
|
|
5064 |
and STDERR being closed or not being assigned to file descriptors 0, 1
|
|
5065 |
and 2 respectively) that will cause the connection to fail.
|
|
5066 |
|
|
5067 |
Specifically this is known to happen under mod_perl/mod_perl2.
|
|
5068 |
|
4851 | 5069 |
=back
|
4852 | 5070 |
|
4853 | 5071 |
Also, the following features should be considered experimental:
|
4854 | 5072 |
|
4855 | 5073 |
- support for Tectia server
|
4856 | |
|
4857 | |
- redirecting SSH stderr stream
|
4858 | |
|
4859 | |
- multi-backend support
|
4860 | 5074 |
|
4861 | 5075 |
- numbered feature
|
4862 | 5076 |
|
|
4896 | 5110 |
L<Net::OpenSSH>.
|
4897 | 5111 |
|
4898 | 5112 |
L<Net::SFTP::Foreign::Backend::Net_SSH2> allows to run
|
4899 | |
Net::SFTP::Foreign on top of L<Net::SSH2>.
|
|
5113 |
Net::SFTP::Foreign on top of L<Net::SSH2> (nowadays, this combination
|
|
5114 |
is probably the best option under Windows).
|
4900 | 5115 |
|
4901 | 5116 |
Modules offering similar functionality available from CPAN are
|
4902 | 5117 |
L<Net::SFTP> and L<Net::SSH2>.
|