App-SimpleBackuper
view release on metacpan or search on metacpan
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
package Net::SFTP::Foreign;
our $VERSION = '1.93';
use strict;
use warnings;
use warnings::register;
use Carp qw(carp croak);
use Symbol ();
use Errno ();
use Fcntl;
use File::Spec ();
use Time::HiRes ();
use POSIX ();
BEGIN {
if ($] >= 5.008) {
require Encode;
}
else {
# Work around for incomplete Unicode handling in perl 5.6.x
require bytes;
bytes->import();
*Encode::encode = sub { $_[1] };
*Encode::decode = sub { $_[1] };
*utf8::downgrade = sub { 1 };
}
}
# we make $Net::SFTP::Foreign::Helpers::debug an alias for
# $Net::SFTP::Foreign::debug so that the user can set it without
# knowing anything about the Helpers package!
our $debug;
BEGIN { *Net::SFTP::Foreign::Helpers::debug = \$debug };
use Net::SFTP::Foreign::Helpers qw(_is_reg _is_lnk _is_dir _debug
_sort_entries _gen_wanted
_gen_converter _hexdump
_ensure_list _catch_tainted_args
_file_part _umask_save_and_set
_untaint);
use Net::SFTP::Foreign::Constants qw( :fxp :flags :att
:status :error
SSH2_FILEXFER_VERSION );
use Net::SFTP::Foreign::Attributes;
use Net::SFTP::Foreign::Buffer;
require Net::SFTP::Foreign::Common;
our @ISA = qw(Net::SFTP::Foreign::Common);
our $dirty_cleanup;
my $windows;
BEGIN {
$windows = $^O =~ /Win(?:32|64)/;
if ($^O =~ /solaris/i) {
$dirty_cleanup = 1 unless defined $dirty_cleanup;
}
}
my $thread_generation = 1;
sub CLONE { $thread_generation++ }
sub _deprecated {
if (warnings::enabled('deprecated') and warnings::enabled(__PACKAGE__)) {
Carp::carp(join('', @_));
}
}
sub _next_msg_id { shift->{_msg_id}++ }
use constant _empty_attributes => Net::SFTP::Foreign::Attributes->new;
sub _queue_new_msg {
my $sftp = shift;
my $code = shift;
my $id = $sftp->_next_msg_id;
$sftp->{incomming}{$id} = undef;
my $msg = Net::SFTP::Foreign::Buffer->new(int8 => $code, int32 => $id, @_);
$sftp->_queue_msg($msg);
return $id;
}
sub _queue_msg {
my ($sftp, $buf) = @_;
my $bytes = $buf->bytes;
my $len = length $bytes;
if ($debug and $debug & 1) {
$sftp->{_queued}++;
_debug(sprintf("queueing msg len: %i, code:%i, id:%i ... [$sftp->{_queued}]",
$len, unpack(CN => $bytes)));
$debug & 16 and _hexdump(pack('N', length($bytes)) . $bytes);
}
$sftp->{_bout} .= pack('N', length($bytes));
$sftp->{_bout} .= $bytes;
}
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
$sftp->{_error} or
$sftp->_set_error((defined $err ? $err : SFTP_ERR_CONNECTION_BROKEN),
(@str ? @str : "Connection to remote server is broken"));
undef $sftp->{_connected};
}
sub _conn_failed {
my $sftp = shift;
$sftp->_conn_lost(SSH2_FX_NO_CONNECTION,
SFTP_ERR_CONNECTION_BROKEN,
@_)
unless $sftp->{_error};
}
sub _get_msg {
my $sftp = shift;
$debug and $debug & 1 and _debug("waiting for message... [$sftp->{_queued}]");
unless ($sftp->_do_io($sftp->{_timeout})) {
$sftp->_conn_lost(undef, undef, "Connection to remote server stalled");
return undef;
}
my $bin = \$sftp->{_bin};
my $len = unpack N => substr($$bin, 0, 4, '');
my $msg = Net::SFTP::Foreign::Buffer->make(substr($$bin, 0, $len, ''));
if ($debug and $debug & 1) {
$sftp->{_queued}--;
my ($code, $id, $status) = unpack( CNN => $$msg);
$id = '-' if $code == SSH2_FXP_VERSION;
$status = '-' unless $code == SSH2_FXP_STATUS;
_debug(sprintf("got it!, len:%i, code:%i, id:%s, status: %s",
$len, $code, $id, $status));
$debug & 8 and _hexdump($$msg);
}
return $msg;
}
sub _croak_bad_options {
if (@_) {
my $s = (@_ > 1 ? 's' : '');
croak "Invalid option$s '" . CORE::join("', '", @_) . "' or bad combination of options";
}
}
sub _fs_encode {
my ($sftp, $path) = @_;
Encode::encode($sftp->{_fs_encoding}, $path);
}
sub _fs_decode {
my ($sftp, $path) = @_;
Encode::decode($sftp->{_fs_encoding}, $path);
}
sub new {
${^TAINT} and &_catch_tainted_args;
my $class = shift;
unshift @_, 'host' if @_ & 1;
my %opts = @_;
my $sftp = { _msg_id => 0,
_bout => '',
_bin => '',
_connected => 1,
_queued => 0,
_error => 0,
_status => 0,
_incomming => {} };
bless $sftp, $class;
if ($debug) {
_debug "This is Net::SFTP::Foreign $Net::SFTP::Foreign::VERSION";
_debug "Loaded from $INC{'Net/SFTP/Foreign.pm'}";
_debug "Running on Perl $^V for $^O";
_debug "debug set to $debug";
_debug "~0 is " . ~0;
}
$sftp->_clear_error_and_status;
my $backend = delete $opts{backend};
unless (ref $backend) {
$backend = ($windows ? 'Windows' : 'Unix')
unless (defined $backend);
$backend =~ /^\w+$/
or croak "Bad backend name $backend";
my $backend_class = "Net::SFTP::Foreign::Backend::$backend";
eval "require $backend_class; 1"
or croak "Unable to load backend $backend: $@";
$backend = $backend_class->_new($sftp, \%opts);
}
$sftp->{_backend} = $backend;
if ($debug) {
my $class = ref($backend) || $backend;
no strict 'refs';
my $version = ${$class .'::VERSION'} || 0;
_debug "Using backend $class $version";
}
my %defs = $backend->_defaults;
$sftp->{_autodie} = delete $opts{autodie};
$sftp->{_block_size} = delete $opts{block_size} || $defs{block_size} || 32*1024;
$sftp->{_min_block_size} = delete $opts{min_block_size} || $defs{min_block_size} || 512;
$sftp->{_queue_size} = delete $opts{queue_size} || $defs{queue_size} || 32;
$sftp->{_read_ahead} = $defs{read_ahead} || $sftp->{_block_size} * 4;
$sftp->{_write_delay} = $defs{write_delay} || $sftp->{_block_size} * 8;
$sftp->{_autoflush} = delete $opts{autoflush};
$sftp->{_late_set_perm} = delete $opts{late_set_perm};
$sftp->{_dirty_cleanup} = delete $opts{dirty_cleanup};
$sftp->{_remote_has_volumes} = delete $opts{remote_has_volumes};
$sftp->{_timeout} = delete $opts{timeout};
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
sub _rid {
my ($sftp, $rfh) = @_;
my $rid = $rfh->_rid;
unless (defined $rid) {
$sftp->_set_error(SFTP_ERR_REMOTE_ACCESING_CLOSED_FILE,
"Couldn't access a file that has been previosly closed");
}
$rid
}
sub _rfid {
$_[1]->_check_is_file;
&_rid;
}
sub _rdid {
$_[1]->_check_is_dir;
&_rid;
}
sub _queue_rid_request {
my ($sftp, $code, $fh, $attrs) = @_;
my $rid = $sftp->_rid($fh);
return undef unless defined $rid;
$sftp->_queue_new_msg($code, str => $rid,
(defined $attrs ? (attr => $attrs) : ()));
}
sub _queue_rfid_request {
$_[2]->_check_is_file;
&_queue_rid_request;
}
sub _queue_rdid_request {
$_[2]->_check_is_dir;
&_queue_rid_request;
}
sub _queue_str_request {
my($sftp, $code, $str, $attrs) = @_;
$sftp->_queue_new_msg($code, str => $str,
(defined $attrs ? (attr => $attrs) : ()));
}
sub _check_status_ok {
my ($sftp, $eid, $error, $errstr) = @_;
if (defined $eid) {
if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_STATUS, $eid,
$error, $errstr)) {
my $status = $sftp->_set_status($msg->get_int32, $msg->get_str);
return 1 if $status == SSH2_FX_OK;
$sftp->_set_error($error, $errstr, $status);
}
}
return undef;
}
sub setcwd {
${^TAINT} and &_catch_tainted_args;
my ($sftp, $cwd, %opts) = @_;
$sftp->_clear_error_and_status;
my $check = delete $opts{check};
$check = 1 unless defined $check;
%opts and _croak_bad_options(keys %opts);
if (defined $cwd) {
if ($check) {
$cwd = $sftp->realpath($cwd);
return undef unless defined $cwd;
_untaint($cwd);
my $a = $sftp->stat($cwd)
or return undef;
unless (_is_dir($a->perm)) {
$sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,
"Remote object '$cwd' is not a directory");
return undef;
}
}
else {
$cwd = $sftp->_rel2abs($cwd);
}
return $sftp->{cwd} = $cwd;
}
else {
delete $sftp->{cwd};
return $sftp->cwd if defined wantarray;
}
}
sub cwd {
@_ == 1 or croak 'Usage: $sftp->cwd()';
my $sftp = shift;
return defined $sftp->{cwd} ? $sftp->{cwd} : $sftp->realpath('');
}
## SSH2_FXP_OPEN (3)
# returns handle on success, undef on failure
sub open {
(@_ >= 2 and @_ <= 4)
or croak 'Usage: $sftp->open($path [, $flags [, $attrs]])';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $path, $flags, $a) = @_;
$path = $sftp->_rel2abs($path);
defined $flags or $flags = SSH2_FXF_READ;
defined $a or $a = Net::SFTP::Foreign::Attributes->new;
my $id = $sftp->_queue_new_msg(SSH2_FXP_OPEN,
str => $sftp->_fs_encode($path),
int32 => $flags, attr => $a);
my $rid = $sftp->_get_handle($id,
SFTP_ERR_REMOTE_OPEN_FAILED,
"Couldn't open remote file '$path'");
if ($debug and $debug & 2) {
if (defined $rid) {
_debug("new remote file '$path' open, rid:");
_hexdump($rid);
}
else {
_debug("open failed: $sftp->{_status}");
}
}
defined $rid or return undef;
my $fh = Net::SFTP::Foreign::FileHandle->_new_from_rid($sftp, $rid);
$fh->_flag(append => 1) if ($flags & SSH2_FXF_APPEND);
$fh;
}
sub _open_mkpath {
my ($sftp, $filename, $mkpath, $flags, $attrs) = @_;
$flags = ($flags || 0) | SSH2_FXF_WRITE|SSH2_FXF_CREAT;
my $fh = do {
local $sftp->{_autodie};
$sftp->open($filename, $flags, $attrs);
};
unless ($fh) {
if ($mkpath and $sftp->status == SSH2_FX_NO_SUCH_FILE) {
my $da = $attrs->clone;
$da->set_perm(($da->perm || 0) | 0700);
$sftp->mkpath($filename, $da, 1) or return;
$fh = $sftp->open($filename, $flags, $attrs);
}
else {
$sftp->_ok_or_autodie;
}
}
$fh;
}
## SSH2_FXP_OPENDIR (11)
sub opendir {
@_ <= 2 or croak 'Usage: $sftp->opendir($path)';
${^TAINT} and &_catch_tainted_args;
my $sftp = shift;
my $path = shift;
$path = '.' unless defined $path;
$path = $sftp->_rel2abs($path);
my $id = $sftp->_queue_str_request(SSH2_FXP_OPENDIR, $sftp->_fs_encode($path), @_);
my $rid = $sftp->_get_handle($id, SFTP_ERR_REMOTE_OPENDIR_FAILED,
"Couldn't open remote dir '$path'");
if ($debug and $debug & 2) {
_debug("new remote dir '$path' open, rid:");
_hexdump($rid);
}
defined $rid
or return undef;
Net::SFTP::Foreign::DirHandle->_new_from_rid($sftp, $rid, 0)
}
## SSH2_FXP_READ (4)
# returns data on success undef on failure
sub sftpread {
(@_ >= 3 and @_ <= 4)
or croak 'Usage: $sftp->sftpread($fh, $offset [, $size])';
my ($sftp, $rfh, $offset, $size) = @_;
unless ($size) {
return '' if defined $size;
$size = $sftp->{_block_size};
}
my $rfid = $sftp->_rfid($rfh);
defined $rfid or return undef;
my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
int64 => $offset, int32 => $size);
if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_DATA, $id,
SFTP_ERR_REMOTE_READ_FAILED,
"Couldn't read from remote file")) {
return $msg->get_str;
}
return undef;
}
## SSH2_FXP_WRITE (6)
# returns true on success, undef on failure
sub sftpwrite {
@_ == 4 or croak 'Usage: $sftp->sftpwrite($fh, $offset, $data)';
my ($sftp, $rfh, $offset) = @_;
my $rfid = $sftp->_rfid($rfh);
defined $rfid or return undef;
utf8::downgrade($_[3], 1) or croak "wide characters found in data";
my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
int64 => $offset, str => $_[3]);
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
$last = length $$bin;
$sftp->_fill_read_cache($rfh, length($$bin) + 1);
unless (length $$bin > $last) {
$sftp->{_error}
and return undef;
my $line = $$bin;
$rfh->_inc_pos(length $line);
$$bin = '';
return (length $line ? $line : undef);
}
}
}
sub readline {
(@_ >= 2 and @_ <= 3)
or croak 'Usage: $sftp->readline($fh [, $sep])';
my ($sftp, $rfh, $sep) = @_;
$sep = "\n" if @_ < 3;
if (!defined $sep or $sep eq '') {
$sftp->_fill_read_cache($rfh);
$sftp->{_error}
and return undef;
my $bin = $rfh->_bin;
my $line = $$bin;
$rfh->_inc_pos(length $line);
$$bin = '';
return $line;
}
if (wantarray) {
my @lines;
while (defined (my $line = $sftp->_readline($rfh, $sep))) {
push @lines, $line;
}
return @lines;
}
return $sftp->_readline($rfh, $sep);
}
sub getc {
@_ == 2 or croak 'Usage: $sftp->getc($fh)';
my ($sftp, $rfh) = @_;
$sftp->_fill_read_cache($rfh, 1);
my $bin = $rfh->_bin;
if (length $bin) {
$rfh->_inc_pos(1);
return substr $$bin, 0, 1, '';
}
return undef;
}
## SSH2_FXP_LSTAT (7), SSH2_FXP_FSTAT (8), SSH2_FXP_STAT (17)
# these all return a Net::SFTP::Foreign::Attributes object on success, undef on failure
sub lstat {
@_ <= 2 or croak 'Usage: $sftp->lstat($path)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $path) = @_;
$path = '.' unless defined $path;
$path = $sftp->_rel2abs($path);
my $id = $sftp->_queue_str_request(SSH2_FXP_LSTAT, $sftp->_fs_encode($path));
if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_ATTRS, $id,
SFTP_ERR_REMOTE_LSTAT_FAILED, "Couldn't stat remote link")) {
return $msg->get_attributes;
}
return undef;
}
sub stat {
@_ <= 2 or croak 'Usage: $sftp->stat($path_or_fh)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $pofh) = @_;
$pofh = '.' unless defined $pofh;
my $id = $sftp->_queue_new_msg( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle'))
? ( SSH2_FXP_FSTAT, str => $sftp->_rid($pofh))
: ( SSH2_FXP_STAT, str => $sftp->_fs_encode($sftp->_rel2abs($pofh))) );
if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_ATTRS, $id,
SFTP_ERR_REMOTE_STAT_FAILED, "Couldn't stat remote file")) {
return $msg->get_attributes;
}
return undef;
}
sub fstat {
_deprecated "fstat is deprecated and will be removed on the upcoming 2.xx series, "
. "stat method accepts now both file handlers and paths";
goto &stat;
}
## SSH2_FXP_RMDIR (15), SSH2_FXP_REMOVE (13)
# these return true on success, undef on failure
sub _gen_remove_method {
my($name, $code, $error, $errstr) = @_;
my $sub = sub {
@_ == 2 or croak "Usage: \$sftp->$name(\$path)";
${^TAINT} and &_catch_tainted_args;
my ($sftp, $path) = @_;
$path = $sftp->_rel2abs($path);
my $id = $sftp->_queue_str_request($code, $sftp->_fs_encode($path));
$sftp->_check_status_ok($id, $error, $errstr);
};
no strict 'refs';
*$name = $sub;
}
_gen_remove_method(remove => SSH2_FXP_REMOVE,
SFTP_ERR_REMOTE_REMOVE_FAILED, "Couldn't delete remote file");
_gen_remove_method(rmdir => SSH2_FXP_RMDIR,
SFTP_ERR_REMOTE_RMDIR_FAILED, "Couldn't remove remote directory");
## SSH2_FXP_MKDIR (14), SSH2_FXP_SETSTAT (9)
# these return true on success, undef on failure
sub mkdir {
(@_ >= 2 and @_ <= 3)
or croak 'Usage: $sftp->mkdir($path [, $attrs])';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $path, $attrs) = @_;
$attrs = _empty_attributes unless defined $attrs;
$path = $sftp->_rel2abs($path);
my $id = $sftp->_queue_str_request(SSH2_FXP_MKDIR,
$sftp->_fs_encode($path),
$attrs);
$sftp->_check_status_ok($id,
SFTP_ERR_REMOTE_MKDIR_FAILED,
"Couldn't create remote directory");
}
sub join {
my $sftp = shift;
my $vol = '';
my $a = '.';
while (@_) {
my $b = shift;
if (defined $b) {
if (ref $sftp and # this method can also be used as a static one
$sftp->{_remote_has_volumes} and $b =~ /^([a-z]\:)(.*)/i) {
$vol = $1;
$a = '.';
$b = $2;
}
$b =~ s|^(?:\./+)+||;
if (length $b and $b ne '.') {
if ($b !~ m|^/| and $a ne '.' ) {
$a = ($a =~ m|/$| ? "$a$b" : "$a/$b");
}
else {
$a = $b
}
$a =~ s|(?:/+\.)+/?$|/|;
$a =~ s|(?<=[^/])/+$||;
$a = '.' unless length $a;
}
}
}
"$vol$a";
}
sub _rel2abs {
my ($sftp, $path) = @_;
my $old = $path;
my $cwd = $sftp->{cwd};
$path = $sftp->join($sftp->{cwd}, $path);
$debug and $debug & 4096 and _debug("'$old' --> '$path'");
return $path
}
sub mkpath {
(@_ >= 2 and @_ <= 4)
or croak 'Usage: $sftp->mkpath($path [, $attrs [, $parent]])';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $path, $attrs, $parent) = @_;
$sftp->_clear_error_and_status;
my $first = !$parent; # skips file name
$path =~ s{^(/*)}{};
my $start = $1;
$path =~ s{/+$}{};
my @path;
while (1) {
if ($first) {
$first = 0
}
else {
$path =~ s{/*[^/]*$}{}
}
my $p = "$start$path";
$debug and $debug & 8192 and _debug "checking $p";
if ($sftp->test_d($p)) {
$debug and $debug & 8192 and _debug "$p is a dir";
last;
}
unless (length $path) {
$sftp->_set_error(SFTP_ERR_REMOTE_MKDIR_FAILED,
"Unable to make path, bad root");
return undef;
}
unshift @path, $p;
}
for my $p (@path) {
$debug and $debug & 8192 and _debug "mkdir $p";
if ($p =~ m{^(?:.*/)?\.{1,2}$} or $p =~ m{/$}) {
$debug and $debug & 8192 and _debug "$p is a symbolic dir, skipping";
unless ($sftp->test_d($p)) {
$debug and $debug & 8192 and _debug "symbolic dir $p can not be checked";
$sftp->{_error} or
$sftp->_set_error(SFTP_ERR_REMOTE_MKDIR_FAILED,
"Unable to make path, bad name");
return undef;
}
}
else {
$sftp->mkdir($p, $attrs)
or return undef;
}
}
1;
}
sub _mkpath_local {
my ($sftp, $path, $perm, $parent) = @_;
# When parent is set, the last path part is removed and the parent
# directory of the path given created.
my @parts = File::Spec->splitdir($path);
$debug and $debug & 32768 and _debug "_mkpath_local($path, $perm, ".($parent||0).")";
if ($parent) {
pop @parts while @parts and not length $parts[-1];
unless (@parts) {
$sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED,
"mkpath failed, top dir reached");
return;
}
pop @parts;
}
my @tail;
while (@parts) {
my $target = File::Spec->catdir(@parts);
if (-e $target) {
unless (-d $target) {
$sftp->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT,
"Local file '$target' is not a directory");
return;
}
last
}
unshift @tail, pop @parts;
}
while (@tail) {
push @parts, shift @tail;
my $target = File::Spec->catdir(@parts);
$debug and $debug and 32768 and _debug "creating local directory '$target'";
unless (CORE::mkdir $target, $perm) {
unless (do { local $!; -d $target}) {
$sftp->_set_error(SFTP_ERR_LOCAL_MKDIR_FAILED,
"mkdir '$target' failed", $!);
return;
}
}
}
$debug and $debug & 32768 and _debug "_mkpath_local succeeded";
return 1;
}
sub setstat {
@_ == 3 or croak 'Usage: $sftp->setstat($path_or_fh, $attrs)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $pofh, $attrs) = @_;
my $id = $sftp->_queue_new_msg( ( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle') )
? ( SSH2_FXP_FSETSTAT, str => $sftp->_rid($pofh) )
: ( SSH2_FXP_SETSTAT, str => $sftp->_fs_encode($sftp->_rel2abs($pofh)) ) ),
attr => $attrs );
return $sftp->_check_status_ok($id,
SFTP_ERR_REMOTE_SETSTAT_FAILED,
"Couldn't setstat remote file");
}
## SSH2_FXP_CLOSE (4), SSH2_FXP_FSETSTAT (10)
# these return true on success, undef on failure
sub fsetstat {
_deprecated "fsetstat is deprecated and will be removed on the upcoming 2.xx series, "
. "setstat method accepts now both file handlers and paths";
goto &setstat;
}
sub _gen_setstat_shortcut {
my ($name, $rid_type, $attrs_flag, @arg_types) = @_;
my $nargs = 2 + @arg_types;
my $usage = ("\$sftp->$name("
. CORE::join(', ', '$path_or_fh', map "arg$_", 1..@arg_types)
. ')');
my $rid_method = ($rid_type eq 'file' ? '_rfid' :
$rid_type eq 'dir' ? '_rdid' :
$rid_type eq 'any' ? '_rid' :
croak "bad rid type $rid_type");
my $sub = sub {
@_ == $nargs or croak $usage;
my $sftp = shift;
my $pofh = shift;
my $id = $sftp->_queue_new_msg( ( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle') )
? ( SSH2_FXP_FSETSTAT, str => $sftp->$rid_method($pofh) )
: ( SSH2_FXP_SETSTAT, str => $sftp->_fs_encode($sftp->_rel2abs($pofh)) ) ),
int32 => $attrs_flag,
map { $arg_types[$_] => $_[$_] } 0..$#arg_types );
$sftp->_check_status_ok($id,
SFTP_ERR_REMOTE_SETSTAT_FAILED,
"Couldn't setstat remote file ($name)");
};
no strict 'refs';
*$name = $sub;
}
_gen_setstat_shortcut(truncate => 'file', SSH2_FILEXFER_ATTR_SIZE, 'int64');
_gen_setstat_shortcut(chown => 'any' , SSH2_FILEXFER_ATTR_UIDGID, 'int32', 'int32');
_gen_setstat_shortcut(chmod => 'any' , SSH2_FILEXFER_ATTR_PERMISSIONS, 'int32');
_gen_setstat_shortcut(utime => 'any' , SSH2_FILEXFER_ATTR_ACMODTIME, 'int32', 'int32');
sub _close {
@_ == 2 or croak 'Usage: $sftp->close($fh, $attrs)';
my $sftp = shift;
my $id = $sftp->_queue_rid_request(SSH2_FXP_CLOSE, @_);
defined $id or return undef;
my $ok = $sftp->_check_status_ok($id,
SFTP_ERR_REMOTE_CLOSE_FAILED,
"Couldn't close remote file");
if ($debug and $debug & 2) {
_debug sprintf("closing file handle, return: %s, rid:", (defined $ok ? $ok : '-'));
_hexdump($sftp->_rid($_[0]));
}
return $ok;
}
sub close {
@_ == 2 or croak 'Usage: $sftp->close($fh)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $rfh) = @_;
# defined $sftp->_rfid($rfh) or return undef;
# ^--- commented out because flush already checks it is an open file
$sftp->flush($rfh)
or return undef;
if ($sftp->_close($rfh)) {
$rfh->_close;
return 1
}
undef
}
sub closedir {
@_ == 2 or croak 'Usage: $sftp->closedir($dh)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $rdh) = @_;
$rdh->_check_is_dir;
if ($sftp->_close($rdh)) {
$rdh->_close;
return 1;
}
undef
}
sub readdir {
@_ == 2 or croak 'Usage: $sftp->readdir($dh)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $rdh) = @_;
my $rdid = $sftp->_rdid($rdh);
defined $rdid or return undef;
my $cache = $rdh->_cache;
while (!@$cache or wantarray) {
my $id = $sftp->_queue_str_request(SSH2_FXP_READDIR, $rdid);
if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id,
SFTP_ERR_REMOTE_READDIR_FAILED,
"Couldn't read remote directory" )) {
my $count = $msg->get_int32 or last;
for (1..$count) {
push @$cache, { filename => $sftp->_fs_decode($msg->get_str),
longname => $sftp->_fs_decode($msg->get_str),
a => $msg->get_attributes };
}
}
else {
$sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF;
last;
}
}
if (wantarray) {
my $old = $cache;
$cache = [];
return @$old;
}
shift @$cache;
}
sub _readdir {
my ($sftp, $rdh);
if (wantarray) {
my $line = $sftp->readdir($rdh);
if (defined $line) {
return $line->{filename};
}
}
else {
return map { $_->{filename} } $sftp->readdir($rdh);
}
}
sub _gen_getpath_method {
my ($code, $error, $name) = @_;
return sub {
@_ == 2 or croak 'Usage: $sftp->some_method($path)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $path) = @_;
$path = $sftp->_rel2abs($path);
my $id = $sftp->_queue_str_request($code, $sftp->_fs_encode($path));
if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id,
$error,
"Couldn't get $name for remote '$path'")) {
$msg->get_int32 > 0
and return $sftp->_fs_decode($msg->get_str);
$sftp->_set_error($error,
"Couldn't get $name for remote '$path', no names on reply")
}
return undef;
};
}
## SSH2_FXP_REALPATH (16)
## SSH2_FXP_READLINK (19)
# return path on success, undef on failure
*realpath = _gen_getpath_method(SSH2_FXP_REALPATH,
SFTP_ERR_REMOTE_REALPATH_FAILED,
"realpath");
*readlink = _gen_getpath_method(SSH2_FXP_READLINK,
SFTP_ERR_REMOTE_READLINK_FAILED,
"link target");
## SSH2_FXP_RENAME (18)
# true on success, undef on failure
sub _rename {
my ($sftp, $old, $new) = @_;
$old = $sftp->_rel2abs($old);
$new = $sftp->_rel2abs($new);
my $id = $sftp->_queue_new_msg(SSH2_FXP_RENAME,
str => $sftp->_fs_encode($old),
str => $sftp->_fs_encode($new));
$sftp->_check_status_ok($id, SFTP_ERR_REMOTE_RENAME_FAILED,
"Couldn't rename remote file '$old' to '$new'");
}
sub rename {
(@_ & 1) or croak 'Usage: $sftp->rename($old, $new, %opts)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $old, $new, %opts) = @_;
my $overwrite = delete $opts{overwrite};
my $numbered = delete $opts{numbered};
croak "'overwrite' and 'numbered' options can not be used together"
if ($overwrite and $numbered);
%opts and _croak_bad_options(keys %opts);
if ($overwrite) {
$sftp->atomic_rename($old, $new) and return 1;
$sftp->{_status} != SSH2_FX_OP_UNSUPPORTED and return undef;
}
for (1) {
local $sftp->{_autodie};
# we are optimistic here and try to rename it without testing
# if a file of the same name already exists first
if (!$sftp->_rename($old, $new) and
$sftp->{_status} == SSH2_FX_FAILURE) {
if ($numbered and $sftp->test_e($new)) {
_inc_numbered($new);
redo;
}
elsif ($overwrite) {
my $rp_old = $sftp->realpath($old);
my $rp_new = $sftp->realpath($new);
if (defined $rp_old and defined $rp_new and $rp_old eq $rp_new) {
$sftp->_clear_error_and_status;
}
elsif ($sftp->remove($new)) {
$overwrite = 0;
redo;
}
}
}
}
$sftp->_ok_or_autodie;
}
sub atomic_rename {
@_ == 3 or croak 'Usage: $sftp->atomic_rename($old, $new)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $old, $new) = @_;
$sftp->_check_extension('posix-rename@openssh.com' => 1,
SFTP_ERR_REMOTE_RENAME_FAILED,
"atomic rename failed")
or return undef;
$old = $sftp->_rel2abs($old);
$new = $sftp->_rel2abs($new);
my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED,
str => 'posix-rename@openssh.com',
str => $sftp->_fs_encode($old),
str => $sftp->_fs_encode($new));
$sftp->_check_status_ok($id, SFTP_ERR_REMOTE_RENAME_FAILED,
"Couldn't rename remote file '$old' to '$new'");
}
## SSH2_FXP_SYMLINK (20)
# true on success, undef on failure
sub symlink {
@_ == 3 or croak 'Usage: $sftp->symlink($sl, $target)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $sl, $target) = @_;
$sl = $sftp->_rel2abs($sl);
my $id = $sftp->_queue_new_msg(SSH2_FXP_SYMLINK,
str => $sftp->_fs_encode($target),
str => $sftp->_fs_encode($sl));
$sftp->_check_status_ok($id, SFTP_ERR_REMOTE_SYMLINK_FAILED,
"Couldn't create symlink '$sl' pointing to '$target'");
}
sub hardlink {
@_ == 3 or croak 'Usage: $sftp->hardlink($hl, $target)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $hl, $target) = @_;
$sftp->_check_extension('hardlink@openssh.com' => 1,
SFTP_ERR_REMOTE_HARDLINK_FAILED,
"hardlink failed")
or return undef;
$hl = $sftp->_rel2abs($hl);
$target = $sftp->_rel2abs($target);
my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED,
str => 'hardlink@openssh.com',
str => $sftp->_fs_encode($target),
str => $sftp->_fs_encode($hl));
$sftp->_check_status_ok($id, SFTP_ERR_REMOTE_HARDLINK_FAILED,
"Couldn't create hardlink '$hl' pointing to '$target'");
}
sub _gen_save_status_method {
my $method = shift;
sub {
my $sftp = shift;
local ($sftp->{_error}, $sftp->{_status}) if $sftp->{_error};
$sftp->$method(@_);
}
}
*_close_save_status = _gen_save_status_method('close');
*_closedir_save_status = _gen_save_status_method('closedir');
*_remove_save_status = _gen_save_status_method('remove');
sub _inc_numbered {
$_[0] =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e or
$_[0] =~ s{((?:\.[^\.]*)?)$}{(1)$1};
$debug and $debug & 128 and _debug("numbering to: $_[0]");
}
## High-level client -> server methods.
sub abort {
my $sftp = shift;
$sftp->_set_error(SFTP_ERR_ABORTED, ($@ ? $_[0] : "Aborted"));
}
# returns true on success, undef on failure
sub get {
@_ >= 2 or croak 'Usage: $sftp->get($remote, $local, %opts)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $remote, $local, %opts) = @_;
defined $remote or croak "remote file path is undefined";
$sftp->_clear_error_and_status;
$remote = $sftp->_rel2abs($remote);
$local = _file_part($remote) unless defined $local;
my $local_is_fh = (ref $local and $local->isa('GLOB'));
my $cb = delete $opts{callback};
my $umask = delete $opts{umask};
my $perm = delete $opts{perm};
my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
my $copy_time = delete $opts{copy_time};
my $overwrite = delete $opts{overwrite};
my $resume = delete $opts{resume};
my $append = delete $opts{append};
my $block_size = delete $opts{block_size} || $sftp->{_block_size};
my $queue_size = delete $opts{queue_size} || $sftp->{_queue_size};
my $dont_save = delete $opts{dont_save};
my $conversion = delete $opts{conversion};
my $numbered = delete $opts{numbered};
my $cleanup = delete $opts{cleanup};
my $atomic = delete $opts{atomic};
my $best_effort = delete $opts{best_effort};
my $mkpath = delete $opts{mkpath};
croak "'perm' and 'copy_perm' options can not be used simultaneously"
if (defined $perm and defined $copy_perm);
croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'"
if ($numbered and ($overwrite or $resume or $append));
if ($resume or $append) {
$resume and $append and croak "'resume' and 'append' options can not be used simultaneously";
$atomic and croak "'atomic' can not be used with 'resume' or 'append'";
$overwrite and croak "'overwrite' can not be used with 'resume' or 'append'";
}
if ($local_is_fh) {
my $tail = 'option can not be used when target is a file handle';
$resume and croak "'resume' $tail";
$overwrite and croak "'overwrite' $tail";
$numbered and croak "'numbered' $tail";
$dont_save and croak "'dont_save' $tail";
$atomic and croak "'croak' $tail";
}
%opts and _croak_bad_options(keys %opts);
if ($resume and $conversion) {
carp "resume option is useless when data conversion has also been requested";
undef $resume;
}
$overwrite = 1 unless (defined $overwrite or $local_is_fh or $numbered or $append);
$copy_perm = 1 unless (defined $perm or defined $copy_perm or $local_is_fh);
$copy_time = 1 unless (defined $copy_time or $local_is_fh);
$mkpath = 1 unless defined $mkpath;
$cleanup = ($atomic || $numbered) unless defined $cleanup;
my $a = do {
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
if (length($data) and !$dont_save) {
unless (print $fh $data) {
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
"unable to write data to local file $local", $!);
last;
}
}
}
$sftp->_get_msg_by_id($_) for @msgid;
goto CLEANUP if $sftp->{_error};
# if a converter is in place, and aditional call has to be
# performed in order to flush any pending buffered data
if ($converter) {
my $data = '';
my $adjustment_before = $adjustment;
$adjustment += $converter->($data);
if (length($data) and defined $cb) {
# $size = $loff if ($loff > $size and $size != -1);
local $\;
$cb->($sftp, $data, $askoff + $adjustment_before, $size + $adjustment);
goto CLEANUP if $sftp->{_error};
}
if (length($data) and !$dont_save) {
unless (print $fh $data) {
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
"unable to write data to local file $local", $!);
goto CLEANUP;
}
}
}
# we call the callback one last time with an empty string;
if (defined $cb) {
my $data = '';
do {
local $\;
$cb->($sftp, $data, $askoff + $adjustment, $size + $adjustment);
};
return undef if $sftp->{_error};
if (length($data) and !$dont_save) {
unless (print $fh $data) {
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
"unable to write data to local file $local", $!);
goto CLEANUP;
}
}
}
unless ($dont_save) {
unless ($local_is_fh or CORE::close $fh) {
$sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
"unable to write data to local file $local", $!);
goto CLEANUP;
}
# we can be running on taint mode, so some checks are
# performed to untaint data from the remote side.
if ($copy_time) {
unless (utime($atime, $mtime, $local) or $best_effort) {
$sftp->_set_error(SFTP_ERR_LOCAL_UTIME_FAILED,
"Can't utime $local", $!);
goto CLEANUP;
}
}
if ($atomic) {
if (!$overwrite) {
while (1) {
# performing a non-overwriting atomic rename is
# quite burdensome: first, link is tried, if that
# fails, non-overwriting is favoured over
# atomicity and an empty file is used to lock the
# path before atempting an overwriting rename.
if (link $local, $atomic_local) {
unlink $local;
last;
}
my $err = $!;
unless (-e $atomic_local) {
if (sysopen my $lock, $atomic_local,
Fcntl::O_CREAT|Fcntl::O_EXCL|Fcntl::O_WRONLY,
0600) {
$atomic_cleanup = 1;
goto OVERWRITE;
}
$err = $!;
unless (-e $atomic_local) {
$sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
"Can't open $local", $err);
goto CLEANUP;
}
}
unless ($numbered) {
$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
"local file $atomic_local already exists");
goto CLEANUP;
}
_inc_numbered($atomic_local);
}
}
else {
OVERWRITE:
unless (CORE::rename $local, $atomic_local) {
$sftp->_set_error(SFTP_ERR_LOCAL_RENAME_FAILED,
"Unable to rename temporal file to its final position '$atomic_local'", $!);
goto CLEANUP;
}
}
$$atomic_numbered = $local if ref $atomic_numbered;
}
}
CLEANUP:
if ($cleanup and $sftp->{_error}) {
unlink $local;
unlink $atomic_local if $atomic_cleanup;
}
}; # autodie flag is restored here!
$sftp->_ok_or_autodie;
}
# return file contents on success, undef on failure
sub get_content {
@_ == 2 or croak 'Usage: $sftp->get_content($remote)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $name) = @_;
#$name = $sftp->_rel2abs($name);
my @data;
my $rfh = $sftp->open($name)
or return undef;
scalar $sftp->readline($rfh, undef);
}
sub put {
@_ >= 2 or croak 'Usage: $sftp->put($local, $remote, %opts)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $local, $remote, %opts) = @_;
defined $local or croak "local file path is undefined";
$sftp->_clear_error_and_status;
my $local_is_fh = (ref $local and $local->isa('GLOB'));
unless (defined $remote) {
$local_is_fh and croak "unable to infer remote file name when a file handler is passed as local";
$remote = (File::Spec->splitpath($local))[2];
}
# $remote = $sftp->_rel2abs($remote);
my $cb = delete $opts{callback};
my $umask = delete $opts{umask};
my $perm = delete $opts{perm};
my $copy_perm = delete $opts{copy_perm};
$copy_perm = delete $opts{copy_perms} unless defined $copy_perm;
my $copy_time = delete $opts{copy_time};
my $overwrite = delete $opts{overwrite};
my $resume = delete $opts{resume};
my $append = delete $opts{append};
my $block_size = delete $opts{block_size} || $sftp->{_block_size};
my $queue_size = delete $opts{queue_size} || $sftp->{_queue_size};
my $conversion = delete $opts{conversion};
my $late_set_perm = delete $opts{late_set_perm};
my $numbered = delete $opts{numbered};
my $atomic = delete $opts{atomic};
my $cleanup = delete $opts{cleanup};
my $best_effort = delete $opts{best_effort};
my $sparse = delete $opts{sparse};
my $mkpath = delete $opts{mkpath};
croak "'perm' and 'umask' options can not be used simultaneously"
if (defined $perm and defined $umask);
croak "'perm' and 'copy_perm' options can not be used simultaneously"
if (defined $perm and $copy_perm);
croak "'resume' and 'append' options can not be used simultaneously"
if ($resume and $append);
croak "'resume' and 'overwrite' options can not be used simultaneously"
if ($resume and $overwrite);
croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'"
if ($numbered and ($overwrite or $resume or $append));
croak "'atomic' can not be used with 'resume' or 'append'"
if ($atomic and ($resume or $append));
%opts and _croak_bad_options(keys %opts);
$overwrite = 1 unless (defined $overwrite or $numbered);
$copy_perm = 1 unless (defined $perm or defined $copy_perm or $local_is_fh);
$copy_time = 1 unless (defined $copy_time or $local_is_fh);
$late_set_perm = $sftp->{_late_set_perm} unless defined $late_set_perm;
$cleanup = ($atomic || $numbered) unless defined $cleanup;
$mkpath = 1 unless defined $mkpath;
my $neg_umask;
if (defined $perm) {
$neg_umask = $perm;
}
else {
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
int64 => $writeoff, str => $data);
push @msgid, $id;
$last_block_was_zeros = 0;
}
$writeoff = $nextoff;
}
}
last if ($eof and !@msgid);
next unless ($eof
or @msgid >= $queue_size
or $sftp->_do_io(0));
my $id = shift @msgid;
unless ($sftp->_check_status_ok($id,
SFTP_ERR_REMOTE_WRITE_FAILED,
"Couldn't write to remote file")) {
last OK;
}
}
CORE::close $fh unless $local_is_fh;
$sftp->_get_msg_by_id($_) for @msgid;
$sftp->truncate($rfh, $writeoff)
if $last_block_was_zeros and not $sftp->{_error};
$sftp->_close_save_status($rfh);
goto CLEANUP if $sftp->{_error};
# set perm for servers that does not support setting
# permissions on open files and also atime and mtime:
if ($copy_time or ($late_set_perm and defined $perm)) {
$attrs->set_perm unless $late_set_perm and defined $perm;
$attrs->set_amtime($latime, $lmtime) if $copy_time;
$sftp->_best_effort($best_effort, setstat => $remote, $attrs) or goto CLEANUP
}
if ($atomic) {
$sftp->rename($remote, $atomic_remote,
overwrite => $overwrite,
numbered => $atomic_numbered) or goto CLEANUP;
}
CLEANUP:
if ($cleanup and $sftp->{_error}) {
warn "cleanup $remote";
$sftp->_remove_save_status($remote);
}
};
$sftp->_ok_or_autodie;
}
sub put_content {
@_ >= 3 or croak 'Usage: $sftp->put_content($content, $remote, %opts)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, undef, $remote, %opts) = @_;
my %put_opts = ( map { $_ => delete $opts{$_} }
qw(perm umask block_size queue_size overwrite conversion resume
numbered late_set_perm atomic best_effort mkpath));
%opts and _croak_bad_options(keys %opts);
my $fh;
unless (CORE::open $fh, '<', \$_[1]) {
$sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED, "Can't open scalar as file handle", $!);
return undef;
}
$sftp->put($fh, $remote, %put_opts);
}
sub ls {
@_ >= 1 or croak 'Usage: $sftp->ls($remote_dir, %opts)';
${^TAINT} and &_catch_tainted_args;
my $sftp = shift;
my %opts = @_ & 1 ? (dir => @_) : @_;
my $dir = delete $opts{dir};
my $ordered = delete $opts{ordered};
my $follow_links = delete $opts{follow_links};
my $atomic_readdir = delete $opts{atomic_readdir};
my $names_only = delete $opts{names_only};
my $realpath = delete $opts{realpath};
my $queue_size = delete $opts{queue_size};
my $cheap = ($names_only and !$realpath);
my ($cheap_wanted, $wanted);
if ($cheap and
ref $opts{wanted} eq 'Regexp' and
not defined $opts{no_wanted}) {
$cheap_wanted = delete $opts{wanted}
}
else {
$wanted = (delete $opts{_wanted} ||
_gen_wanted(delete $opts{wanted},
delete $opts{no_wanted}));
undef $cheap if defined $wanted;
}
%opts and _croak_bad_options(keys %opts);
my $delayed_wanted = ($atomic_readdir and $wanted);
$queue_size = 1 if ($follow_links or $realpath or
($wanted and not $delayed_wanted));
my $max_queue_size = $queue_size || $sftp->{_queue_size};
$queue_size ||= ($max_queue_size < 2 ? $max_queue_size : 2);
$dir = '.' unless defined $dir;
$dir = $sftp->_rel2abs($dir);
my $rdh = $sftp->opendir($dir);
return unless defined $rdh;
my $rdid = $sftp->_rdid($rdh);
defined $rdid or return undef;
my @dir;
my @msgid;
do {
local $sftp->{_autodie};
OK: while (1) {
push @msgid, $sftp->_queue_str_request(SSH2_FXP_READDIR, $rdid)
while (@msgid < $queue_size);
my $id = shift @msgid;
my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id,
SFTP_ERR_REMOTE_READDIR_FAILED,
"Couldn't read directory '$dir'" ) or last;
my $count = $msg->get_int32 or last;
if ($cheap) {
for (1..$count) {
my $fn = $sftp->_fs_decode($msg->get_str);
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
my $entry = { filename => $fn,
longname => $ln,
a => $a };
if ($follow_links and _is_lnk($a->perm)) {
if ($a = $sftp->stat($sftp->join($dir, $fn))) {
$entry->{a} = $a;
}
else {
$sftp->_clear_error_and_status;
}
}
if ($realpath) {
my $rp = $sftp->realpath($sftp->join($dir, $fn));
if (defined $rp) {
$fn = $entry->{realpath} = $rp;
}
else {
$sftp->_clear_error_and_status;
}
}
if (!$wanted or $delayed_wanted or $wanted->($sftp, $entry)) {
push @dir, (($names_only and !$delayed_wanted) ? $fn : $entry);
}
}
}
$queue_size++ if $queue_size < $max_queue_size;
}
$sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF;
$sftp->_get_msg_by_id($_) for @msgid;
$sftp->_closedir_save_status($rdh) if $rdh;
};
unless ($sftp->{_error}) {
if ($delayed_wanted) {
@dir = grep { $wanted->($sftp, $_) } @dir;
@dir = map { defined $_->{realpath}
? $_->{realpath}
: $_->{filename} } @dir
if $names_only;
}
if ($ordered) {
if ($names_only) {
@dir = sort @dir;
}
else {
_sort_entries \@dir;
}
}
return \@dir;
}
croak $sftp->{_error} if $sftp->{_autodie};
return undef;
}
sub rremove {
@_ >= 2 or croak 'Usage: $sftp->rremove($dirs, %opts)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $dirs, %opts) = @_;
my $on_error = delete $opts{on_error};
local $sftp->{_autodie} if $on_error;
my $wanted = _gen_wanted( delete $opts{wanted},
delete $opts{no_wanted});
%opts and _croak_bad_options(keys %opts);
my $count = 0;
my @dirs;
$sftp->find( $dirs,
on_error => $on_error,
atomic_readdir => 1,
wanted => sub {
my $e = $_[1];
my $fn = $e->{filename};
if (_is_dir($e->{a}->perm)) {
push @dirs, $e;
}
else {
if (!$wanted or $wanted->($sftp, $e)) {
if ($sftp->remove($fn)) {
$count++;
}
else {
$sftp->_call_on_error($on_error, $e);
}
}
}
} );
_sort_entries(\@dirs);
while (@dirs) {
my $e = pop @dirs;
if (!$wanted or $wanted->($sftp, $e)) {
if ($sftp->rmdir($e->{filename})) {
$count++;
}
else {
$sftp->_call_on_error($on_error, $e);
}
}
}
return $count;
}
sub get_symlink {
@_ >= 3 or croak 'Usage: $sftp->get_symlink($remote, $local, %opts)';
my ($sftp, $remote, $local, %opts) = @_;
my $overwrite = delete $opts{overwrite};
my $numbered = delete $opts{numbered};
croak "'overwrite' and 'numbered' can not be used together"
if ($overwrite and $numbered);
%opts and _croak_bad_options(keys %opts);
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
$sftp->_set_error(SFTP_ERR_LOCAL_SYMLINK_FAILED,
"creation of symlink '$local' failed", $!);
return undef;
}
$$numbered = $local if ref $numbered;
1;
}
sub put_symlink {
@_ >= 3 or croak 'Usage: $sftp->put_symlink($local, $remote, %opts)';
my ($sftp, $local, $remote, %opts) = @_;
my $overwrite = delete $opts{overwrite};
my $numbered = delete $opts{numbered};
croak "'overwrite' and 'numbered' can not be used together"
if ($overwrite and $numbered);
%opts and _croak_bad_options(keys %opts);
$overwrite = 1 unless (defined $overwrite or $numbered);
my $perm = (CORE::lstat $local)[2];
unless (defined $perm) {
$sftp->_set_error(SFTP_ERR_LOCAL_STAT_FAILED,
"Couldn't stat local file '$local'", $!);
return undef;
}
unless (_is_lnk($perm)) {
$sftp->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT,
"Local file $local is not a symlink");
return undef;
}
my $target = readlink $local;
unless (defined $target) {
$sftp->_set_error(SFTP_ERR_LOCAL_READLINK_FAILED,
"Couldn't read link '$local'", $!);
return undef;
}
while (1) {
local $sftp->{_autodie};
$sftp->symlink($remote, $target);
if ($sftp->{_error} and
$sftp->{_status} == SSH2_FX_FAILURE) {
if ($numbered and $sftp->test_e($remote)) {
_inc_numbered($remote);
redo;
}
elsif ($overwrite and $sftp->_remove_save_status($remote)) {
$overwrite = 0;
redo;
}
}
last
}
$$numbered = $remote if ref $numbered;
$sftp->_ok_or_autodie;
}
sub rget {
@_ >= 2 or croak 'Usage: $sftp->rget($remote, $local, %opts)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $remote, $local, %opts) = @_;
defined $remote or croak "remote file path is undefined";
$local = File::Spec->curdir unless defined $local;
# my $cb = delete $opts{callback};
my $umask = delete $opts{umask};
my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
my $copy_time = delete $opts{copy_time};
my $newer_only = delete $opts{newer_only};
my $on_error = delete $opts{on_error};
local $sftp->{_autodie} if $on_error;
my $ignore_links = delete $opts{ignore_links};
my $mkpath = delete $opts{mkpath};
# my $relative_links = delete $opts{relative_links};
my $wanted = _gen_wanted( delete $opts{wanted},
delete $opts{no_wanted} );
my %get_opts = (map { $_ => delete $opts{$_} }
qw(block_size queue_size overwrite conversion
resume numbered atomic best_effort));
if ($get_opts{resume} and $get_opts{conversion}) {
carp "resume option is useless when data conversion has also been requested";
delete $get_opts{resume};
}
my %get_symlink_opts = (map { $_ => $get_opts{$_} }
qw(overwrite numbered));
%opts and _croak_bad_options(keys %opts);
$remote = $sftp->join($remote, './');
my $qremote = quotemeta $remote;
my $reremote = qr/^$qremote(.*)$/i;
my $save = _umask_save_and_set $umask;
$copy_perm = 1 unless defined $copy_perm;
$copy_time = 1 unless defined $copy_time;
$mkpath = 1 unless defined $mkpath;
my $count = 0;
$sftp->find( [$remote],
descend => sub {
my $e = $_[1];
# print "descend: $e->{filename}\n";
if (!$wanted or $wanted->($sftp, $e)) {
my $fn = $e->{filename};
if ($fn =~ $reremote) {
my $lpath = File::Spec->catdir($local, $1);
($lpath) = $lpath =~ /(.*)/ if ${^TAINT};
if (-d $lpath) {
$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
"directory '$lpath' already exists");
$sftp->_call_on_error($on_error, $e);
return 1;
}
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
}
$sftp->_call_on_error($on_error, $e);
}
return undef;
},
wanted => sub {
my $e = $_[1];
unless (_is_dir($e->{a}->perm)) {
if (!$wanted or $wanted->($sftp, $e)) {
my $fn = $e->{filename};
if ($fn =~ $reremote) {
my $lpath = ((length $1) ? File::Spec->catfile($local, $1) : $local);
# print "file fn:$e->{filename}, lpath:$lpath, re:$reremote\n";
($lpath) = $lpath =~ /(.*)/ if ${^TAINT};
if (_is_lnk($e->{a}->perm) and !$ignore_links) {
if ($sftp->get_symlink($fn, $lpath,
# copy_time => $copy_time,
%get_symlink_opts)) {
$count++;
return undef;
}
}
elsif (_is_reg($e->{a}->perm)) {
if ($newer_only and -e $lpath
and (CORE::stat _)[9] >= $e->{a}->mtime) {
$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
"newer local file '$lpath' already exists");
}
else {
if ($sftp->get($fn, $lpath,
copy_perm => $copy_perm,
copy_time => $copy_time,
%get_opts)) {
$count++;
return undef;
}
}
}
else {
$sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,
( $ignore_links
? "remote file '$fn' is not regular file or directory"
: "remote file '$fn' is not regular file, directory or link"));
}
}
else {
$sftp->_set_error(SFTP_ERR_REMOTE_BAD_PATH,
"bad remote path '$fn'");
}
$sftp->_call_on_error($on_error, $e);
}
}
return undef;
} );
return $count;
}
sub rput {
@_ >= 2 or croak 'Usage: $sftp->rput($local, $remote, %opts)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $local, $remote, %opts) = @_;
defined $local or croak "local path is undefined";
$remote = '.' unless defined $remote;
# my $cb = delete $opts{callback};
my $umask = delete $opts{umask};
my $perm = delete $opts{perm};
my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
my $copy_time = delete $opts{copy_time};
my $newer_only = delete $opts{newer_only};
my $on_error = delete $opts{on_error};
local $sftp->{_autodie} if $on_error;
my $ignore_links = delete $opts{ignore_links};
my $mkpath = delete $opts{mkpath};
my $wanted = _gen_wanted( delete $opts{wanted},
delete $opts{no_wanted} );
my %put_opts = (map { $_ => delete $opts{$_} }
qw(block_size queue_size overwrite
conversion resume numbered
late_set_perm atomic best_effort
sparse));
my %put_symlink_opts = (map { $_ => $put_opts{$_} }
qw(overwrite numbered));
croak "'perm' and 'umask' options can not be used simultaneously"
if (defined $perm and defined $umask);
croak "'perm' and 'copy_perm' options can not be used simultaneously"
if (defined $perm and $copy_perm);
%opts and _croak_bad_options(keys %opts);
require Net::SFTP::Foreign::Local;
my $lfs = Net::SFTP::Foreign::Local->new;
$local = $lfs->join($local, './');
my $relocal;
if ($local =~ m|^\./?$|) {
$relocal = qr/^(.*)$/;
}
else {
my $qlocal = quotemeta $local;
$relocal = qr/^$qlocal(.*)$/i;
}
$copy_perm = 1 unless defined $copy_perm;
$copy_time = 1 unless defined $copy_time;
$mkpath = 1 unless defined $mkpath;
my $mask;
if (defined $perm) {
$mask = $perm & 0777;
}
else {
$umask = umask unless defined $umask;
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
my $e = $_[1];
# print "file fn:$e->{filename}, a:$e->{a}\n";
unless (_is_dir($e->{a}->perm)) {
if (!$wanted or $wanted->($lfs, $e)) {
my $fn = $e->{filename};
$debug and $debug & 32768 and _debug "rput handling $fn";
if ($fn =~ $relocal) {
my (undef, $d, $f) = File::Spec->splitpath($1);
my $rpath = $sftp->join($remote, File::Spec->splitdir($d), $f);
if (_is_lnk($e->{a}->perm) and !$ignore_links) {
if ($sftp->put_symlink($fn, $rpath,
%put_symlink_opts)) {
$count++;
return undef;
}
$lfs->_copy_error($sftp);
}
elsif (_is_reg($e->{a}->perm)) {
my $ra;
if ( $newer_only and
$ra = $sftp->stat($rpath) and
$ra->mtime >= $e->{a}->mtime) {
$lfs->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS,
"Newer remote file '$rpath' already exists");
}
else {
if ($sftp->put($fn, $rpath,
( defined($perm) ? (perm => $perm)
: $copy_perm ? (perm => $e->{a}->perm & $mask)
: (copy_perm => 0, umask => $umask) ),
copy_time => $copy_time,
%put_opts)) {
$count++;
return undef;
}
$lfs->_copy_error($sftp);
}
}
else {
$lfs->_set_error(SFTP_ERR_LOCAL_BAD_OBJECT,
( $ignore_links
? "Local file '$fn' is not regular file or directory"
: "Local file '$fn' is not regular file, directory or link"));
}
}
else {
$lfs->_set_error(SFTP_ERR_LOCAL_BAD_PATH,
"Bad local path '$fn'");
}
$lfs->_call_on_error($on_error, $e);
}
}
return undef;
} );
return $count;
}
sub mget {
@_ >= 2 or croak 'Usage: $sftp->mget($remote, $localdir, %opts)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $remote, $localdir, %opts) = @_;
defined $remote or croak "remote pattern is undefined";
my $on_error = $opts{on_error};
local $sftp->{_autodie} if $on_error;
my $ignore_links = delete $opts{ignore_links};
my %glob_opts = (map { $_ => delete $opts{$_} }
qw(on_error follow_links ignore_case
wanted no_wanted strict_leading_dot));
my %get_symlink_opts = (map { $_ => $opts{$_} }
qw(overwrite numbered));
my %get_opts = (map { $_ => delete $opts{$_} }
qw(umask perm copy_perm copy_time block_size queue_size
overwrite conversion resume numbered atomic best_effort mkpath));
%opts and _croak_bad_options(keys %opts);
my @remote = map $sftp->glob($_, %glob_opts), _ensure_list $remote;
my $count = 0;
require File::Spec;
for my $e (@remote) {
my $perm = $e->{a}->perm;
if (_is_dir($perm)) {
$sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,
"Remote object '$e->{filename}' is a directory");
}
else {
my $fn = $e->{filename};
my ($local) = $fn =~ m{([^\\/]*)$};
$local = File::Spec->catfile($localdir, $local)
if defined $localdir;
if (_is_lnk($perm)) {
next if $ignore_links;
$sftp->get_symlink($fn, $local, %get_symlink_opts);
}
else {
$sftp->get($fn, $local, %get_opts);
}
}
$count++ unless $sftp->{_error};
$sftp->_call_on_error($on_error, $e);
}
$count;
}
sub mput {
@_ >= 2 or croak 'Usage: $sftp->mput($local, $remotedir, %opts)';
my ($sftp, $local, $remotedir, %opts) = @_;
defined $local or die "local pattern is undefined";
my $on_error = $opts{on_error};
local $sftp->{_autodie} if $on_error;
my $ignore_links = delete $opts{ignore_links};
my %glob_opts = (map { $_ => delete $opts{$_} }
qw(on_error follow_links ignore_case
wanted no_wanted strict_leading_dot));
my %put_symlink_opts = (map { $_ => $opts{$_} }
qw(overwrite numbered));
my %put_opts = (map { $_ => delete $opts{$_} }
qw(umask perm copy_perm copy_time block_size queue_size
overwrite conversion resume numbered late_set_perm
atomic best_effort sparse mkpath));
%opts and _croak_bad_options(keys %opts);
require Net::SFTP::Foreign::Local;
my $lfs = Net::SFTP::Foreign::Local->new;
my @local = map $lfs->glob($_, %glob_opts), _ensure_list $local;
my $count = 0;
require File::Spec;
for my $e (@local) {
my $perm = $e->{a}->perm;
if (_is_dir($perm)) {
$sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,
"Remote object '$e->{filename}' is a directory");
}
else {
my $fn = $e->{filename};
my $remote = (File::Spec->splitpath($fn))[2];
$remote = $sftp->join($remotedir, $remote)
if defined $remotedir;
if (_is_lnk($perm)) {
next if $ignore_links;
$sftp->put_symlink($fn, $remote, %put_symlink_opts);
}
else {
$sftp->put($fn, $remote, %put_opts);
}
}
$count++ unless $sftp->{_error};
$sftp->_call_on_error($on_error, $e);
}
$count;
}
sub fsync {
@_ == 2 or croak 'Usage: $sftp->fsync($fh)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $fh) = @_;
$sftp->flush($fh, "out");
$sftp->_check_extension('fsync@openssh.com' => 1,
SFTP_ERR_REMOTE_FSYNC_FAILED,
"fsync failed, not implemented")
or return undef;
my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED,
str => 'fsync@openssh.com',
str => $sftp->_rid($fh));
if ($sftp->_check_status_ok($id,
SFTP_ERR_REMOTE_FSYNC_FAILED,
"Couldn't fsync remote file")) {
return 1;
}
return undef;
}
sub statvfs {
@_ == 2 or croak 'Usage: $sftp->statvfs($path_or_fh)';
${^TAINT} and &_catch_tainted_args;
my ($sftp, $pofh) = @_;
my ($extension, $arg) = ( (ref $pofh and UNIVERSAL::isa($pofh, 'Net::SFTP::Foreign::FileHandle'))
? ('fstatvfs@openssh.com', $sftp->_rid($pofh) )
: ('statvfs@openssh.com' , $sftp->_fs_encode($sftp->_rel2abs($pofh)) ) );
$sftp->_check_extension($extension => 2,
SFTP_ERR_REMOTE_STATVFS_FAILED,
"statvfs failed, not implemented")
or return undef;
my $id = $sftp->_queue_new_msg(SSH2_FXP_EXTENDED,
str => $extension,
str => $arg);
if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_EXTENDED_REPLY, $id,
SFTP_ERR_REMOTE_STATVFS_FAILED,
"Couldn't stat remote file system")) {
my %statvfs = map { $_ => $msg->get_int64 } qw(bsize frsize blocks
bfree bavail files ffree
favail fsid flag namemax);
return \%statvfs;
}
return undef;
}
sub fstatvfs {
_deprecated "fstatvfs is deprecated and will be removed on the upcoming 2.xx series, "
. "statvfs method accepts now both file handlers and paths";
goto &statvfs;
}
package Net::SFTP::Foreign::Handle;
use Tie::Handle;
our @ISA = qw(Tie::Handle);
our @CARP_NOT = qw(Net::SFTP::Foreign Tie::Handle);
my $gen_accessor = sub {
my $ix = shift;
sub {
my $st = *{shift()}{ARRAY};
if (@_) {
$st->[$ix] = shift;
}
else {
$st->[$ix]
}
}
};
my $gen_proxy_method = sub {
my $method = shift;
sub {
my $self = $_[0];
$self->_check
or return undef;
my $sftp = $self->_sftp;
if (wantarray) {
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
more => [-o => 'StrictHostKeyChecking no'],
...);
=back
=head1 BUGS
These are the currently known bugs:
=over 4
=item - Doesn't work on VMS:
The problem is related to L<IPC::Open3> not working on VMS. Patches
are welcome!
=item - Dirty cleanup:
On some operating systems, closing the pipes used to communicate with
the slave SSH process does not terminate it and a work around has to
be applied. If you find that your scripts hung when the $sftp object
gets out of scope, try setting C<$Net::SFTP::Foreign::dirty_cleanup>
to a true value and also send me a report including the value of
C<$^O> on your machine and the OpenSSH version.
From version 0.90_18 upwards, a dirty cleanup is performed anyway when
the SSH process does not terminate by itself in 8 seconds or less.
=item - Reversed symlink arguments:
This package uses the non-conforming OpenSSH argument order for the
SSH_FXP_SYMLINK command that seems to be the de facto standard. When
interacting with SFTP servers that follow the SFTP specification, the
C<symlink> method will interpret its arguments in reverse order.
=item - IPC::Open3 bugs on Windows
On Windows the IPC::Open3 module is used to spawn the slave SSH
process. That module has several nasty bugs (related to STDIN, STDOUT
and STDERR being closed or not being assigned to file descriptors 0, 1
and 2 respectively) that will cause the connection to fail.
Specifically this is known to happen under mod_perl/mod_perl2.
=item - Password authentication on HP-UX
For some unknown reason, it seems that when using the module on HP-UX,
number signs (C<#>) in password need to be escaped (C<\#>). For
instance:
my $password = "foo#2014";
$password =~ s/#/\\#/g if $running_in_hp_ux;
my $ssh = Net::OpenSSH->new($host, user => $user,
password => $password);
I don't have access to an HP-UX machine, and so far nobody using it
has been able to explain this behaviour. Patches welcome!
=item - Taint mode and data coming through SFTP
When the module finds it is being used from a script started in taint
mode, on every method call it checks all the arguments passed and dies
if any of them is tainted. Also, any data coming through the SFTP
connection is marked as tainted.
That generates an internal conflict for those methods that under the
hood query the remote server multiple times, using data from responses
to previous queries (tainted) to build new ones (die!).
I don't think a generic solution could be applied to this issue while
honoring the taint-mode spirit (and erring on the safe side), so my
plan is to fix that in a case by case manner.
So, please report any issue you find with taint mode!
=back
Also, the following features should be considered experimental:
- support for Tectia server
- numbered feature
- autodie mode
- best_effort feature
=head1 SUPPORT
To report bugs, send me and email or use the CPAN bug tracking system
at L<http://rt.cpan.org>.
=head2 Commercial support
Commercial support, professional services and custom software
development around this module are available through my current
company. Drop me an email with a rough description of your
requirements and we will get back to you ASAP.
=head2 My wishlist
If you like this module and you're feeling generous, take a look at my
Amazon Wish List: L<http://amzn.com/w/1WU1P6IR5QZ42>
Also consider contributing to the OpenSSH project this module builds
upon: L<http://www.openssh.org/donations.html>.
=head1 SEE ALSO
Information about the constants used on this module is available from
L<Net::SFTP::Foreign::Constants>. Information about attribute objects
is available from L<Net::SFTP::Foreign::Attributes>.
General information about SSH and the OpenSSH implementation is
available from the OpenSSH web site at L<http://www.openssh.org/> and
from the L<sftp(1)> and L<sftp-server(8)> manual pages.
Net::SFTP::Foreign integrates nicely with my other module
L<Net::OpenSSH>.
L<Net::SFTP::Foreign::Backend::Net_SSH2> allows one to run
Net::SFTP::Foreign on top of L<Net::SSH2> (nowadays, this combination
is probably the best option under Windows).
Modules offering similar functionality available from CPAN are
L<Net::SFTP> and L<Net::SSH2>.
L<Test::SFTP> allows one to run tests against a remote SFTP server.
L<autodie>.
=head1 COPYRIGHT
Copyright (c) 2005-2021 Salvador FandiE<ntilde>o (sfandino@yahoo.com).
( run in 0.907 second using v1.01-cache-2.11-cpan-39bf76dae61 )