Codebase list libnet-sftp-foreign-perl / upstream/1.69+dfsg
Imported Upstream version 1.69+dfsg gregor herrmann 12 years ago
16 changed file(s) with 931 addition(s) and 540 deletion(s). Raw diff Collapse all Expand all
00 Revision history for Net::SFTP::Foreign
1
2 1.69 Dic 9, 2011
3 - release as stable
4
5 1.68_08 Oct 11, 2011
6 - accept an array reference in ssh_cmd
7 - use warnings::warnif to generate warnings
8 - minor doc improvements and corrections
9 - in case of sftp-server not found test were not skipped but
10 failed
11
12 1.68_07 Oct 10, 2011
13 - password authentication was not working with the new
14 IPC::Open3 replacement code (bug report by Srini T)
15 - empty password handling was also broken
16 - allow setting the backend on all the tests
17
18 1.68_06 Oct 9, 2011
19 - do not use the buggy IPC::Open3 under Unix/Linux. This is a
20 mayor internal change, please report any connection problems
21 that were not happening with previous versions of the module
22 - allow testing Windows backend under Unix
23
24 1.68_05 Sep 27, 2011
25 - this version is more picky about incomplete responses to
26 stat requests when copy_perms or copy_time are enabled
27 (implicetly or explicitly) on get method
28 - handle incomplete attributes in stat response inside get
29 (bug report by Gus via the Perl Guru Forums).
30
31 1.68_04 Sep 7, 2011
32 - accept passing undef as second argument to put, get, rput,
33 rget, mput and mget
34 - catch invalid undefined arguments in several places
35 - custom conversion usage was broken
36 - add %DEFAULTS to Compat package for setting default options
37 for Net::SFTP::Foreign methods called under the hood.
38
39 1.68_03 Aug 28, 2011
40 - atomic feature added to get, put and higher level methods
41 using them
42 - cleanup feature added to get and put
43 - support for numbered feature added to rename
44 - save final target name when a reference is passed as
45 numbered option
46 - refactor rput and rget handling of put, put_symlink, get and
47 get_symlink options using hashes
48 - remove operation inside put_symlink was clobbering error and
49 status from previous symlink call
50 - do not die from inside DESTROY methods when autodie is set
51 - resume feature in get method was broken
52 - refactor numbered logic inside _inc_numbered sub
53 - refactor _gen_save_status_method using local
54
55 1.68_02 Jul 20, 2011
56 - make unix2dos clever so it doesn't convert CR+LF sequences
57 into CR+CR+LF (bug report by Pavel Albertyan).
58
59 1.68_01 Jul 12, 2011
60 - add workaround for crippled versions of Scalar::Util
61 - document overwrite and numbered options as accepted by the
62 put method (reported by Paul Kolano)
163
264 1.67 Jul 4, 2011
365 - released as stable in order to solve critical bug:
466 - solve regresion introduced in 1.63_05 that caused ssh to
567 hang when trying to access the tty
6
768 - pass password to plink via -pw and generate a warning when
869 doing so
970 - support for key_path constructor argument
75136 report by rfbits at PerlMonks)
76137
77138 1.61 Sep 22, 2010
78 - remove some dead code introducing unneded constraints that
139 - remove some dead code introducing unneeded constraints that
79140 cause the Net::SSH2 backend to fail (bug report by Philippe
80141 Vouters)
81142
00 --- #YAML:1.0
11 name: Net-SFTP-Foreign
2 version: 1.67
2 version: 1.69
33 abstract: Secure File Transfer Protocol client
44 author:
55 - Salvador Fandino <sfandino@yahoo.com>
1212
1313 - detect unknown host key checking
1414
15 - add support for process filters on put/get operations
16
1517 DONE
1618 ====
1719
2224
2325 - add support for unix2dos and dos2unix transformations on the fly for get and put.
2426
25 - add support con restarting transfer to put, get and derived methods.
27 - add support for restarting transfers in put, get and derived methods.
00 package Net::SFTP::Foreign::Attributes;
11
2 our $VERSION = '1.45_02';
2 our $VERSION = '1.68_05';
33
44 use strict;
55 use warnings;
3131 sub new_from_buffer {
3232 my ($class, $buf) = @_;
3333 my $self = $class->new;
34 my $flags = $self->{flags} = $buf->get_int32;
34 my $flags = $self->{flags} = $buf->get_int32_untaint;
3535
3636 if ($flags & SSH2_FILEXFER_ATTR_SIZE) {
37 $self->{size} = $buf->get_int64;
37 $self->{size} = $buf->get_int64_untaint;
3838 }
3939
4040 if ($flags & SSH2_FILEXFER_ATTR_UIDGID) {
41 $self->{uid} = $buf->get_int32;
42 $self->{gid} = $buf->get_int32;
41 $self->{uid} = $buf->get_int32_untaint;
42 $self->{gid} = $buf->get_int32_untaint;
4343 }
4444
4545 if ($flags & SSH2_FILEXFER_ATTR_PERMISSIONS) {
46 $self->{perm} = $buf->get_int32;
46 $self->{perm} = $buf->get_int32_untaint;
4747 }
4848
4949 if ($flags & SSH2_FILEXFER_ATTR_ACMODTIME) {
50 $self->{atime} = $buf->get_int32;
51 $self->{mtime} = $buf->get_int32;
50 $self->{atime} = $buf->get_int32_untaint;
51 $self->{mtime} = $buf->get_int32_untaint;
5252 }
5353
5454 if ($flags & SSH2_FILEXFER_ATTR_EXTENDED) {
00 package Net::SFTP::Foreign::Backend::Unix;
11
2 our $VERSION = '1.67';
2 our $VERSION = '1.68_08';
33
44 use strict;
55 use warnings;
88 our @CARP_NOT = qw(Net::SFTP::Foreign);
99
1010 use Fcntl qw(O_NONBLOCK F_SETFL F_GETFL);
11 use IPC::Open3;
12 use IPC::Open2;
11 use POSIX ();
1312 use Net::SFTP::Foreign::Helpers qw(_tcroak _ensure_list _debug _hexdump $debug);
1413 use Net::SFTP::Foreign::Constants qw(SSH2_FX_BAD_MESSAGE
1514 SFTP_ERR_REMOTE_BAD_MESSAGE);
3938 $dev_null
4039 }
4140
42 sub _ipc_open2_bug_workaround {
43 # in some cases, IPC::Open3::open2 returns from the child
44 my $pid = shift;
45 unless ($pid == $$) {
46 require POSIX;
47 POSIX::_exit(-1);
48 }
49 }
50
51 sub _open3 {
41 sub _fileno_dup_over {
42 my ($good_fn, $fh) = @_;
43 if (defined $fh) {
44 my @keep_open;
45 my $fn = fileno $fh;
46 for (1..5) {
47 $fn >= $good_fn and return $fn;
48 $fn = POSIX::dup($fn);
49 push @keep_open, $fn;
50 }
51 POSIX::_exit(255);
52 }
53 undef;
54 }
55
56 sub _open4 {
5257 my $backend = shift;
5358 my $sftp = shift;
54 if (defined $_[2]) {
55 my $sftp_err = $_[2];
56 my $fno = eval { no warnings; fileno($sftp_err) };
57 local *SSHERR;
58 unless (defined $fno and $fno >= 0 and
59 open(SSHERR, ">>&=", $fno)) {
60 $sftp->_conn_failed("Unable to duplicate stderr redirection file handle: $!");
61 return undef;
62 }
63 local ($@, $SIG{__DIE__}, $SIG{__WARN__});
64 return eval { open3(@_[1,0], ">&SSHERR", @_[3..$#_]) }
65 }
66 else {
67 local ($@, $SIG{__DIE__}, $SIG{__WARN__});
68 return eval { open2(@_[0,1], @_[3..$#_]) };
69 }
59 my ($dad_in, $dad_out, $child_in, $child_out);
60 unless (pipe ($dad_in, $child_out) and
61 pipe ($child_in, $dad_out)) {
62 $sftp->_conn_failed("Unable to created pipes: $!");
63 return;
64 }
65 my $pid = fork;
66 unless ($pid) {
67 unless (defined $pid) {
68 $sftp->_conn_failed("Unable to fork new process: $!");
69 return;
70 }
71 close ($dad_in);
72 close ($dad_out);
73
74 shift; shift;
75 my $child_err = shift;
76 my $pty = shift;
77
78 $pty->make_slave_controlling_terminal if defined $pty;
79
80 my $child_err_fno = eval { no warnings; fileno($child_err ? $child_err : *STDERR) };
81 my $child_err_safe; # passed handler may be tied, so we
82 # duplicate it in order to get a plain OS
83 # handler.
84 if (defined $child_err_fno and $child_err_fno >= 0) {
85 open $child_err_safe, ">&=$child_err_fno" or POSIX::_exit(1);
86 }
87 else {
88 open $child_err_safe, ">/dev/null" or POSIX::_exit(1);
89 }
90
91 my $child_in_fno = _fileno_dup_over(0 => $child_in );
92 my $child_out_fno = _fileno_dup_over(1 => $child_out );
93 my $child_err_safe_fno = _fileno_dup_over(2 => $child_err_safe);
94
95 unless (($child_in_fno == 0 or POSIX::dup2($child_in_fno, 0)) and
96 ($child_out_fno == 1 or POSIX::dup2($child_out_fno, 1)) and
97 ($child_err_safe_fno == 2 or POSIX::dup2($child_err_safe_fno, 2))) {
98 POSIX::_exit(1);
99 }
100 do { exec @_ };
101 POSIX::_exit(1);
102 }
103 close $child_in;
104 close $child_out;
105
106 $_[0] = $dad_in;
107 $_[1] = $dad_out;
108 $pid;
70109 }
71110
72111 sub _init_transport {
85124 }
86125 else {
87126 my $pass = delete $opts->{passphrase};
88 my $passphrase;
127 my $pass_is_passphrase;
89128 if (defined $pass) {
90 $passphrase = 1;
129 $pass_is_passphrase = 1;
91130 }
92131 else {
93132 $pass = delete $opts->{password};
112151
113152 my $ssh_cmd = delete $opts->{ssh_cmd};
114153 $ssh_cmd = 'ssh' unless defined $ssh_cmd;
115 @open2_cmd = ($ssh_cmd);
154 @open2_cmd = _ensure_list $ssh_cmd;
116155
117156 unless (defined $ssh_cmd_interface) {
118 $ssh_cmd_interface = ( $ssh_cmd =~ /\bplink(?:\.exe)?$/i ? 'plink' :
119 $ssh_cmd =~ /\bsshg3$/i ? 'tectia' :
120 'ssh' );
157 $ssh_cmd_interface = ( "@open2_cmd" =~ /\bplink\b/i ? 'plink' :
158 "@open2_cmd" =~ /\bsshg3\b/i ? 'tectia' :
159 'ssh' );
121160 }
122161
123162 my $port = delete $opts->{port};
125164 my $ssh1 = delete $opts->{ssh1};
126165
127166 my $more = delete $opts->{more};
128 carp "'more' argument looks like if it should be splited first"
129 if (defined $more and !ref($more) and $more =~ /^-\w\s+\S/);
167 defined $more and !ref($more) and $more =~ /^-\w\s+\S/ and
168 warnings::warnif("Net::SFTP::Foreign", "'more' argument looks like it should be split first");
130169 my @more = _ensure_list $more;
131170
132171 my @preferred_authentications;
137176
138177 if ($ssh_cmd_interface eq 'plink') {
139178 push @open2_cmd, -P => $port if defined $port;
140 if ($pass and !$passphrase) {
179 if (defined $pass and !$pass_is_passphrase) {
141180 warnings::warnif("Net::SFTP::Foreign", "using insecure password authentication with plink");
142181 push @open2_cmd, -pw => $pass;
143182 undef $pass;
146185 }
147186 elsif ($ssh_cmd_interface eq 'ssh') {
148187 push @open2_cmd, -p => $port if defined $port;
149 if ($pass and !$passphrase) {
188 if (defined $pass and !$pass_is_passphrase) {
150189 push @open2_cmd, -o => 'NumberOfPasswordPrompts=1';
151190 push @preferred_authentications, ('keyboard-interactive', 'password');
152191 }
168207 push @open2_cmd, ($ssh1 ? "/usr/lib/sftp-server" : -s => 'sftp');
169208 }
170209
171 my $redirect_stderr_to_tty = ( (defined $pass or defined $passphrase) and
172 (delete $opts->{redirect_stderr_to_tty} or
173 $ssh_cmd_interface eq 'tectia' ) );
210 my $redirect_stderr_to_tty = ( defined $pass and
211 ( delete $opts->{redirect_stderr_to_tty} or $ssh_cmd_interface eq 'tectia' ) );
174212
175213 $redirect_stderr_to_tty and ($stderr_discard or $stderr_fh)
176214 and croak "stderr_discard or stderr_fh can not be used together with password/passphrase "
188226 if ($stderr_discard) {
189227 $stderr_fh = $backend->_open_dev_null($sftp) or return;
190228 }
191
192 my $this_pid = $$;
193229
194230 if (defined $pass) {
195231
201237 eval { require Expect };
202238 $@ and croak "password authentication is not available, Expect is not installed";
203239
204 local ($ENV{SSH_ASKPASS}, $ENV{SSH_AUTH_SOCK}) if $passphrase;
205
206 my $name = $passphrase ? 'Passphrase' : 'Password';
240 local ($ENV{SSH_ASKPASS}, $ENV{SSH_AUTH_SOCK}) if $pass_is_passphrase;
241
242 my $name = $pass_is_passphrase ? 'Passphrase' : 'Password';
207243 my $eto = $sftp->{_timeout} ? $sftp->{_timeout} * 4 : 120;
208244
209245 my $child;
210246 my $expect;
211 if (eval $IPC::Open3::VERSION >= 1.0105) {
212 # open2(..., '-') only works from this IPC::Open3 version upwards;
213 my $pty = IO::Pty->new;
214 $expect = Expect->init($pty);
215 $expect->raw_pty(1);
216 $expect->log_user($expect_log_user);
217
218 $redirect_stderr_to_tty and $stderr_fh = $pty->slave;
219
220 $child = $backend->_open3($sftp, $sftp->{ssh_in}, $sftp->{ssh_out}, $stderr_fh, '-');
221
222 if (defined $child and !$child) {
223 $pty->make_slave_controlling_terminal;
224 do { exec @open2_cmd }; # work around suppress warning under mod_perl
225 exit -1;
226 }
227 _ipc_open2_bug_workaround $this_pid;
228 # $pty->close_slave();
229 }
230 else {
231 $redirect_stderr_to_tty and
232 croak "In order to support password/passphrase authentication with the Tectia client, " .
233 "IPC::Open3 version 1.0105 is required (current version is $IPC::Open3::VERSION)";
234 $expect = Expect->new;
235 $expect->raw_pty(1);
236 $expect->log_user($expect_log_user);
237 $expect->spawn(@open2_cmd);
238 $sftp->{ssh_in} = $sftp->{ssh_out} = $expect;
239 $sftp->{_ssh_out_is_not_dupped} = 1;
240 $child = $expect->pid;
241 }
247 my $pty = IO::Pty->new;
248 $expect = Expect->init($pty);
249 $expect->raw_pty(1);
250 $expect->log_user($expect_log_user);
251
252 $redirect_stderr_to_tty and $stderr_fh = $pty->slave;
253
254 $child = $backend->_open4($sftp, $sftp->{ssh_in}, $sftp->{ssh_out}, $stderr_fh, $pty, @open2_cmd);
242255 unless (defined $child) {
243256 $sftp->_conn_failed("Bad ssh command", $!);
244257 return;
266279 $expect->close_slave();
267280 }
268281 else {
269 $sftp->{pid} = $backend->_open3($sftp, $sftp->{ssh_in}, $sftp->{ssh_out}, $stderr_fh, @open2_cmd);
270 _ipc_open2_bug_workaround $this_pid;
271
282 $sftp->{pid} = $backend->_open4($sftp, $sftp->{ssh_in}, $sftp->{ssh_out}, $stderr_fh, undef, @open2_cmd);
272283 unless (defined $sftp->{pid}) {
273284 $sftp->_conn_failed("Bad ssh command", $!);
274285 return;
00 package Net::SFTP::Foreign::Backend::Windows;
11
2 our $VERSION = '1.63_05';
2 our $VERSION = '1.68_07';
33
44 use strict;
55 use warnings;
77 use Carp;
88 our @CARP_NOT = qw(Net::SFTP::Foreign);
99
10 use IPC::Open3;
11 use POSIX ();
1012 use Net::SFTP::Foreign::Helpers;
1113 use Net::SFTP::Foreign::Constants qw(SSH2_FX_BAD_MESSAGE
1214 SFTP_ERR_REMOTE_BAD_MESSAGE);
3436 $dev_null
3537 }
3638
37 # workaround for IPC::Open3 not working with tied filehandles even
38 # when they implement FILENO
39 sub _open3 {
39 sub _open4 {
4040 my $backend = shift;
4141 my $sftp = shift;
42 if (tied(*STDERR)) {
43 my $fn = eval { defined $_[2] ? fileno $_[2] : fileno *STDERR };
44 unless (defined $fn and $fn >= 0) {
45 $sftp->_conn_failed("STDERR or stderr_fh is not a real file handle: " . (length $@ ? $@ : $!));
46 return;
47 }
48 local *STDERR;
49 unless (open STDERR, ">&=$fn") {
50 $sftp->_conn_failed("Unable to reattach STDERR to fd $fn: $!");
51 return;
52 }
53 $backend->SUPER::_open3($sftp, @_);
42
43 defined $_[3] and croak "setting child PTY is not supported on Windows";
44
45 my $fno = eval { defined $_[2] ? fileno $_[2] : fileno *STDERR };
46 unless (defined $fno and $fno >= 0) {
47 $sftp->_conn_failed("STDERR or stderr_fh is not a real file handle: " . (length $@ ? $@ : $!));
48 return;
5449 }
55 else {
56 $backend->SUPER::_open3($sftp, @_);
50
51 local *SSHERR;
52 unless (open(SSHERR, ">>&=", $fno)) {
53 $sftp->_conn_failed("Unable to duplicate stderr redirection file handle: $!");
54 return undef;
5755 }
56
57 goto NOTIE unless tied *STDERR;
58 local *STDERR;
59 unless (open STDERR, ">&=2") {
60 $sftp->_conn_failed("Unable to reattach STDERR to fd 2: $!");
61 return;
62 }
63 NOTIE:
64 local ($@, $SIG{__DIE__}, $SIG{__WARN__});
65
66 my $ppid = $$;
67 my $pid = eval { open3(@_[1,0], ">&SSHERR", @_[4..$#_]) };
68 $ppid == $$ or POSIX::_exit(-1);
69 $pid;
5870 }
5971
6072 sub _after_init {}
00 package Net::SFTP::Foreign::Buffer;
11
2 our $VERSION = '1.52';
2 our $VERSION = '1.68_05';
33
44 use strict;
55 use warnings;
3737 unpack(N => substr(${$_[0]}, 0, 4, ''));
3838 }
3939
40 sub get_int64_quads { unpack Q => substr(${$_[0]}, 0, 8, '') }
40 sub get_int32_untaint {
41 my ($v) = substr(${$_[0]}, 0, 4, '') =~ /(.*)/s;
42 get_int32(\$v);
43 }
44
45 sub get_int64_quads {
46 length ${$_[0]} >= 8 or return undef;
47 unpack Q => substr(${$_[0]}, 0, 8, '')
48 }
4149
4250 sub get_int64_no_quads {
4351 length ${$_[0]} >= 8 or return undef;
5967 }
6068
6169 *get_int64 = (HAS_QUADS ? \&get_int64_quads : \&get_int64_no_quads);
70
71 sub get_int64_untaint {
72 my ($v) = substr(${$_[0]}, 0, 8, '') =~ /(.*)/s;
73 get_int64(\$v);
74 }
6275
6376 sub get_str {
6477 my $self = shift;
00 package Net::SFTP::Foreign::Common;
11
2 our $VERSION = '1.66_01';
2 our $VERSION = '1.68_01';
33
44 use strict;
55 use warnings;
66 use Carp;
7 use Scalar::Util qw(dualvar tainted);
7
8 BEGIN {
9 # Some versions of Scalar::Util are crippled
10 require Scalar::Util;
11 eval { Scalar::Util->import(qw(dualvar tainted)); 1 }
12 or do {
13 *tainted = sub { croak "The version of Scalar::Util installed on your system "
14 . "does not provide 'tainted'" };
15 *dualvar = sub { $_[0] };
16 };
17 }
818
919 use Net::SFTP::Foreign::Helpers qw(_gen_wanted _ensure_list _debug _glob_to_regex _is_lnk _is_dir $debug);
1020 use Net::SFTP::Foreign::Constants qw(:status);
8292 sub die_on_error {
8393 my $sftp = shift;
8494 $sftp->{_error} and croak(@_ ? "@_: $sftp->{_error}" : $sftp->{_error});
95 }
96
97 sub _ok_or_autodie {
98 my $sftp = shift;
99 return 1 unless $sftp->{_error};
100 $sftp->{_autodie} and croak $sftp->{_error};
101 undef;
85102 }
86103
87104 sub _set_errno {
381398 $a ? _is_dir($a->perm) : undef;
382399 }
383400
401 sub test_e {
402 my ($sftp, $name) = @_;
403 local ($sftp->{_error}, $sftp->{_status}, $sftp->{_autodie});
404 !!$sftp->stat($name)
405 }
406
384407 1;
385408
00 package Net::SFTP::Foreign::Compat;
11
2 our $VERSION = '1.36';
2 our $VERSION = '1.68_04';
33
44 use warnings;
55 use strict;
3535 }
3636 }
3737 }
38
39 our %DEFAULTS = ( put => [],
40 get => [],
41 ls => [],
42 new => [] );
3843
3944 BEGIN {
4045 my @forbidden = qw( setcwd cwd open opendir sftpread sftpwrite seek
6772 $warn = sub { warn(CORE::join '', @_, "\n") };
6873 }
6974
70 my $sftp = $class->SUPER::new($host, %opts);
75 my $sftp = $class->SUPER::new($host, @{$DEFAULTS{new}}, %opts);
7176
7277 $sftp->{_compat_warn} = $warn;
7378
101106 my @content;
102107
103108 $sftp->SUPER::get($remote, $local,
109 @{$DEFAULTS{get}},
104110 dont_save => !defined($local),
105111 callback => sub {
106112 my ($sftp, $data, $off, $size) = @_;
118124 my ($sftp, $local, $remote, $cb) = @_;
119125
120126 $sftp->SUPER::put($local, $remote,
127 @{$DEFAULTS{put}},
121128 (defined $cb ? (callback => $cb) : ()));
122129 $sftp->_warn_error;
123130 !$sftp->SUPER::error;
127134 my ($sftp, $path, $cb) = @_;
128135 if ($cb) {
129136 $sftp->SUPER::ls($path,
137 @{$DEFAULTS{ls}},
130138 wanted => sub { _rebless_attrs($_[1]->{a});
131139 $cb->($_[1]);
132140 0 } );
133141 return ();
134142 }
135143 else {
136 if (my $ls = $sftp->SUPER::ls($path)) {
144 if (my $ls = $sftp->SUPER::ls($path, @{$DEFAULTS{ls}})) {
137145 _rebless_attrs($_->{a}) for @$ls;
138146 return @$ls;
139147 }
239247 parts of the program have to modified in order to move from Net::SFTP
240248 to Net::SFTP::Foreign.
241249
250 =head2 Setting defaults
251
252 The hash C<%Net::SFTP::Foreign::DEFAULTS> can be used to set default
253 values for L<Net::SFTP::Foreign> methods called under the hood and
254 otherwise not accesible through the Net::SFTP API.
255
256 The entries currently supported are:
257
258 =over
259
260 =item new => \@opts
261
262 extra options passed to Net::SFTP::Foreign constructor.
263
264 =item get => \@opts
265
266 extra options passed to Net::SFTP::Foreign::get method.
267
268 =item put => \@opts
269
270 extra options passed to Net::SFTP::Foreign::put method.
271
272 =item ls => \@opts
273
274 extra options passed to Net::SFTP::Foreign::ls method.
275
276 =back
277
242278 =head1 COPYRIGHT
243279
244 Copyright (c) 2006-2008 Salvador FandiE<ntilde>o
280 Copyright (c) 2006-2008, 2011 Salvador FandiE<ntilde>o
245281
246282 All rights reserved. This program is free software; you can
247283 redistribute it and/or modify it under the same terms as Perl itself.
7070 SFTP_ERR_REMOTE_STAT_FAILED => 1,
7171 SFTP_ERR_REMOTE_OPEN_FAILED => 2,
7272 SFTP_ERR_LOCAL_ALREADY_EXISTS => 3,
73 SFTP_ERR_LOCAL_OPEN_FAILED => 4,
73 # SFTP_ERR_LOCAL_OPEN_FAILED => 4,
74 SFTP_ERR_LOCAL_OPEN_FAILED => 26,
7475 SFTP_ERR_REMOTE_READ_FAILED => 5,
7576 SFTP_ERR_REMOTE_BLOCK_TOO_SMALL => 6,
7677 SFTP_ERR_LOCAL_WRITE_FAILED => 7,
9192 SFTP_ERR_REMOTE_RMDIR_FAILED => 23,
9293 SFTP_ERR_REMOTE_SETSTAT_FAILED => 24,
9394 SFTP_ERR_REMOTE_FSETSTAT_FAILED => 25,
94 SFTP_ERR_LOCAL_OPEN_FAILED => 26,
9595 SFTP_ERR_LOCAL_STAT_FAILED => 27,
9696 SFTP_ERR_LOCAL_READ_ERROR => 28,
9797 SFTP_ERR_REMOTE_READDIR_FAILED => 29,
117117 SFTP_ERR_REMOTE_FSTATVFS_FAILED => 49,
118118 SFTP_ERR_PASSWORD_AUTHENTICATION_FAILED => 50,
119119 SFTP_ERR_REMOTE_HARDLINK_FAILED => 51,
120 SFTP_ERR_LOCAL_RENAME_FAILED => 52,
120121 );
121122
122123 for my $key (keys %constants) {
00 package Net::SFTP::Foreign::Helpers;
11
2 our $VERSION = '1.57';
2 our $VERSION = '1.68_04';
33
44 use strict;
55 use warnings;
2525 _is_reg
2626 _do_nothing
2727 _glob_to_regex
28 _file_part
2829 _tcroak );
2930
3031 our $debug;
115116 local $@;
116117 local $SIG{__DIE__};
117118 local $SIG{__WARN__};
118 return @$l if eval { @$l >= 0 };
119 return ($l);
119 no warnings;
120 (eval { @$l; 1 } ? @$l : $l);
120121 }
121122
122123 sub _glob_to_regex {
173174 else {
174175 croak "invalid glob pattern";
175176 }
176
177177 }
178178 else {
179179 $wildcards--;
227227 }
228228
229229 sub _gen_dos2unix {
230 my $unix2dos = shift;
231 my $name = ($unix2dos ? 'unix2dos' : 'dos2unix');
230232 my $previous;
231233 my $done;
232234 sub {
233 $done and die "Internal error: bad calling sequence for unix2dos transformation";
235 $done and die "Internal error: bad calling sequence for $name transformation";
234236 my $adjustment = 0;
235237 for (@_) {
236238 if ($debug and $debug & 128) {
237 _debug ("before dos2unixunix2dos: previous: $previous, data follows...");
239 _debug ("before $name: previous: $previous, data follows...");
238240 _hexdump($_);
239241 }
240242 if (length) {
243245 $_ = "\x0d$_";
244246 }
245247 $adjustment -= $previous = s/\x0d\z//s;
246 $adjustment -= s/\x0d\x0a/\x0a/gs;
248 if ($unix2dos) {
249 $adjustment += s/(?<!\x0d)\x0a/\x0d\x0a/gs;
250 }
251 else {
252 $adjustment -= s/\x0d\x0a/\x0a/gs;
253 }
247254 }
248255 elsif ($previous) {
249256 $previous = 0;
252259 $_ = "\x0d";
253260 }
254261 if ($debug and $debug & 128) {
255 _debug ("after dos2unix: previous: $previous, adjustment: $adjustment, data follows...");
262 _debug ("after $name: previous: $previous, adjustment: $adjustment, data follows...");
256263 _hexdump($_);
257264 }
258265 return $adjustment;
259266 }
260267 }
261268 }
262
263 sub _unix2dos {
264 if ($debug and $debug & 128) {
265 _debug ("before unix2dos: data follows...");
266 _hexdump($_[0]);
267 }
268 my $adjustment = $_[0] =~ s/\x0a/\x0d\x0a/gs;
269 if ($debug and $debug & 128) {
270 _debug ("before unix2dos: adjustment: $adjustment, data follows...");
271 _hexdump($_[0]);
272 }
273 $adjustment;
274 }
275
276 sub _gen_unix2dos { \&_unix2dos }
277269
278270 sub _gen_converter {
279271 my $conversion = shift;
285277 return sub {
286278 my $before = length $_[0];
287279 $conversion->($_[0]);
288 length $_[0] - $before;
280 length($_[0]) - $before;
289281 }
290282 }
291283 else {
293285 }
294286 }
295287 elsif ($conversion eq 'dos2unix') {
296 return _gen_dos2unix;
288 return _gen_dos2unix(0);
297289 }
298290 elsif ($conversion eq 'unix2dos') {
299 return _gen_unix2dos
291 return _gen_dos2unix(1);
300292 }
301293 else {
302294 croak "unknown conversion '$conversion'";
307299 sub _is_dir { (0040000 & shift) == 0040000 }
308300 sub _is_reg { (0100000 & shift) == 0100000 }
309301
302 sub _file_part {
303 my $path = shift;
304 $path =~ m{([^/]*)$} or croak "unable to get file part from path '$path'";
305 $1;
306 }
307
310308 1;
311309
00 package Net::SFTP::Foreign;
11
2 our $VERSION = '1.67';
2 our $VERSION = '1.69';
33
44 use strict;
55 use warnings;
99
1010 use Symbol ();
1111 use Errno ();
12 use Scalar::Util;
12 use Fcntl;
1313
1414 BEGIN {
1515 if ($] >= 5.008) {
3131 our $debug;
3232 BEGIN { *Net::SFTP::Foreign::Helpers::debug = \$debug };
3333 use Net::SFTP::Foreign::Helpers qw(_is_reg _is_lnk _is_dir _debug
34 _sort_entries _gen_wanted _gen_converter
35 _hexdump _ensure_list _catch_tainted_args);
34 _sort_entries _gen_wanted
35 _gen_converter _hexdump
36 _ensure_list _catch_tainted_args
37 _file_part);
3638 use Net::SFTP::Foreign::Constants qw( :fxp :flags :att
3739 :status :error
3840 SSH2_FILEXFER_VERSION );
4547 my $windows;
4648
4749 BEGIN {
48 $windows = $^O =~ /Win32/;
50 $windows = $^O =~ /Win(?:32|64)/;
4951
5052 if ($^O =~ /solaris/i) {
5153 $dirty_cleanup = 1 unless defined $dirty_cleanup;
12431245 my ($sftp, $old, $new, %opts) = @_;
12441246
12451247 my $overwrite = delete $opts{overwrite};
1248 my $numbered = delete $opts{numbered};
1249 croak "'overwrite' and 'numbered' options can not be used together"
1250 if ($overwrite and $numbered);
12461251 %opts and _croak_bad_options(keys %opts);
12471252
12481253 if ($overwrite) {
12501255 $sftp->status != SSH2_FX_OP_UNSUPPORTED and return undef;
12511256 }
12521257
1253 # we are optimistic here and try to rename it without testing if a
1254 # file of the same name already exists first
1255 $sftp->_rename($old, $new) and return 1;
1256
1257 if ($overwrite and $sftp->status == SSH2_FX_FAILURE) {
1258 if ($sftp->realpath($old) eq $sftp->realpath($new)) {
1259 $sftp->_set_status(SSH2_FX_FAILURE);
1260 $sftp->_set_error(SFTP_ERR_REMOTE_RENAME_FAILED,
1261 "Couldn't rename, both '$old' and '$new' point to the same file");
1262 return undef;
1258 for (1) {
1259 local $sftp->{_autodie};
1260 # we are optimistic here and try to rename it without testing
1261 # if a file of the same name already exists first
1262 if (!$sftp->_rename($old, $new) and
1263 $sftp->status == SSH2_FX_FAILURE) {
1264 if ($numbered and $sftp->test_e($new)) {
1265 _inc_numbered($new);
1266 redo;
1267 }
1268 elsif ($overwrite) {
1269 my $rp_old = $sftp->realpath($old);
1270 my $rp_new = $sftp->realpath($new);
1271 if (defined $rp_old and defined $rp_new and $rp_old eq $rp_new) {
1272 $sftp->_clear_error;
1273 }
1274 elsif ($sftp->remove($new)) {
1275 $overwrite = 0;
1276 redo;
1277 }
1278 }
12631279 }
1264
1265 $sftp->remove($new);
1266 return $sftp->_rename($old, $new);
1267 }
1268 return undef;
1280 }
1281 $sftp->_ok_or_autodie;
12691282 }
12701283
12711284 sub atomic_rename {
13321345 my $method = shift;
13331346 sub {
13341347 my $sftp = shift;
1335 my $oerror = $sftp->{_error};
1336 my $ostatus = $sftp->{_status};
1337 my $ret = $sftp->$method(@_);
1338 if ($oerror) {
1339 $sftp->{_error} = $oerror;
1340 $sftp->{_status} = $ostatus;
1341 }
1342 $ret;
1348 local ($sftp->{_error}, $sftp->{_status}) if $sftp->{_error};
1349 $sftp->$method(@_);
13431350 }
13441351 }
13451352
13461353 *_close_save_status = _gen_save_status_method('close');
13471354 *_closedir_save_status = _gen_save_status_method('closedir');
1348
1355 *_remove_save_status = _gen_save_status_method('remove');
1356
1357 sub _inc_numbered {
1358 $_[0] =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e or
1359 $_[0] =~ s{((?:\.[^\.]*)?)$}{(1)$1};
1360 $debug and $debug & 128 and _debug("numbering to: $_[0]");
1361 }
13491362
13501363 ## High-level client -> server methods.
13511364
13561369
13571370 # returns true on success, undef on failure
13581371 sub get {
1359 @_ >= 3 or croak 'Usage: $sftp->get($remote, $local, %opts)';
1372 @_ >= 2 or croak 'Usage: $sftp->get($remote, $local, %opts)';
13601373 ${^TAINT} and &_catch_tainted_args;
13611374
13621375 my ($sftp, $remote, $local, %opts) = @_;
1376 defined $remote or croak "remote file path is undefined";
1377
1378 $sftp->_clear_error_and_status;
1379
13631380 $remote = $sftp->_rel2abs($remote);
1381 $local = _file_part($remote) unless defined $local;
13641382 my $local_is_fh = (ref $local and $local->isa('GLOB'));
1365
1366 $sftp->_clear_error_and_status;
13671383
13681384 my $cb = delete $opts{callback};
13691385 my $umask = delete $opts{umask};
13781394 my $dont_save = delete $opts{dont_save};
13791395 my $conversion = delete $opts{conversion};
13801396 my $numbered = delete $opts{numbered};
1397 my $cleanup = delete $opts{cleanup};
1398 my $atomic = delete $opts{atomic};
13811399
13821400 croak "'perm' and 'umask' options can not be used simultaneously"
13831401 if (defined $perm and defined $umask);
13871405 if ($resume and $append);
13881406 croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'"
13891407 if ($numbered and ($overwrite or $resume or $append));
1390
1408 croak "'atomic' can not be used with 'resume' or 'append'"
1409 if ($atomic and ($resume or $append));
13911410 if ($local_is_fh) {
13921411 my $append = 'option can not be used when target is a file handle';
13931412 $resume and croak "'resume' $append";
13941413 $overwrite and croak "'overwrite' $append";
13951414 $numbered and croak "'numbered' $append";
13961415 $dont_save and croak "'dont_save' $append";
1416 $atomic and croak "'croak' $append";
13971417 }
13981418 %opts and _croak_bad_options(keys %opts);
13991419
14161436 $overwrite = 1 unless (defined $overwrite or $local_is_fh or $numbered);
14171437 $copy_perm = 1 unless (defined $perm or defined $copy_perm or $local_is_fh);
14181438 $copy_time = 1 unless (defined $copy_time or $local_is_fh);
1419
1420 my $size;
1421 my $a = $sftp->stat($remote);
1422 if (defined $a) {
1423 $size = $a->size
1424 }
1425 else {
1426 return undef if ($copy_time or $copy_perm);
1427 $size = -1;
1428 }
1439 $cleanup = ($atomic || $numbered) unless defined $cleanup;
1440
1441 my $a = do {
1442 local $sftp->{_autodie};
1443 $sftp->stat($remote);
1444 };
1445 my ($rperm, $size, $atime, $mtime) = ($a ? ($a->perm, $a->size, $a->atime, $a->mtime) : ());
1446 $size = -1 unless defined $size;
1447
1448 if ($copy_time and not defined $atime) {
1449 $sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED,
1450 "Not enough information on stat, amtime not included");
1451 return undef;
1452 }
1453
1454 if ($copy_perm) {
1455 if (defined $rperm) {
1456 $perm = $rperm;
1457 }
1458 else {
1459 $sftp->_ok_or_autodie and $sftp->_set_error(SFTP_ERR_REMOTE_STAT_FAILED,
1460 "Not enough information on stat, mode not included");
1461 return undef
1462 }
1463 }
1464 $sftp->_clear_error_and_status;
14291465
14301466 if ($resume and $resume eq 'auto') {
14311467 undef $resume;
1432 if (my @lstat = CORE::stat $local) {
1433 if (defined $a and $a->mtime <= $lstat[9]) {
1434 $resume = 1;
1468 if (defined $mtime) {
1469 if (my @lstat = CORE::stat $local) {
1470 $resume = ($mtime <= $lstat[9]);
14351471 }
14361472 }
14371473 }
1474
1475 my ($atomic_numbered, $atomic_local, $atomic_cleanup);
14381476
14391477 my ($rfh, $fh);
14401478 my $askoff = 0;
14451483 defined $rfh or return undef;
14461484 }
14471485 else {
1448 unless ($local_is_fh or $overwrite or $append or $resume) {
1449 while (-e $local) {
1450 if ($numbered) {
1451 my $old = $local;
1452 $local =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e
1453 or $local =~ s{((?:\.[^\.]*)?)$}{(1)$1};
1454 $debug and $debug & 128 and _debug("numbering: $old => $local");
1455 }
1456 else {
1457 $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
1458 "local file $local already exists");
1459 return undef
1460 }
1486 unless ($local_is_fh or $overwrite or $append or $resume or $numbered) {
1487 if (-e $local) {
1488 $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
1489 "local file $local already exists");
1490 return undef
14611491 }
14621492 }
14631493
1464 if ($copy_perm) {
1465 my $aperm = $a->perm;
1466 $aperm = 0666 unless defined $aperm;
1467 $aperm =~ /^(\d+)$/ or die "perm is not numeric";
1468 $perm = int $1;
1494 if ($atomic) {
1495 $atomic_local = $local;
1496 $local .= sprintf("(%d).tmp", rand(10000));
1497 $atomic_numbered = $numbered;
1498 $numbered = 1;
1499 $debug and $debug & 128 and _debug("temporal local file name: $local");
14691500 }
14701501
1471 $perm = (0666 & $neg_umask)
1472 unless (defined $perm or $local_is_fh);
1502 $perm = (0666 & $neg_umask) unless defined $perm or $local_is_fh;
14731503
14741504 if ($resume) {
1475 if (CORE::open $fh, '>', $local) {
1505 if (CORE::open $fh, '+<', $local) {
14761506 binmode $fh;
14771507 CORE::seek($fh, 0, 2);
14781508 $askoff = CORE::tell $fh;
15061536 $lstart = 0 unless ($lstart and $lstart > 0);
15071537 }
15081538 else {
1509 my $lumask = ~$perm & 0666;
1510 umask $lumask;
1511 unlink $local unless $append;
1512 unless (CORE::open $fh, ($append ? '>>' : '>'), $local) {
1513 umask $oldumask;
1514 $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
1515 "Can't open $local", $!);
1516 return undef;
1517 }
1518 umask $oldumask;
1539 my $flags = Fcntl::O_CREAT|Fcntl::O_WRONLY;
1540 $flags |= Fcntl::O_APPEND if $append;
1541 $flags |= Fcntl::O_EXCL if ($numbered or (!$overwrite and !$append));
1542
1543 my $lumask = ~$perm & 0777;
1544
1545 unlink $local if ($overwrite and !$numbered);
1546
1547 while (1) {
1548 umask $lumask;
1549 sysopen ($fh, $local, $flags, $perm) and last;
1550 my $err = $!;
1551 umask $oldumask;
1552 unless ($numbered and -e $local) {
1553 $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
1554 "Can't open $local", $err);
1555 return undef;
1556 }
1557 _inc_numbered($local);
1558 }
1559 umask $oldumask;
1560 $$numbered = $local if ref $numbered;
15191561 binmode $fh;
1520 $lstart = CORE::tell $fh if $append;
1562 $lstart = sysseek($fh, 0, 1) if $append;
15211563 }
15221564 }
15231565
15251567 local ($@, $SIG{__DIE__}, $SIG{__WARN__});
15261568 my $e = eval { chmod($perm & $neg_umask, $local) };
15271569 if ($@ or $e <= 0) {
1570 my $err = $!;
1571 unlink $local;
15281572 $sftp->_set_error(SFTP_ERR_LOCAL_CHMOD_FAILED,
1529 "Can't chmod $local", ($@ ? $@ : $!));
1573 "Can't chmod $local", ($@ ? $@ : $err));
15301574 return undef
15311575 }
15321576 }
15351579 my $converter = _gen_converter $conversion;
15361580
15371581 my $rfid = $sftp->_rfid($rfh);
1538 defined $rfid or return undef;
1582 defined $rfid or die "internal error: rfid not defined";
15391583
15401584 my @msgid;
15411585 my @askoff;
15441588 my $n = 0;
15451589 local $\;
15461590 do {
1547 # disable autodie here in order to do not leave unhandled
1591 # Disable autodie here in order to do not leave unhandled
15481592 # responses queued on the connection in case of failure.
15491593 local $sftp->{_autodie};
1594
1595 # Again, once this point is reached, all code paths should end
1596 # through the CLEANUP block.
15501597
15511598 while (1) {
15521599 # request a new block if queue is not full
16101657 }
16111658 }
16121659 }
1613 };
1614
1615 $sftp->_get_msg for (@msgid);
1616
1617 if ($sftp->error) {
1618 # we are out of the pipeline loop, so we can now safely
1619 # rethrow any error when autodie is on.
1620 croak $sftp->error if $sftp->{_autodie};
1621 return undef
1622 }
1623
1624 # if a converter is in place, and aditional call has to be
1625 # performed in order to flush any pending buffered data
1626 if ($converter) {
1627 my $data = '';
1628 my $adjustment_before = $adjustment;
1629 $adjustment += $converter->($data);
1630
1631 if (length($data) and defined $cb) {
1632 # $size = $loff if ($loff > $size and $size != -1);
1633 $cb->($sftp, $data, $askoff + $adjustment_before, $size + $adjustment);
1634 return undef if $sftp->error;
1635 }
1636
1637 if (length($data) and !$dont_save) {
1638 unless (print $fh $data) {
1639 $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
1640 "unable to write data to local file $local", $!);
1641 return undef;
1660
1661 $sftp->_get_msg for (@msgid);
1662
1663 goto CLEANUP if $sftp->{_error};
1664
1665 # if a converter is in place, and aditional call has to be
1666 # performed in order to flush any pending buffered data
1667 if ($converter) {
1668 my $data = '';
1669 my $adjustment_before = $adjustment;
1670 $adjustment += $converter->($data);
1671
1672 if (length($data) and defined $cb) {
1673 # $size = $loff if ($loff > $size and $size != -1);
1674 $cb->($sftp, $data, $askoff + $adjustment_before, $size + $adjustment);
1675 goto CLEANUP if $sftp->{_error};
16421676 }
1643 }
1644 }
1645
1646 # we call the callback one last time with an empty string;
1647 if (defined $cb) {
1648 my $data = '';
1649 $cb->($sftp, $data, $askoff + $adjustment, $size + $adjustment);
1650 return undef if $sftp->error;
1651 if (length($data) and !$dont_save) {
1652 unless (print $fh $data) {
1653 $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
1654 "unable to write data to local file $local", $!);
1655 return undef;
1656 }
1657 }
1658 }
1659
1660 unless ($dont_save) {
1661 unless ($local_is_fh or CORE::close $fh) {
1662 $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
1663 "unable to write data to local file $local", $!);
1664 return undef;
1665 }
1666
1667 # we can be running on taint mode, so some checks are
1668 # performed to untaint data from the remote side.
1669
1670 if ($copy_time) {
1671 if ($a->flags & SSH2_FILEXFER_ATTR_ACMODTIME) {
1672 $a->atime =~ /^(\d+)$/ or die "Bad atime from remote file $remote";
1673 my $atime = int $1;
1674 $a->mtime =~ /^(\d+)$/ or die "Bad mtime from remote file $remote";
1675 my $mtime = int $1;
1676
1677 unless (utime $atime, $mtime, $local) {
1678 $sftp->_set_error(SFTP_ERR_LOCAL_UTIME_FAILED,
1679 "Can't utime $local", $!);
1680 return undef;
1677
1678 if (length($data) and !$dont_save) {
1679 unless (print $fh $data) {
1680 $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
1681 "unable to write data to local file $local", $!);
1682 goto CLEANUP;
16811683 }
16821684 }
16831685 }
1684 }
1685
1686 return !$sftp->{_error}
1686
1687 # we call the callback one last time with an empty string;
1688 if (defined $cb) {
1689 my $data = '';
1690 $cb->($sftp, $data, $askoff + $adjustment, $size + $adjustment);
1691 return undef if $sftp->error;
1692 if (length($data) and !$dont_save) {
1693 unless (print $fh $data) {
1694 $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
1695 "unable to write data to local file $local", $!);
1696 goto CLEANUP;
1697 }
1698 }
1699 }
1700
1701 unless ($dont_save) {
1702 unless ($local_is_fh or CORE::close $fh) {
1703 $sftp->_set_error(SFTP_ERR_LOCAL_WRITE_FAILED,
1704 "unable to write data to local file $local", $!);
1705 goto CLEANUP;
1706 }
1707
1708 # we can be running on taint mode, so some checks are
1709 # performed to untaint data from the remote side.
1710
1711 if ($copy_time and not utime($atime, $mtime, $local)) {
1712 $sftp->_set_error(SFTP_ERR_LOCAL_UTIME_FAILED,
1713 "Can't utime $local", $!);
1714 goto CLEANUP;
1715 }
1716 }
1717
1718 if ($atomic) {
1719 if (!$overwrite) {
1720 while (1) {
1721 # performing a non-overwriting atomic rename is
1722 # quite burdensome: first, link is tried, if that
1723 # fails, non-overwriting is favoured over
1724 # atomicity and an empty file is used to lock the
1725 # path before atempting an overwriting rename.
1726 if (link $local, $atomic_local) {
1727 unlink $local;
1728 last;
1729 }
1730 my $err = $!;
1731 unless (-e $atomic_local) {
1732 if (sysopen my $lock, $atomic_local,
1733 Fcntl::O_CREAT|Fcntl::O_EXCL|Fcntl::O_WRONLY,
1734 0600) {
1735 $atomic_cleanup = 1;
1736 goto OVERWRITE;
1737 }
1738 $err = $!;
1739 unless (-e $atomic_local) {
1740 $sftp->_set_error(SFTP_ERR_LOCAL_OPEN_FAILED,
1741 "Can't open $local", $err);
1742 goto CLEANUP;
1743 }
1744 }
1745 unless ($numbered) {
1746 $sftp->_set_error(SFTP_ERR_LOCAL_ALREADY_EXISTS,
1747 "local file $atomic_local already exists");
1748 goto CLEANUP;
1749 }
1750 _inc_numbered($atomic_local);
1751 }
1752 }
1753 else {
1754 OVERWRITE:
1755 unless (CORE::rename $local, $atomic_local) {
1756 $sftp->_set_error(SFTP_ERR_LOCAL_RENAME_FAILED,
1757 "Unable to rename temporal file to its final position '$atomic_local'", $!);
1758
1759 goto CLEANUP;
1760 }
1761 }
1762 $$atomic_numbered = $local if ref $atomic_numbered;
1763 }
1764
1765 CLEANUP:
1766 if ($cleanup and $sftp->{_error}) {
1767 unlink $local;
1768 unlink $atomic_local if $atomic_cleanup;
1769 }
1770
1771 }; # autodie flag is restored here!
1772
1773 $sftp->_ok_or_autodie;
16871774 }
16881775
16891776 # return file contents on success, undef on failure
16981785 my $rfh = $sftp->open($name)
16991786 or return undef;
17001787
1701 return scalar $sftp->readline($rfh, undef);
1788 scalar $sftp->readline($rfh, undef);
17021789 }
17031790
17041791 sub put {
1705 @_ >= 3 or croak 'Usage: $sftp->put($local, $remote, %opts)';
1792 @_ >= 2 or croak 'Usage: $sftp->put($local, $remote, %opts)';
17061793 ${^TAINT} and &_catch_tainted_args;
17071794
17081795 my ($sftp, $local, $remote, %opts) = @_;
1796 defined $local or croak "local file path is undefined";
1797
1798 $sftp->_clear_error_and_status;
1799
1800 my $local_is_fh = (ref $local and $local->isa('GLOB'));
1801 unless (defined $remote) {
1802 $local_is_fh and croak "unable to infer remote file name when a file handler is passed as local";
1803 $remote = (File::Spec->splitpath($local))[2];
1804 }
17091805 $remote = $sftp->_rel2abs($remote);
1710 my $local_is_fh = (ref $local and $local->isa('GLOB'));
1711
1712 $sftp->_clear_error_and_status;
17131806
17141807 my $cb = delete $opts{callback};
1715
17161808 my $umask = delete $opts{umask};
17171809 my $perm = delete $opts{perm};
1718 my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
1810 my $copy_perm = delete $opts{copy_perm};
1811 $copy_perm = delete $opts{copy_perms} unless defined $copy_perm;
17191812 my $copy_time = delete $opts{copy_time};
17201813 my $overwrite = delete $opts{overwrite};
17211814 my $resume = delete $opts{resume};
17251818 my $conversion = delete $opts{conversion};
17261819 my $late_set_perm = delete $opts{late_set_perm};
17271820 my $numbered = delete $opts{numbered};
1821 my $atomic = delete $opts{atomic};
1822 my $cleanup = delete $opts{cleanup};
17281823
17291824 croak "'perm' and 'umask' options can not be used simultaneously"
17301825 if (defined $perm and defined $umask);
17361831 if ($resume and $overwrite);
17371832 croak "'numbered' can not be used with 'overwrite', 'resume' or 'append'"
17381833 if ($numbered and ($overwrite or $resume or $append));
1834 croak "'atomic' can not be used with 'resume' or 'append'"
1835 if ($atomic and ($resume or $append));
17391836
17401837 %opts and _croak_bad_options(keys %opts);
17411838
17431840 $copy_perm = 1 unless (defined $perm or defined $copy_perm or $local_is_fh);
17441841 $copy_time = 1 unless (defined $copy_time or $local_is_fh);
17451842 $late_set_perm = $sftp->{_late_set_perm} unless defined $late_set_perm;
1843 $cleanup = ($atomic || $numbered) unless defined $cleanup;
17461844
17471845 my $neg_umask;
17481846 if (defined $perm) {
19062004 }
19072005 }
19082006
2007 my ($atomic_numbered, $atomic_remote);
2008
19092009 unless (defined $rfh) {
2010 if ($atomic) {
2011 # check that does not exist a file of the same name that
2012 # would block the rename operation at the end
2013 if (!($numbered or $overwrite) and
2014 $sftp->test_e($remote)) {
2015 $sftp->_set_status(SSH2_FX_FAILURE);
2016 $sftp->_set_error(SFTP_ERR_REMOTE_ALREADY_EXISTS,
2017 "Remote file '$remote' already exists");
2018 return undef;
2019 }
2020 $atomic_remote = $remote;
2021 $remote .= sprintf("(%d).tmp", rand(10000));
2022 $atomic_numbered = $numbered;
2023 $numbered = 1;
2024 $debug and $debug & 128 and _debug("temporal remote file name: $remote");
2025 }
19102026 if ($numbered) {
1911 while ($sftp->stat($remote)) {
1912 my $old = $remote;
1913 $remote =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e
1914 or $remote =~ s{((?:\.[^\.]*)?)$}{(1)$1};
1915 $debug and $debug & 128 and _debug("numbering remote: $old => $local");
2027 while (1) {
2028 local $sftp->{_autodie};
2029 $rfh = $sftp->open($remote,
2030 SSH2_FXF_WRITE | SSH2_FXF_CREAT | SSH2_FXF_EXCL,
2031 $attrs);
2032 last if ($rfh or
2033 $sftp->status != SSH2_FX_FAILURE or
2034 !$sftp->test_e($remote));
2035 _inc_numbered($remote);
19162036 }
2037 $sftp->_ok_or_autodie;
2038 $$numbered = $remote if ref $numbered;
19172039 }
1918
1919 $rfh = $sftp->open($remote,
1920 SSH2_FXF_WRITE | SSH2_FXF_CREAT |
1921 ($append ? 0 : ($overwrite ? SSH2_FXF_TRUNC : SSH2_FXF_EXCL)),
1922 $attrs)
1923 or return undef;
1924 }
1925
1926 # In some SFTP server implementations, open does not set the
1927 # attributes for existent files so we do it again. The
1928 # $late_set_perm work around is for some servers that do not
1929 # support changing the permissions of open files
1930 if (defined $perm and !$late_set_perm) {
1931 $sftp->fsetstat($rfh, $attrs)
1932 or return undef;
1933 }
1934
1935 my $rfid = $sftp->_rfid($rfh);
1936 defined $rfid or return undef;
1937
1938 # In append mode we add the size of the remote file in writeoff,
1939 # if lsize is undef, we initialize it to $writeoff:
1940 $lsize += $writeoff if ($append or not defined $lsize);
1941
1942 # when a converter is used, the EOF can become delayed by the
1943 # buffering introduced, we use $eof_t to account for that.
1944 my ($eof, $eof_t);
1945 my @msgid;
2040 else {
2041 $rfh = $sftp->open($remote,
2042 SSH2_FXF_WRITE | SSH2_FXF_CREAT |
2043 ($append ? 0 : ($overwrite ? SSH2_FXF_TRUNC : SSH2_FXF_EXCL)),
2044 $attrs)
2045 or return undef;
2046 }
2047 }
2048
2049 $sftp->_ok_or_autodie or return undef;
2050 # Once this point is reached and for the remaining of the sub,
2051 # code should never return but jump into the CLEANUP block.
2052
19462053 do {
1947 local $sftp->{_autodie};
2054 local $sftp->{autodie};
2055
2056 # In some SFTP server implementations, open does not set the
2057 # attributes for existent files so we do it again. The
2058 # $late_set_perm work around is for some servers that do not
2059 # support changing the permissions of open files
2060 if (defined $perm and !$late_set_perm) {
2061 $sftp->fsetstat($rfh, $attrs) or goto CLEANUP;
2062 }
2063
2064 my $rfid = $sftp->_rfid($rfh);
2065 defined $rfid or die "internal error: rfid is undef";
2066
2067 # In append mode we add the size of the remote file in
2068 # writeoff, if lsize is undef, we initialize it to $writeoff:
2069 $lsize += $writeoff if ($append or not defined $lsize);
2070
2071 # when a converter is used, the EOF can become delayed by the
2072 # buffering introduced, we use $eof_t to account for that.
2073 my ($eof, $eof_t);
2074 my @msgid;
19482075 OK: while (1) {
19492076 if (!$eof and @msgid < $queue_size) {
19502077 my ($data, $len);
20402167 $sftp->_get_msg for (@msgid);
20412168
20422169 $sftp->_close_save_status($rfh);
2170
2171 goto CLEANUP if $sftp->{_error};
2172
2173 # for servers that does not support setting permissions on open files
2174 if (defined $perm and $late_set_perm) {
2175 $sftp->setstat($remote, $attrs);
2176 }
2177
2178 if ($copy_time) {
2179 $attrs = Net::SFTP::Foreign::Attributes->new;
2180 $attrs->set_amtime($latime, $lmtime);
2181 $sftp->setstat($remote, $attrs) or goto CLEANUP;
2182 }
2183
2184 if ($atomic) {
2185 $sftp->rename($remote, $atomic_remote,
2186 overwrite => $overwrite,
2187 numbered => $atomic_numbered) or goto CLEANUP;
2188 }
2189
2190 CLEANUP:
2191 if ($cleanup and $sftp->{_error}) {
2192 warn "cleanup $remote";
2193 $sftp->_remove_save_status($remote);
2194 }
20432195 };
2044
2045 if ($sftp->error) {
2046 croak $sftp->error if $sftp->{_autodie};
2047 return undef;
2048 }
2049
2050 # for servers that does not support setting permissions on open files
2051 if (defined $perm and $late_set_perm) {
2052 $sftp->setstat($remote, $attrs)
2053 or return undef;
2054 }
2055
2056 if ($copy_time) {
2057 $attrs = Net::SFTP::Foreign::Attributes->new;
2058 $attrs->set_amtime($latime, $lmtime);
2059 $sftp->setstat($remote, $attrs);
2060 }
2061
2062 return $sftp->{_error} == 0;
2196 $sftp->_ok_or_autodie;
20632197 }
20642198
20652199 sub ls {
22742408
22752409 my $link = $sftp->readlink($remote) or return undef;
22762410
2411 # TODO: this is too weak, may contain race conditions.
22772412 if ($numbered) {
2278 while (-e $local) {
2279 my $old = $local;
2280 $local =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e
2281 or $local =~ s{((?:\.[^\.]*)?)$}{(1)$1};
2282 $debug and $debug & 128 and _debug("numbering: $old => $local");
2283 }
2413 _inc_numbered($local) while -e $local;
22842414 }
22852415 elsif (-e $local) {
22862416 if ($overwrite) {
22982428 "creation of symlink '$local' failed", $!);
22992429 return undef;
23002430 }
2431 $$numbered = $local if ref $numbered;
2432
23012433 1;
23022434 }
23032435
23302462 return undef;
23312463 }
23322464
2333 if ($numbered) {
2334 while ($sftp->stat($remote)) {
2335 my $old = $remote;
2336 $remote =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e
2337 or $remote =~ s{((?:\.[^\.]*)?)$}{(1)$1};
2338 $debug and $debug & 128 and _debug("numbering remote: $old => $local");
2339 }
2340 }
2341 $sftp->remove($remote) if $overwrite;
2342 $sftp->symlink($remote, $target);
2465 while (1) {
2466 local $sftp->{_autodie};
2467 $sftp->symlink($remote, $target);
2468 if ($sftp->error and
2469 $sftp->status == SSH2_FX_FAILURE) {
2470 if ($numbered and $sftp->test_e($remote)) {
2471 _inc_numbered($remote);
2472 redo;
2473 }
2474 elsif ($overwrite and $sftp->_remove_save_status($remote)) {
2475 $overwrite = 0;
2476 redo;
2477 }
2478 }
2479 last
2480 }
2481 $$numbered = $remote if ref $numbered;
2482 $sftp->_ok_or_autodie;
23432483 }
23442484
23452485 sub rget {
2346 @_ >= 3 or croak 'Usage: $sftp->rget($remote, $local, %opts)';
2486 @_ >= 2 or croak 'Usage: $sftp->rget($remote, $local, %opts)';
23472487 ${^TAINT} and &_catch_tainted_args;
2348
23492488 my ($sftp, $remote, $local, %opts) = @_;
2489
2490 defined $remote or croak "remote file path is undefined";
2491 $local = File::Spec->curdir unless defined $local;
23502492
23512493 # my $cb = delete $opts{callback};
23522494 my $umask = delete $opts{umask};
23532495 my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
23542496 my $copy_time = delete $opts{copy_time};
2355 my $block_size = delete $opts{block_size};
2356 my $queue_size = delete $opts{queue_size};
2357 my $overwrite = delete $opts{overwrite};
23582497 my $newer_only = delete $opts{newer_only};
23592498 my $on_error = delete $opts{on_error};
23602499 local $sftp->{_autodie} if $on_error;
23612500 my $ignore_links = delete $opts{ignore_links};
2362 my $conversion = delete $opts{conversion};
2363 my $resume = delete $opts{resume};
2364 my $numbered = delete $opts{numbered};
2365
2366 if ($resume and $conversion) {
2367 carp "resume option is useless when data conversion has also been requested";
2368 undef $resume;
2369 }
23702501
23712502 # my $relative_links = delete $opts{relative_links};
23722503
23732504 my $wanted = _gen_wanted( delete $opts{wanted},
23742505 delete $opts{no_wanted} );
2506
2507 my %get_opts = (map { $_ => delete $opts{$_} }
2508 qw(block_size queue_size overwrite conversion
2509 resume numbered atomic));
2510
2511 if ($get_opts{resume} and $get_opts{conversion}) {
2512 carp "resume option is useless when data conversion has also been requested";
2513 delete $get_opts{resume};
2514 }
2515
2516 my %get_symlink_opts = (map { $_ => $get_opts{$_} }
2517 qw(overwrite numbered));
23752518
23762519 %opts and _croak_bad_options(keys %opts);
23772520
24322575 ($lpath) = $lpath =~ /(.*)/ if ${^TAINT};
24332576 if (_is_lnk($e->{a}->perm) and !$ignore_links) {
24342577 if ($sftp->get_symlink($fn, $lpath,
2435 overwrite => $overwrite,
2436 numbered => $numbered,
2437 copy_time => $copy_time)) {
2578 copy_time => $copy_time,
2579 %get_symlink_opts)) {
24382580 $count++;
24392581 return undef;
24402582 }
24472589 }
24482590 else {
24492591 if ($sftp->get($fn, $lpath,
2450 overwrite => $overwrite,
2451 numbered => $numbered,
2452 queue_size => $queue_size,
2453 block_size => $block_size,
24542592 copy_perm => $copy_perm,
24552593 copy_time => $copy_time,
2456 conversion => $conversion,
2457 resume => $resume )) {
2594 %get_opts)) {
24582595 $count++;
24592596 return undef;
24602597 }
24832620 }
24842621
24852622 sub rput {
2486 @_ >= 3 or croak 'Usage: $sftp->rput($local, $remote, %opts)';
2623 @_ >= 2 or croak 'Usage: $sftp->rput($local, $remote, %opts)';
24872624 ${^TAINT} and &_catch_tainted_args;
24882625
24892626 my ($sftp, $local, $remote, %opts) = @_;
2627
2628 defined $local or croak "local path is undefined";
2629 $remote = '.' unless defined $remote;
24902630
24912631 # my $cb = delete $opts{callback};
24922632 my $umask = delete $opts{umask};
24932633 my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
24942634 my $copy_time = delete $opts{copy_time};
2495 my $block_size = delete $opts{block_size};
2496 my $queue_size = delete $opts{queue_size};
2497 my $overwrite = delete $opts{overwrite};
2498 my $numbered = delete $opts{numbered};
2635
24992636 my $newer_only = delete $opts{newer_only};
25002637 my $on_error = delete $opts{on_error};
25012638 local $sftp->{_autodie} if $on_error;
25022639 my $ignore_links = delete $opts{ignore_links};
2503 my $conversion = delete $opts{conversion};
2504 my $resume = delete $opts{resume};
2505 my $late_set_perm = delete $opts{late_set_perm};
2506
2507 # my $relative_links = delete $opts{relative_links};
25082640
25092641 my $wanted = _gen_wanted( delete $opts{wanted},
25102642 delete $opts{no_wanted} );
2643
2644 my %put_opts = (map { $_ => delete $opts{$_} }
2645 qw(block_size queue_size overwrite conversion
2646 resume numbered late_set_perm atomic));
2647
2648 my %put_symlink_opts = (map { $_ => $put_opts{$_} }
2649 qw(overwrite numbered));
25112650
25122651 %opts and _croak_bad_options(keys %opts);
25132652
25872726 my (undef, $d, $f) = File::Spec->splitpath($1);
25882727 my $rpath = $sftp->join($remote, File::Spec->splitdir($d), $f);
25892728 if (_is_lnk($e->{a}->perm) and !$ignore_links) {
2590 if ($sftp->put_symlink($fn, $remote,
2591 overwrite => $overwrite,
2592 numbered => $numbered)) {
2729 if ($sftp->put_symlink($fn, $rpath,
2730 %put_symlink_opts)) {
25932731 $count++;
25942732 return undef;
25952733 }
26052743 }
26062744 else {
26072745 if ($sftp->put($fn, $rpath,
2608 overwrite => $overwrite,
2609 numbered => $numbered,
2610 queue_size => $queue_size,
2611 block_size => $block_size,
26122746 perm => ($copy_perm ? $e->{a}->perm : 0777) & $mask,
26132747 copy_time => $copy_time,
2614 conversion => $conversion,
2615 resume => $resume,
2616 late_set_perm => $late_set_perm )) {
2748 %put_opts)) {
26172749 $count++;
26182750 return undef;
26192751 }
26442776 @_ >= 2 or croak 'Usage: $sftp->mget($remote, $localdir, %opts)';
26452777 ${^TAINT} and &_catch_tainted_args;
26462778
2647 my $sftp = shift;
2648 my $remote = shift;
2649 my $localdir = (@_ & 1 ? shift : undef);
2650 my %opts = @_;
2779 my ($sftp, $remote, $localdir, %opts) = @_;
2780
2781 defined $remote or croak "remote pattern is undefined";
26512782
26522783 my $on_error = $opts{on_error};
26532784 local $sftp->{_autodie} if $on_error;
26622793
26632794 my %get_opts = (map { $_ => delete $opts{$_} }
26642795 qw(umask copy_perm copy_time block_size queue_size
2665 overwrite conversion resume numbered));
2796 overwrite conversion resume numbered atomic));
26662797
26672798 %opts and _croak_bad_options(keys %opts);
26682799
27002831
27012832 sub mput {
27022833 @_ >= 2 or croak 'Usage: $sftp->mput($local, $remotedir, %opts)';
2703 my $sftp = shift;
2704 my $local = shift;
2705 my $remotedir = (@_ & 1 ? shift : undef);
2706 my %opts = @_;
2834
2835 my ($sftp, $local, $remotedir, %opts) = @_;
2836
2837 defined $local or die "local pattern is undefined";
27072838
27082839 my $on_error = $opts{on_error};
27092840 local $sftp->{_autodie} if $on_error;
27172848
27182849 my %put_opts = (map { $_ => delete $opts{$_} }
27192850 qw(umask copy_perm copy_time block_size queue_size
2720 overwrite conversion resume numbered late_set_perm));
2851 overwrite conversion resume numbered late_set_perm atomic));
27212852
27222853 %opts and _croak_bad_options(keys %opts);
27232854
30353166 $debug and $debug & 4 and Net::SFTP::Foreign::_debug("$self->DESTROY called (sftp: ".($sftp||'').")");
30363167
30373168 if ($self->_check and $sftp) {
3169 local $sftp->{_autodie};
30383170 $sftp->_close_save_status($self)
30393171 }
30403172 }
30753207 $debug and $debug & 4 and Net::SFTP::Foreign::_debug("$self->DESTROY called (sftp: ".($sftp||'').")");
30763208
30773209 if ($self->_check and $sftp) {
3210 local $sftp->{_autodie};
30783211 $sftp->_closedir_save_status($self)
30793212 }
30803213 }
32323365
32333366 port number where the remote SSH server is listening
32343367
3368 =item ssh1 =E<gt> 1
3369
3370 use old SSH1 approach for starting the remote SFTP server.
3371
32353372 =item more =E<gt> [@more_ssh_args]
32363373
32373374 additional args passed to C<ssh> command.
32493386 more => "-c $cipher" # wrong!!!
32503387 more => [-c => $cipher] # right
32513388
3389 =item timeout =E<gt> $seconds
3390
3391 when this parameter is set, the connection is dropped if no data
3392 arrives on the SSH socket for the given time while waiting for some
3393 command to complete.
3394
3395 When the timeout expires, the current method is aborted and
3396 the SFTP connection becomes invalid.
3397
3398 =item fs_encoding =E<gt> $encoding
3399
3400 Version 3 of the SFTP protocol (the one supported by this module)
3401 knows nothing about the character encoding used on the remote
3402 filesystem to represent file and directory names.
3403
3404 This option allows to select the encoding used in the remote
3405 machine. The default value is C<utf8>.
3406
3407 For instance:
3408
3409 $sftp = Net::SFTP::Foreign->new('user@host', fs_encoding => 'latin1');
3410
3411 will convert any path name passed to any method in this package to its
3412 C<latin1> representation before sending it to the remote side.
3413
3414 Note that this option will not affect file contents in any way.
3415
3416 This feature is not supported in perl 5.6 due to incomplete Unicode
3417 support in the interpreter.
3418
3419 =item key_path =E<gt> $filename
3420
3421 asks C<ssh> to use the key in the given file for authentication.
3422
3423 =item password =E<gt> $password
3424
3425 =item passphrase =E<gt> $passphrase
3426
3427 uses L<Expect> to handle password authentication or keys requiring a
3428 passphrase.
3429
3430 Note that password authentication on Windows OSs only works when the
3431 Cygwin port of Perl is used.
3432
3433 =item expect_log_user =E<gt> $bool
3434
3435 activates password/passphrase authentication interaction logging (see
3436 C<Expect::log_user> method documentation).
3437
3438 =item ssh_cmd =E<gt> $sshcmd
3439
3440 =item ssh_cmd =E<gt> \@sshcmd
3441
3442 name of the external SSH client. By default C<ssh> is used.
3443
3444 For instance:
3445
3446 $sftp = Net::SFTP::Foreign->new($host, ssh_cmd => 'plink');
3447
3448 When an array reference is used, its elements are inserted at the
3449 beginning of the system call. That allows, for instance, to connect to
3450 the target host through some SSH proxy:
3451
3452 $sftp = Net::SFTP::Foreign->new($host,
3453 ssh_cmd => qw(ssh -l user proxy.server ssh));
3454
3455 But note that the module will not handle password authentication for
3456 those proxies.
3457
32523458 =item ssh_cmd_interface =E<gt> 'plink' or 'ssh' or 'tectia'
32533459
32543460 declares the command line interface that the SSH client used to
32573463
32583464 This option would be rarely required as the module infers the
32593465 interface from the SSH command name.
3260
3261 =item timeout =E<gt> $seconds
3262
3263 when this parameter is set, the connection is dropped if no data
3264 arrives on the SSH socket for the given time while waiting for some
3265 command to complete.
3266
3267 When the timeout expires, the current method is aborted and
3268 the SFTP connection becomes invalid.
3269
3270 =item fs_encoding =E<gt> $encoding
3271
3272 Version 3 of the SFTP protocol (the one supported by this module)
3273 knows nothing about the character encoding used on the remote
3274 filesystem to represent file and directory names.
3275
3276 This option allows to select the encoding used in the remote
3277 machine. The default value is C<utf8>.
3278
3279 For instance:
3280
3281 $sftp = Net::SFTP::Foreign->new('user@host', fs_encoding => 'latin1');
3282
3283 will convert any path name passed to any method in this package to its
3284 C<latin1> representation before sending it to the remote side.
3285
3286 Note that this option will not affect file contents in any way.
3287
3288 This feature is not supported in perl 5.6 due to incomplete Unicode
3289 support in the interpreter.
3290
3291 =item key_path =E<gt> $filename
3292
3293 asks C<ssh> to use the key in the given file for authentication.
3294
3295 =item password =E<gt> $password
3296
3297 =item passphrase =E<gt> $passphrase
3298
3299 uses L<Expect> to handle password authentication or keys requiring a
3300 passphrase.
3301
3302 Note that password authentication on Windows OSs only works when the
3303 Cygwin port of Perl is used.
3304
3305 =item expect_log_user =E<gt> $bool
3306
3307 activates password/passphrase authentication interaction logging (see
3308 C<Expect::log_user> method documentation).
3309
3310 =item ssh_cmd =E<gt> $sshcmd
3311
3312 name of the external SSH client. By default C<ssh> is used.
3313
3314 For instance:
3315
3316 my $sftp = Net::SFTP::Foreign->new($host, ssh_cmd => 'plink');
3317
3318 =item ssh1 =E<gt> 1
3319
3320 use old SSH1 approach for starting the remote SFTP server.
33213466
33223467 =item transport =E<gt> $fh
33233468
35843729 will copy the remote file as "data.txt" the first time and as
35853730 "data(1).txt" the second one.
35863731
3732 If a scalar reference is passed as the numbered value, the final
3733 target will be stored in the value pointed by the reference. For
3734 instance:
3735
3736 my $target;
3737 $sftp->get("data.txt", "data.txt", numbered => \$target);
3738 say "file was saved as $target" unless $sftp->error
3739
3740 =item atomic =E<gt> 1
3741
3742 The remote file contents are transferred into a temporal file that
3743 once the copy completes is renamed to the target destination.
3744
3745 If not-overwrite of remote files is also requested, an empty file may
3746 appear at the target destination before the rename operation is
3747 performed. This is due to limitations of some operating/file systems.
3748
3749 =item cleanup =E<gt> 1
3750
3751 If the transfer fails, remove the incomplete file.
3752
3753 This option is set to by default when there is not possible to resume
3754 the transfer afterwards (i.e., when using `atomic` or `numbered`
3755 options).
3756
35873757 =item conversion =E<gt> $conversion
35883758
35893759 on the fly data conversion of the file contents can be performed with
36273797
36283798 =item block_size =E<gt> $bytes
36293799
3630 size of the blocks the file is being splittered on for
3631 transfer. Incrementing this value can improve performance but some
3632 servers limit the maximum size.
3800 size of the blocks the file is being split on for transfer.
3801 Incrementing this value can improve performance but some servers limit
3802 the maximum size.
36333803
36343804 =item queue_size =E<gt> $size
36353805
36963866 sets the permision mask of the file to be $perm, umask and local
36973867 permissions are ignored.
36983868
3869 =item overwrite =E<gt> 0
3870
3871 by default C<put> will overwrite any pre-existent file with the same
3872 name at the remote side. Setting this flag to zero will make the
3873 method fail in that case.
3874
3875 =item numbered =E<gt> 1
3876
3877 when required, adds a sequence number to local file names in order to
3878 avoid overwriting pre-existent files. Off by default.
3879
36993880 =item append =E<gt> 1
37003881
37013882 appends the local file at the end of the remote file instead of
37023883 overwriting it. If the remote file does not exist a new one is
3703 created.
3884 created. Off by default.
37043885
37053886 =item resume =E<gt> 1 | 'auto'
37063887
37083889
37093890 If the C<auto> value is given, the transfer will be resumed only when
37103891 the remote file is newer than the local one.
3892
3893 =item atomic =E<gt> 1
3894
3895 The local file contents are transferred into a temporal file that
3896 once the copy completes is renamed to the target destination.
3897
3898 This operation relies on the SSH server to perform an
3899 overwriting/non-overwritting atomic rename operation free of race
3900 conditions.
3901
3902 OpenSSH server does it correctly on top of Linux/UNIX native file
3903 systems (i.e. ext[234], ffs or zfs) but has problems on file systems
3904 not supporting hard links (i.e. FAT) or on operating systems with
3905 broken POSIX semantics as Windows.
3906
3907 =item cleanup =E<gt> 1
3908
3909 If the transfer fails, attempts to remove the incomplete file.
3910
3911 Cleanup may fail if for example the SSH connection gets broken.
3912
3913 This option is set to by default when there is not possible to resume
3914 the transfer afterwards (i.e., when using `atomic` or `numbered`
3915 options).
3916
37113917
37123918 =item conversion =E<gt> $conversion
37133919
37383944
37393945 =item block_size =E<gt> $bytes
37403946
3741 size of the blocks the file is being splittered on for
3742 transfer. Incrementing this value can improve performance but some
3743 servers limit its size and if this limit is overpassed the command
3744 will fail.
3947 size of the blocks the file is being split on for transfer.
3948 Incrementing this value can improve performance but some servers limit
3949 its size and if this limit is overpassed the command will fail.
37453950
37463951 =item queue_size =E<gt> $size
37473952
37974002
37984003 =item wanted =E<gt> qr/.../
37994004
3800 Only elements which filename match the regular expression are included
4005 Only elements whose filename matchs the regular expression are included
38014006 on the listing.
38024007
38034008 =item wanted =E<gt> sub {...}
40834288
40844289 =item numbered =E<gt> $bool
40854290
4086 when required adds a sequence number to local file names in order to
4087 avoid overwriting already existent files. Off by default.
4291 when required, adds a sequence number to local file names in order to
4292 avoid overwriting pre-existent remote files. Off by default.
40884293
40894294 =item newer_only =E<gt> $bool
40904295
41114316 it is not possible to copy child files without creating the directory
41124317 first!).
41134318
4319 =item atomic =E<gt> 1
4320
41144321 =item block_size =E<gt> $block_size
41154322
41164323 =item queue_size =E<gt> $queue_size
41784385 If a directory is discarded all of its contents are also discarded (as
41794386 it is not possible to copy child files without creating the directory
41804387 first!).
4388
4389 =item atomic =E<gt> 1
41814390
41824391 =item block_size =E<gt> $block_size
41834392
46094818
46104819 =item conversion =E<gt> 'dos2unix'
46114820
4612 Converts LF+CR line endings (as commonly used under MS-DOS) to LF
4821 Converts CR+LF line endings (as commonly used under MS-DOS) to LF
46134822 (Unix).
46144823
46154824 =item conversion =E<gt> 'unix2dos'
46164825
4617 Converts LF line endings (Unix) to LF+CR (DOS).
4826 Converts LF line endings (Unix) to CR+LF (DOS).
46184827
46194828 =item conversion =E<gt> sub { CONVERT $_[0] }
46204829
4621 When a callback is given, it is called repeatly as chunks of data
4830 When a callback is given, it is invoked repeatly as chunks of data
46224831 become available. It has to change C<$_[0]> in place in order to
46234832 perform the conversion.
46244833
48265035
48275036 =item - Doesn't work on VMS:
48285037
4829 The problem is related to L<IPC::Open2> not working on VMS. Patches
5038 The problem is related to L<IPC::Open3> not working on VMS. Patches
48305039 are welcome!
48315040
48325041 =item - Dirty cleanup:
48485057 interacting with SFTP servers that follow the SFTP specification, the
48495058 C<symlink> method will interpret its arguments in reverse order.
48505059
5060 =item - IPC::Open3 bugs on Windows
5061
5062 On Windows the IPC::Open3 module is used to spawn the slave SSH
5063 process. That module has several nasty bugs (related to STDIN, STDOUT
5064 and STDERR being closed or not being assigned to file descriptors 0, 1
5065 and 2 respectively) that will cause the connection to fail.
5066
5067 Specifically this is known to happen under mod_perl/mod_perl2.
5068
48515069 =back
48525070
48535071 Also, the following features should be considered experimental:
48545072
48555073 - support for Tectia server
4856
4857 - redirecting SSH stderr stream
4858
4859 - multi-backend support
48605074
48615075 - numbered feature
48625076
48965110 L<Net::OpenSSH>.
48975111
48985112 L<Net::SFTP::Foreign::Backend::Net_SSH2> allows to run
4899 Net::SFTP::Foreign on top of L<Net::SSH2>.
5113 Net::SFTP::Foreign on top of L<Net::SSH2> (nowadays, this combination
5114 is probably the best option under Windows).
49005115
49015116 Modules offering similar functionality available from CPAN are
49025117 L<Net::SFTP> and L<Net::SSH2>.
1212 use File::Spec;
1313 use Cwd qw(getcwd);
1414
15 my $server; # = 'localhost';
16 my $sscmd = sftp_server;
17
15 my $salva = eval "no warnings; getlogin eq 'salva'";
1816 plan skip_all => "tests not supported on inferior OS"
19 if (is_windows and eval "no warnings; getlogin ne 'salva'");
20 plan skip_all => "sftp-server not found"
21 unless defined $sscmd;
22
23 plan tests => 742;
17 if (is_windows and not $salva);
18
19 my @new_args = new_args;
20
21 plan tests => 790;
2422
2523 use_ok('Net::SFTP::Foreign');
2624 use Net::SFTP::Foreign::Constants qw(:flags);
3230
3331 # don't set the alarm if we are being debugged!
3432 alarm 300 unless exists ${DB::}{sub};
35
36 my @new_args = defined $server
37 ? (host => $server, timeout => 20)
38 : (open2_cmd => $sscmd, timeout => 20);
3933
4034 my $sftp = eval { Net::SFTP::Foreign->new(@new_args) };
4135 diag($@) if $@;
117111 ok ($sftp->get($drfn, $dlfn1), "get - $i");
118112 diag ($sftp->error) if $sftp->error;
119113 ok(!filediff($drfn_l, $dlfn1), "get - file content - $i");
114 unlink $dlfn1;
115
116 my $c = 0;
117 ok ($sftp->get($drfn, $dlfn1, conversion => sub { $c = 1 } ), "get with conversion - $i");
118 diag ($sftp->error) if $sftp->error;
119 ok(!filediff($drfn_l, $dlfn1), "get with conversion - file content - $i");
120 ok($c, "get with conversion - conversion done - $i");
120121 unlink $dlfn1;
121122
122123 ok (open(F, '>', $dlfn1), "get fh - open - $i");
1212 use File::Spec;
1313 use Cwd qw(getcwd);
1414
15 my $server; # = 'localhost';
16 my $sscmd = sftp_server;
17
1815 plan skip_all => "tests not supported on inferior OS"
1916 if (is_windows and eval "no warnings; getlogin ne 'salva'");
20 plan skip_all => "sftp-server not found"
21 unless defined $sscmd;
2217
23 plan tests => 211;
18 my @new_args = new_args;
19
20 plan tests => 223;
2421
2522 use_ok('Net::SFTP::Foreign');
2623 use Net::SFTP::Foreign::Constants qw(:flags);
3229
3330 # don't set the alarm if we are being debugged!
3431 alarm 300 unless exists ${DB::}{sub};
35
36 my @new_args = defined $server
37 ? (host => $server, timeout => 20)
38 : (open2_cmd => $sscmd, timeout => 20);
3932
4033 chdir 't';
4134 my $lcwd = File::Spec->rel2abs('.');
6356 diag ($sftp->error) if $sftp->error;
6457
6558 ok(!filediff('data.txd', 'copied.txd'), "get conversion unix2dos ok - $bs");
59 unlink 'copied.txd';
60
61 ok($sftp->get('data.txd', 'copied.txd', conversion => 'unix2dos'), "get unix2dos when already in dos format - $bs");
62 diag ($sftp->error) if $sftp->error;
63
64 ok(!filediff('data.txd', 'copied.txd'), "get conversion unix2dos when already is dos format ok - $bs");
6665 unlink 'copied.txd';
6766
6867 ok($sftp->get('data.txd', 'copied.txu', conversion => 'dos2unix'), "get dos2unix - $bs");
77 use lib "./t";
88 use common;
99
10 my $server; # = 'localhost';
11 my $sscmd = sftp_server;
12
1310 plan skip_all => "tests not supported on inferior OS"
1411 if (is_windows and eval "no warnings; getlogin ne 'salva'");
15 plan skip_all => "sftp-server not found"
16 unless defined $sscmd;
12
13 my @new_args = new_args;
1714
1815 plan tests => 2;
1916
2017 use Net::SFTP::Foreign;
2118
22 my $sftp = Net::SFTP::Foreign->new(open2_cmd => $sscmd, timeout => 20);
19 my $sftp = Net::SFTP::Foreign->new(@new_args);
2320 my $fn = File::Spec->rel2abs('t/data.txd');
2421
2522 ok(my $fh = $sftp->open($fn), "open");
2323 $pf = Win32::GetFolderPath(Win32::CSIDL_PROGRAM_FILES());
2424 };
2525 $pf = "C:/Program Files/" unless defined $pf;
26
26
2727 @ssh = ("$pf/openssh/bin/ssh.exe",
2828 "$pf/openssh/usr/bin/ssh.exe",
2929 "$pf/bin/ssh.exe",
4848
4949 SEARCH: for (@ssh) {
5050 my ($vol, $dir) = File::Spec->splitpath($_);
51
51
5252 my $up = File::Spec->rel2abs(File::Spec->catpath($vol, $dir, File::Spec->updir));
53
53
5454 for ( File::Spec->catfile($vol, $dir, $ssname),
5555 File::Spec->catfile($up, 'lib', $ssname),
5656 File::Spec->catfile($up, 'libexec', $ssname),
6262
6363 if (-x $_) {
6464 $sscmd = $_;
65 diag "sftp-server found at $_\n";
6665 last SEARCH;
6766 }
6867 }
8584 while (1) {
8685 my $la = read($fa, my $da, 2048);
8786 my $lb = read($fb, my $db, 2048);
88
8987 return 1 unless (defined $la and defined $lb);
9088 return 1 if $la != $lb;
9189 return 0 if $la == 0;
103101 close DL;
104102 }
105103
104 sub new_args {
105 my $host = $ENV{NET_SFTP_FOREIGN_TESTING_HOST}; # = 'localhost';
106 my $backend = $ENV{NET_SFTP_FOREIGN_TESTING_BACKEND};
107 my @diag;
108
109 my @args = (timeout => 20);
110 if (defined $backend) {
111 push @args, backend => $backend;
112 push @diag, "using $backend backend";
113 }
114 if (defined $host) {
115 push @diag, "connecting to host $host";
116 push @args, host => $host;
117 }
118 else {
119 my $ss_cmd = sftp_server;
120 defined $ss_cmd or plan skip_all => 'sftp-server not found';
121 push @diag, "sftp-server found at $ss_cmd";
122 push @args, open2_cmd => $ss_cmd;
123 }
124 diag join(", ", @diag) if @diag;
125 @args;
126 }
127
106128 1;