App-SimpleBackuper
view release on metacpan or search on metacpan
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
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;
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
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]);
if ($sftp->_check_status_ok($id,
SFTP_ERR_REMOTE_WRITE_FAILED,
"Couldn't write to remote file")) {
return 1;
}
return undef;
}
sub seek {
(@_ >= 3 and @_ <= 4)
or croak 'Usage: $sftp->seek($fh, $pos [, $whence])';
my ($sftp, $rfh, $pos, $whence) = @_;
$sftp->flush($rfh) or return undef;
if (!$whence) {
$rfh->_pos($pos)
}
elsif ($whence == 1) {
$rfh->_inc_pos($pos)
}
elsif ($whence == 2) {
my $a = $sftp->stat($rfh) or return undef;
$rfh->_pos($pos + $a->size);
}
else {
croak "invalid value for whence argument ('$whence')";
}
1;
}
sub tell {
@_ == 2 or croak 'Usage: $sftp->tell($fh)';
my ($sftp, $rfh) = @_;
return $rfh->_pos + length ${$rfh->_bout};
}
sub eof {
@_ == 2 or croak 'Usage: $sftp->eof($fh)';
my ($sftp, $rfh) = @_;
$sftp->_fill_read_cache($rfh, 1);
return length(${$rfh->_bin}) == 0
}
sub _write {
my ($sftp, $rfh, $off, $cb) = @_;
$sftp->_clear_error_and_status;
my $rfid = $sftp->_rfid($rfh);
defined $rfid or return undef;
my $qsize = $sftp->{_queue_size};
my @msgid;
my @written;
my $written = 0;
my $end;
while (!$end or @msgid) {
while (!$end and @msgid < $qsize) {
my $data = $cb->();
if (defined $data and length $data) {
my $id = $sftp->_queue_new_msg(SSH2_FXP_WRITE, str => $rfid,
int64 => $off + $written, str => $data);
push @written, $written;
$written += length $data;
push @msgid, $id;
}
else {
$end = 1;
}
}
my $eid = shift @msgid;
my $last = shift @written;
unless ($sftp->_check_status_ok($eid,
SFTP_ERR_REMOTE_WRITE_FAILED,
"Couldn't write to remote file")) {
# discard responses to queued requests:
$sftp->_get_msg_by_id($_) for @msgid;
return $last;
}
}
return $written;
}
sub write {
@_ == 3 or croak 'Usage: $sftp->write($fh, $data)';
my ($sftp, $rfh) = @_;
$sftp->flush($rfh, 'in') or return undef;
utf8::downgrade($_[2], 1) or croak "wide characters found in data";
my $datalen = length $_[2];
my $bout = $rfh->_bout;
$$bout .= $_[2];
my $len = length $$bout;
if ($len >= $sftp->{_write_delay} or ($len and $sftp->{_autoflush} )) {
$sftp->flush($rfh, 'out') or return undef;
}
return $datalen;
}
sub flush {
(@_ >= 2 and @_ <= 3)
or croak 'Usage: $sftp->flush($fh [, $direction])';
my ($sftp, $rfh, $dir) = @_;
$dir ||= '';
defined $sftp->_rfid($rfh) or return;
if ($dir ne 'out') { # flush in!
${$rfh->_bin} = '';
}
if ($dir ne 'in') { # flush out!
my $bout = $rfh->_bout;
my $len = length $$bout;
if ($len) {
my $start;
my $append = $rfh->_flag('append');
if ($append) {
my $attr = $sftp->stat($rfh)
or return undef;
$start = $attr->size;
}
else {
$start = $rfh->_pos;
${$rfh->_bin} = '';
}
my $off = 0;
my $written = $sftp->_write($rfh, $start,
sub {
my $data = substr($$bout, $off, $sftp->{_block_size});
$off += length $data;
$data;
} );
$rfh->_inc_pos($written)
unless $append;
$$bout = ''; # The full buffer is discarded even when some error happens.
$written == $len or return undef;
}
}
1;
}
sub _fill_read_cache {
my ($sftp, $rfh, $len) = @_;
$sftp->_clear_error_and_status;
$sftp->flush($rfh, 'out')
or return undef;
my $rfid = $sftp->_rfid($rfh);
defined $rfid or return undef;
my $bin = $rfh->_bin;
if (defined $len) {
return 1 if ($len < length $$bin);
my $read_ahead = $sftp->{_read_ahead};
$len = length($$bin) + $read_ahead
if $len - length($$bin) < $read_ahead;
}
my $pos = $rfh->_pos;
my $qsize = $sftp->{_queue_size};
my $bsize = $sftp->{_block_size};
do {
local $sftp->{_autodie};
my @msgid;
my $askoff = length $$bin;
my $ensure_eof;
while (!defined $len or length $$bin < $len) {
while ((!defined $len or $askoff < $len) and @msgid < $qsize) {
my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
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");
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
"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;
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
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 $sftp->{_autodie};
$sftp->stat($remote);
};
my ($rperm, $size, $atime, $mtime) = ($a ? ($a->perm, $a->size, $a->atime, $a->mtime) : ());
$size = -1 unless defined $size;
if ($copy_time and not defined $atime) {
if ($best_effort) {
undef $copy_time;
}
else {
$sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED,
"Not enough information on stat, amtime not included");
return undef;
}
}
$umask = (defined $perm ? 0 : umask) unless defined $umask;
if ($copy_perm) {
if (defined $rperm) {
$perm = $rperm;
}
elsif ($best_effort) {
undef $copy_perm
}
else {
$sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED,
"Not enough information on stat, mode not included");
return undef
}
}
$perm &= ~$umask if defined $perm;
$sftp->_clear_error_and_status;
if ($resume and $resume eq 'auto') {
undef $resume;
if (defined $mtime) {
if (my @lstat = CORE::stat $local) {
$resume = ($mtime <= $lstat[9]);
}
}
}
my ($atomic_numbered, $atomic_local, $atomic_cleanup);
my ($rfh, $fh);
my $askoff = 0;
my $lstart = 0;
if ($dont_save) {
$rfh = $sftp->open($remote, SSH2_FXF_READ);
defined $rfh or return undef;
}
else {
unless ($local_is_fh or $overwrite or $append or $resume or $numbered) {
if (-e $local) {
$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
"local file $local already exists");
return undef
}
}
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
if ($local_is_fh) {
$fh = $local;
# we don't set binmode for the passed file handle on purpose
}
else {
unless (CORE::open $fh, '<', $local) {
$sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
"Unable to open local file '$local'", $!);
return undef;
}
binmode $fh;
}
{
# as $fh can come from the outside, it may be a tied object
# lacking support for some methods, so we call them wrapped
# inside eval blocks
local ($@, $SIG{__DIE__}, $SIG{__WARN__});
if ((undef, undef, $lmode, undef, undef,
undef, undef, $lsize, $latime, $lmtime) =
eval {
no warnings; # Calling stat on a tied handler
# generates a warning because the op is
# not supported by the tie API.
CORE::stat $fh;
}
) {
$debug and $debug & 16384 and _debug "local file size is " . (defined $lsize ? $lsize : '<undef>');
# $fh can point at some place inside the file, not just at the
# begining
if ($local_is_fh and defined $lsize) {
my $tell = eval { CORE::tell $fh };
$lsize -= $tell if $tell and $tell > 0;
}
}
elsif ($copy_perm or $copy_time) {
$sftp->_set_error(SFTP_ERR_LOCAL_STAT_FAILED,
"Couldn't stat local file '$local'", $!);
return undef;
}
elsif ($resume and $resume eq 'auto') {
$debug and $debug & 16384 and _debug "not resuming because stat'ing the local file failed";
undef $resume
}
}
$perm = $lmode & $neg_umask if $copy_perm;
my $attrs = Net::SFTP::Foreign::Attributes->new;
$attrs->set_perm($perm) if defined $perm;
my $rfh;
my $writeoff = 0;
my $converter = _gen_converter $conversion;
my $converted_input = '';
my $rattrs;
if ($resume or $append) {
$rattrs = do {
local $sftp->{_autodie};
$sftp->stat($remote);
};
if ($rattrs) {
if ($resume and $resume eq 'auto' and $rattrs->mtime <= $lmtime) {
$debug and $debug & 16384 and
_debug "not resuming because local file is newer, r: ".$rattrs->mtime." l: $lmtime";
undef $resume;
}
else {
$writeoff = $rattrs->size;
$debug and $debug & 16384 and _debug "resuming from $writeoff";
}
}
else {
if ($append) {
$sftp->{_status} == SSH2_FX_NO_SUCH_FILE
or $sftp->_ok_or_autodie or return undef;
# no such file, no append
undef $append;
}
$sftp->_clear_error_and_status;
}
}
my ($atomic_numbered, $atomic_remote);
if ($writeoff) {
# one of $resume or $append is set
if ($resume) {
$debug and $debug & 16384 and _debug "resuming file transfer from $writeoff";
if ($converter) {
# as size could change, we have to read and convert
# data until we reach the given position on the local
# file:
my $off = 0;
my $eof_t;
while (1) {
my $len = length $converted_input;
my $delta = $writeoff - $off;
if ($delta <= $len) {
$debug and $debug & 16384 and _debug "discarding $delta converted bytes";
substr $converted_input, 0, $delta, '';
last;
}
else {
$off += $len;
if ($eof_t) {
$sftp->_set_error(SFTP_ERR_REMOTE_BIGGER_THAN_LOCAL,
"Couldn't resume transfer, remote file is bigger than local");
return undef;
}
my $read = CORE::read($fh, $converted_input, $block_size * 4);
unless (defined $read) {
$sftp->_set_error(SFTP_ERR_LOCAL_READ_ERROR,
"Couldn't read from local file '$local' to the resume point $writeoff", $!);
return undef;
}
$lsize += $converter->($converted_input) if defined $lsize;
utf8::downgrade($converted_input, 1)
or croak "converter introduced wide characters in data";
$read or $eof_t = 1;
}
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
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);
push @dir, $fn if (!defined $cheap_wanted or $fn =~ $cheap_wanted);
$msg->skip_str;
Net::SFTP::Foreign::Attributes->skip_from_buffer($msg);
}
}
else {
for (1..$count) {
my $fn = $sftp->_fs_decode($msg->get_str);
my $ln = $sftp->_fs_decode($msg->get_str);
# my $a = $msg->get_attributes;
my $a = Net::SFTP::Foreign::Attributes->new_from_buffer($msg);
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);
$overwrite = 1 unless (defined $overwrite or $numbered);
my $a = $sftp->lstat($remote) or return undef;
unless (_is_lnk($a->perm)) {
$sftp->_set_error(SFTP_ERR_REMOTE_BAD_OBJECT,
"Remote object '$remote' is not a symlink");
return undef;
}
my $link = $sftp->readlink($remote) or return undef;
# TODO: this is too weak, may contain race conditions.
if ($numbered) {
_inc_numbered($local) while -e $local;
}
elsif (-e $local) {
if ($overwrite) {
unlink $local;
}
else {
$sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
"local file $local already exists");
return undef
}
}
unless (eval { CORE::symlink $link, $local }) {
$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;
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
$debug and $debug & 32768 and _debug "rput handling $fn";
if ($fn =~ $relocal) {
my $rpath = $sftp->join($remote, File::Spec->splitdir($1));
$debug and $debug & 32768 and _debug "rpath: $rpath";
my $a = Net::SFTP::Foreign::Attributes->new;
if (defined $perm) {
$a->set_perm($mask | 0300);
}
elsif ($copy_perm) {
$a->set_perm($e->{a}->perm & $mask);
}
if ($sftp->mkdir($rpath, $a)) {
$count++;
return 1;
}
if ($mkpath and
$sftp->status == SSH2_FX_NO_SUCH_FILE) {
$sftp->_clear_error_and_status;
if ($sftp->mkpath($rpath, $a)) {
$count++;
return 1;
}
}
$lfs->_copy_error($sftp);
if ($sftp->test_d($rpath)) {
$lfs->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS,
"Remote directory '$rpath' already exists");
$lfs->_call_on_error($on_error, $e);
return 1;
}
}
else {
$lfs->_set_error(SFTP_ERR_LOCAL_BAD_PATH,
"Bad local path '$fn'");
}
$lfs->_call_on_error($on_error, $e);
}
return undef;
},
wanted => sub {
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));
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
Note that this operation just sends data cached locally to the remote
server. You may like to call C<fsync> (when supported) afterwards to
ensure that data is actually flushed to disc.
=item $sftp-E<gt>fsync($fh)
On servers supporting the C<fsync@openssh.com> extension, this method
calls L<fysnc(2)> on the remote side, which usually flushes buffered
changes to disk.
=item $sftp-E<gt>sftpread($handle, $offset, $length)
low level method that sends a SSH2_FXP_READ request to read from an
open file handle C<$handle>, C<$length> bytes starting at C<$offset>.
Returns the data read on success and undef on failure.
Some servers (for instance OpenSSH SFTP server) limit the size of the
read requests and so the length of data returned can be smaller than
requested.
=item $sftp-E<gt>sftpwrite($handle, $offset, $data)
low level method that sends a C<SSH_FXP_WRITE> request to write to an
open file handle C<$handle>, starting at C<$offset>, and where the
data to be written is in C<$data>.
Returns true on success and undef on failure.
=item $sftp-E<gt>opendir($path)
Sends a C<SSH_FXP_OPENDIR> command to open the remote directory
C<$path>, and returns an open handle on success (unfortunately,
current versions of perl does not support directory operations via
tied handles, so it is not possible to use the returned handle as a
native one).
On failure returns C<undef>.
=item $sftp-E<gt>closedir($handle)
closes the remote directory handle C<$handle>.
Directory handles are closed from their C<DESTROY> method when not
done explicitly.
Return true on success, undef on failure.
=item $sftp-E<gt>readdir($handle)
returns the next entry from the remote directory C<$handle> (or all
the remaining entries when called in list context).
The return values are a hash with three keys: C<filename>, C<longname> and
C<a>. The C<a> value contains a L<Net::SFTP::Foreign::Attributes>
object describing the entry.
Returns undef on error or when no more entries exist on the directory.
=item $sftp-E<gt>stat($path_or_fh)
performs a C<stat> on the remote file and returns a
L<Net::SFTP::Foreign::Attributes> object with the result values. Both
paths and open remote file handles can be passed to this method.
Returns undef on failure.
=item $sftp-E<gt>fstat($handle)
this method is deprecated.
=item $sftp-E<gt>lstat($path)
this method is similar to C<stat> method but stats a symbolic link
instead of the file the symbolic links points to.
=item $sftp-E<gt>setstat($path_or_fh, $attrs)
sets file attributes on the remote file. Accepts both paths and open
remote file handles.
Returns true on success and undef on failure.
=item $sftp-E<gt>fsetstat($handle, $attrs)
this method is deprecated.
=item $sftp-E<gt>truncate($path_or_fh, $size)
=item $sftp-E<gt>chown($path_or_fh, $uid, $gid)
=item $sftp-E<gt>chmod($path_or_fh, $perm)
=item $sftp-E<gt>utime($path_or_fh, $atime, $mtime)
Shortcuts around C<setstat> method.
=item $sftp-E<gt>remove($path)
Sends a C<SSH_FXP_REMOVE> command to remove the remote file
C<$path>. Returns a true value on success and undef on failure.
=item $sftp-E<gt>mkdir($path, $attrs)
Sends a C<SSH_FXP_MKDIR> command to create a remote directory C<$path>
whose attributes are initialized to C<$attrs> (a
L<Net::SFTP::Foreign::Attributes> object).
Returns a true value on success and undef on failure.
The C<$attrs> argument is optional.
=item $sftp-E<gt>mkpath($path, $attrs, $parent)
This method is similar to C<mkdir> but also creates any non-existent
parent directories recursively.
When the optional argument C<$parent> has a true value, just the
parent directory of the given path (and its ancestors as required) is
created.
For instance:
$sftp->mkpath("/tmp/work", undef, 1);
my $fh = $sftp->open("/tmp/work/data.txt",
SSH2_FXF_WRITE|SSH2_FXF_CREAT);
=item $sftp-E<gt>rmdir($path)
Sends a C<SSH_FXP_RMDIR> command to remove a remote directory
C<$path>. Returns a true value on success and undef on failure.
=item $sftp-E<gt>realpath($path)
Sends a C<SSH_FXP_REALPATH> command to canonicalise C<$path>
to an absolute path. This can be useful for turning paths
containing C<'..'> into absolute paths.
Returns the absolute path on success, C<undef> on failure.
When the given path points to an nonexistent location, what one
gets back is server dependent. Some servers return a failure message
and others a canonical version of the path.
( run in 2.341 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )