App-SimpleBackuper
view release on metacpan or search on metacpan
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
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;
}
sub _do_io { $_[0]->{_backend}->_do_io(@_) }
sub _conn_lost {
my ($sftp, $status, $err, @str) = @_;
$debug and $debug & 32 and _debug("_conn_lost");
$sftp->{_status} or
$sftp->_set_status(defined $status ? $status : SSH2_FX_CONNECTION_LOST);
$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,
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
$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};
defined $sftp->{_timeout} and $sftp->{_timeout} <= 0 and croak "invalid timeout";
$sftp->{_fs_encoding} = delete $opts{fs_encoding};
if (defined $sftp->{_fs_encoding}) {
$] < 5.008
and carp "fs_encoding feature is not supported in this perl version $]";
}
else {
$sftp->{_fs_encoding} = 'utf8';
}
$sftp->autodisconnect(delete $opts{autodisconnect});
$backend->_init_transport($sftp, \%opts);
%opts and _croak_bad_options(keys %opts);
$sftp->_init unless $sftp->{_error};
$backend->_after_init($sftp);
$sftp
}
sub autodisconnect {
my ($sftp, $ad) = @_;
if (not defined $ad or $ad == 2) {
$debug and $debug & 4 and _debug "setting disconnecting pid to $$ and thread to $thread_generation";
$sftp->{_disconnect_by_pid} = $$;
$sftp->{_disconnect_by_thread} = $thread_generation;
}
else {
delete $sftp->{_disconnect_by_thread};
if ($ad == 0) {
$sftp->{_disconnect_by_pid} = -1;
}
elsif ($ad == 1) {
delete $sftp->{_disconnect_by_pid};
}
else {
croak "bad value '$ad' for autodisconnect";
}
}
1;
}
sub disconnect {
my $sftp = shift;
my $pid = delete $sftp->{pid};
$debug and $debug & 4 and _debug("$sftp->disconnect called (ssh pid: ".($pid||'').")");
local $sftp->{_autodie};
$sftp->_conn_lost;
if (defined $pid) {
close $sftp->{ssh_out} if (defined $sftp->{ssh_out} and not $sftp->{_ssh_out_is_not_dupped});
close $sftp->{ssh_in} if defined $sftp->{ssh_in};
if ($windows) {
kill KILL => $pid
and waitpid($pid, 0);
$debug and $debug & 4 and _debug "process $pid reaped";
}
else {
my $dirty = ( defined $sftp->{_dirty_cleanup}
? $sftp->{_dirty_cleanup}
: $dirty_cleanup );
if ($dirty or not defined $dirty) {
$debug and $debug & 4 and _debug("starting dirty cleanup of process $pid");
OUT: for my $sig (($dirty ? () : 0), qw(TERM TERM KILL KILL)) {
$debug and $debug & 4 and _debug("killing process $pid with signal $sig");
$sig and kill $sig, $pid;
local ($@, $SIG{__DIE__}, $SIG{__WARN__});
my $deadline = Time::HiRes::time + 8;
my $dt = 0.01;
while (Time::HiRes::time < $deadline) {
my $wpr = waitpid($pid, POSIX::WNOHANG());
$debug and $debug & 4 and _debug("waitpid returned ", $wpr);
last OUT if $wpr or $! == Errno::ECHILD();
Time::HiRes::sleep($dt);
$dt *= 1.2;
}
}
}
else {
while (1) {
last if waitpid($pid, 0) > 0;
if ($! != Errno::EINTR()) {
warn "internal error: unexpected error in waitpid($pid): $!"
if $! != Errno::ECHILD();
last;
}
}
}
$debug and $debug & 4 and _debug "process $pid reaped";
}
}
close $sftp->{_pty} if defined $sftp->{_pty};
1
}
sub DESTROY {
local ($?, $!, $@);
my $sftp = shift;
my $dbpid = $sftp->{_disconnect_by_pid};
my $dbthread = $sftp->{_disconnect_by_thread};
$debug and $debug & 4 and _debug("$sftp->DESTROY called (current pid: $$, disconnect_by_pid: " .
($dbpid || '') .
"), current thread generation: $thread_generation, disconnect_by_thread: " .
($dbthread || '') . ")");
if (!defined $dbpid or ($dbpid == $$ and $dbthread == $thread_generation)) {
$sftp->disconnect
}
else {
$debug and $debug & 4 and _debug "skipping disconnection because pid and/or thread generation don't match";
}
}
sub _init {
my $sftp = shift;
$sftp->_queue_msg( Net::SFTP::Foreign::Buffer->new(int8 => SSH2_FXP_INIT,
int32 => SSH2_FILEXFER_VERSION));
if (my $msg = $sftp->_get_msg) {
my $type = $msg->get_int8;
if ($type == SSH2_FXP_VERSION) {
my $version = $msg->get_int32;
$sftp->{server_version} = $version;
$sftp->{server_extensions} = {};
while (length $$msg) {
my $key = $msg->get_str;
my $value = $msg->get_str;
$sftp->{server_extensions}{$key} = $value;
if ($key eq 'vendor-id') {
my $vid = Net::SFTP::Foreign::Buffer->make("$value");
$sftp->{_ext__vendor_id} = [ Encode::decode(utf8 => $vid->get_str),
Encode::decode(utf8 => $vid->get_str),
Encode::decode(utf8 => $vid->get_str),
$vid->get_int64 ];
}
elsif ($key eq 'supported2') {
my $s2 = Net::SFTP::Foreign::Buffer->make("$value");
$sftp->{_ext__supported2} = [ $s2->get_int32,
$s2->get_int32,
$s2->get_int32,
$s2->get_int32,
$s2->get_int32,
$s2->get_int16,
$s2->get_int16,
[map Encode::decode(utf8 => $_), $s2->get_str_list],
[map Encode::decode(utf8 => $_), $s2->get_str_list] ];
}
}
return $version;
}
$sftp->_conn_lost(SSH2_FX_BAD_MESSAGE,
SFTP_ERR_REMOTE_BAD_MESSAGE,
"bad packet type, expecting SSH2_FXP_VERSION, got $type");
}
elsif ($sftp->{_status} == SSH2_FX_CONNECTION_LOST
and $sftp->{_password_authentication}
and $sftp->{_password_sent}) {
$sftp->_set_error(SFTP_ERR_PASSWORD_AUTHENTICATION_FAILED,
"Password authentication failed or connection lost");
}
return undef;
}
sub server_extensions { %{shift->{server_extensions}} }
sub _check_extension {
local/lib/perl5/Net/SFTP/Foreign.pm view on Meta::CPAN
open my $ssherr, '>', '/dev/null' or die "unable to open /dev/null";
my $sftp = Net::SFTP::Foreign->new($host,
stderr_fh => $ssherr);
Or to send SSH stderr to a file in order to capture errors for later
analysis:
my $ssherr = File::Temp->new or die "File::Temp->new failed";
my $sftp = Net::SFTP::Foreign->new($hostname, more => ['-v'],
stderr_fh => $ssherr);
if ($sftp->error) {
print "sftp error: ".$sftp->error."\n";
seek($ssherr, 0, 0);
while (<$ssherr>) {
print "captured stderr: $_";
}
}
=item stderr_discard =E<gt> 1
redirects stderr to /dev/null
=item block_size =E<gt> $default_block_size
=item queue_size =E<gt> $default_queue_size
default C<block_size> and C<queue_size> used for read and write
operations (see the C<put> or C<get> documentation).
=item autoflush =E<gt> $bool
by default, and for performance reasons, write operations are cached,
and only when the write buffer becomes big enough is the data written to
the remote file. Setting this flag makes the write operations immediate.
=item write_delay =E<gt> $bytes
This option determines how many bytes are buffered before the real
SFTP write operation is performed.
=item read_ahead =E<gt> $bytes
On read operations this option determines how many bytes to read in
advance so that later read operations can be fulfilled from the
buffer.
Using a high value will increase the performance of the module for a
sequential reads access pattern but degrade it for a short random
reads access pattern. It can also cause synchronization problems if
the file is concurrently modified by other parties (L</flush> can be
used to discard all the data inside the read buffer on demand).
The default value is set dynamically considering some runtime
parameters and given options, though it tends to favor the sequential
read access pattern.
=item autodisconnect =E<gt> $ad
by default, the SSH connection is closed from the DESTROY method when
the object goes out of scope on the process and thread where it was
created. This option allows one to customize this behaviour.
The acceptable values for C<$ad> are:
=over 4
=item '0'
Never try to disconnect this object when exiting from any process.
On most operating systems, the SSH process will exit when the last
process connected to it ends, but this is not guaranteed.
You can always call the C<disconnect> method explicitly to end the
connection at the right time from the right place.
=item '1'
Disconnect on exit from any thread or process.
=item '2'
Disconnect on exit from the current process/thread only. This is the
default.
=back
See also the C<disconnect> and C<autodisconnect> methods.
=item late_set_perm =E<gt> $bool
See the FAQ below.
=item dirty_cleanup =E<gt> $bool
Sets the C<dirty_cleanup> flag in a per object basis (see the BUGS
section).
=item backend => $backend
From version 1.57 Net::SFTP::Foreign supports plugable backends in
order to allow other ways to communicate with the remote server in
addition to the default I<pipe-to-ssh-process>.
Custom backends may change the set of options supported by the C<new>
method.
=item autodie => $bool
Enables the autodie mode that will cause the module to die when any
error is found (a la L<autodie>).
=back
=item $sftp-E<gt>error
Returns the error code from the last executed command. The value
returned is similar to C<$!>, when used as a string it yields the
corresponding error string.
See L<Net::SFTP::Foreign::Constants> for a list of possible error
codes and how to import them on your scripts.
=item $sftp-E<gt>die_on_error($msg)
Convenience method:
$sftp->die_on_error("Something bad happened");
# is a shortcut for...
$sftp->error and die "Something bad happened: " . $sftp->error;
=item $sftp-E<gt>status
Returns the code from the last SSH2_FXP_STATUS response. It is also a
dualvar that yields the status string when used as a string.
Usually C<$sftp-E<gt>error> should be checked first to see if there was
any error and then C<$sftp-E<gt>status> to find out its low level cause.
=item $sftp-E<gt>cwd
Returns the remote current working directory.
( run in 2.933 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )