Codebase list libnet-sftp-foreign-perl / 523774b
New upstream release. Gregor Herrmann 15 years ago
8 changed file(s) with 379 addition(s) and 175 deletion(s). Raw diff Collapse all Expand all
00 Revision history for Net::SFTP::Foreign
1
2 1.38 May 20, 2008
3 - add experimental support for plink command
4 - on get, don't change file size passed to callback
5 - on get, survive stat failure for servers with stat/readdir
6 disabled (bug reported by Hussain Syed)
7 - default open mode set to read
8 - add support for block_size and queue_size constructor
9 arguments
10 - limit usage of Expect and PTYs to authentication phase (bug
11 reported by Tom Warkentin)
12 - honour copy_perm option in put method (bug report by Bruce
13 Harold)
14 - copy_perms option renamed to copy_perm for consistency
15 (copy_perms still supported)
16 - glob optimization
17 - typo in Net::SFTP::Foreign::Common::_set_errno was not
18 setting $! correctly (bug report by Rafael Kitover)
19 - add debugging support to _do_io and _set_(status|error)
120
221 1.36 Apr 18, 2008
322 - forbid usage of Net::SFTP::Foreign methods from Compat
0 --- #YAML:1.0
1 name: Net-SFTP-Foreign
2 version: 1.36
3 abstract: Secure File Transfer Protocol client
4 license: ~
5 generated_by: ExtUtils::MakeMaker version 6.32
6 distribution_type: module
7 requires:
0 # http://module-build.sourceforge.net/META-spec.html
1 #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
2 name: Net-SFTP-Foreign
3 version: 1.38
4 version_from: lib/Net/SFTP/Foreign.pm
5 installdirs: site
6 requires:
87 Scalar::Util: 0
98 Test::More: 0
10 meta-spec:
11 url: http://module-build.sourceforge.net/META-spec-v1.2.html
12 version: 1.2
13 author:
14 - Salvador Fandino <sfandino@yahoo.com>
9
10 distribution_type: module
11 generated_by: ExtUtils::MakeMaker version 6.30_01
66
77 PREREQUISITES
88
9 An external ssh2 client reachable from your PATH.
9 An external SSH2 client reachable from your PATH.
1010
1111 Perl modules:
1212
1313 Test::More (mandatory)
1414 File::Which (optional, only for testing)
1515 Sort::Key (optional, for better performance)
16 Expect and its dependencies (optional, only required if
17 password authentication is going to be used)
1618
1719 If the sftp-server command is available it will be used to perform
1820 some tests, but it is not mandatory.
0 libnet-sftp-foreign-perl (1.38+dfsg-1) UNRELEASED; urgency=low
1
2 * New upstream release.
3
4 -- gregor herrmann <gregoa@debian.org> Wed, 18 Jun 2008 18:35:25 +0200
5
06 libnet-sftp-foreign-perl (1.36+dfsg-1) unstable; urgency=low
17
28 * New upstream release.
00 package Net::SFTP::Foreign::Common;
11
2 our $VERSION = '1.31';
2 our $VERSION = '1.37';
33
44 use strict;
55 use warnings;
77 use Scalar::Util qw(dualvar tainted);
88 use Fcntl qw(S_ISLNK S_ISDIR);
99
10 use Net::SFTP::Foreign::Helpers qw(_gen_wanted _ensure_list);
10 use Net::SFTP::Foreign::Helpers qw(_gen_wanted _ensure_list _debug);
1111 use Net::SFTP::Foreign::Constants qw(:status);
1212
1313 my %status_str = ( SSH2_FX_OK, "OK",
1919 SSH2_FX_NO_CONNECTION, "No connection",
2020 SSH2_FX_CONNECTION_LOST, "Connection lost",
2121 SSH2_FX_OP_UNSUPPORTED, "Operation unsupported" );
22
23 *debug = \$Net::SFTP::Foreign::debug;
24 our $debug;
2225
2326 sub _set_status {
2427 my $sftp = shift;
3336 unless (defined $str and length $str) {
3437 $str = $status_str{$code} || "Unknown status ($code)";
3538 }
39 $debug and $debug & 64 and _debug("_set_status code: $code, str: $str");
3640 return $sftp->{_status} = dualvar($code, $str);
3741 }
3842 else {
5559 else {
5660 $str = $code ? "Unknown error $code" : "OK";
5761 }
62 $debug and $debug & 64 and _debug("_set_err code: $code, str: $str");
5863 return $sftp->{_error} = dualvar $code, $str;
5964 }
6065 else {
8691 $! = Errno::EBADMSG();
8792 }
8893 elsif ($status == SSH2_FX_OP_UNSUPPORTED) {
89 $! = Errnor::ENOTSUP()
94 $! = Errno::ENOTSUP()
9095 }
9196 elsif ($status) {
92 $! = Errnor::EIO()
97 $! = Errno::EIO()
9398 }
9499 }
95100 }
1717 _ensure_list
1818 _glob_to_regex
1919 _tcroak
20 _catch_tainted_args);
20 _catch_tainted_args
21 _debug);
2122
2223 sub _do_nothing {}
24
25 sub _debug { print STDERR '# ', @_,"\n" }
2326
2427 {
2528 my $has_sk;
7881 my ($glob, $strict_leading_dot, $ignore_case) = @_;
7982
8083 my ($regex, $in_curlies, $escaping);
84 my $wildcards = 0;
8185
8286 my $first_byte = 1;
8387 while ($glob =~ /\G(.)/g) {
100104 $regex .= quotemeta $char;
101105 }
102106 else {
107 $wildcards++;
103108 if ($char eq '*') {
104109 $regex .= ".*";
105110 }
129134
130135 }
131136 else {
137 $wildcards--;
132138 $regex .= quotemeta $char;
133139 }
134140 }
139145
140146 croak "invalid glob pattern" if $in_curlies;
141147
142 $ignore_case ? qr/^$regex$/i : qr/^$regex$/;
148 my $re = $ignore_case ? qr/^$regex$/i : qr/^$regex$/;
149 wantarray ? ($re, ($wildcards > 0 ? 1 : undef)) : $re
143150 }
144151
145152 sub _tcroak {
00 package Net::SFTP::Foreign;
11
2 our $VERSION = '1.36';
2 our $VERSION = '1.38';
33
44 use strict;
55 use warnings;
1616 my $windows;
1717
1818 BEGIN {
19 $windows = $^O =~ /Win/;
19 $windows = $^O =~ /Win32/;
2020
2121 if ($^O =~ /solaris/i) {
2222 $dirty_cleanup = 1 unless defined $dirty_cleanup;
2323 }
2424 }
25
26 sub _debug { print STDERR '# ', @_,"\n" }
2725
2826 sub _hexdump {
2927 no warnings qw(uninitialized);
4846 our @ISA = qw(Net::SFTP::Foreign::Common);
4947
5048
51 use constant COPY_SIZE => 16384;
49 use constant DEFAULT_BLOCK_SIZE => 16384;
50 use constant DEFAULT_QUEUE_SIZE => ($windows ? 4 : 10);
5251
5352 sub _next_msg_id { shift->{_msg_id}++ }
5453
9897
9998 sub _do_io_unix {
10099 my ($sftp, $timeout) = @_;
100
101 $debug and $debug & 32 and _debug(sprintf "_do_io connected: %s", $sftp->{_connected} || 0);
101102
102103 return undef unless $sftp->{_connected};
103104
128129 my $rv1 = $rv;
129130 my $wv1 = length($$bout) ? $wv : '';
130131
132 $debug and $debug & 32 and _debug("_do_io select(-,-,-, $timeout)");
133
131134 my $n = select($rv1, $wv1, undef, $timeout);
132135 if ($n > 0) {
133136 if (vec($wv1, $fnoout, 1)) {
134137 my $written = syswrite($sftp->{ssh_out}, $$bout, 16384);
138 $debug and $debug & 32 and _debug (sprintf "_do_io write queue: %d, syswrite: %s, max: %d",
139 length $$bout,
140 (defined $written ? $written : 'undef'),
141 16384);
135142 unless ($written) {
136143 $sftp->_conn_lost;
137144 return undef;
140147 }
141148 if (vec($rv1, $fnoin, 1)) {
142149 my $read = sysread($sftp->{ssh_in}, $sftp->{_bin}, 16384, length($$bin));
150 $debug and $debug & 32 and _debug (sprintf "_do_io read sysread: %s, total read: %d",
151 (defined $read ? $read : 'undef'),
152 length $sftp->{_bin});
143153 unless ($read) {
144154 $sftp->_conn_lost;
145155 return undef;
147157 }
148158 }
149159 else {
160 $debug and $debug & 32 and _debug "_do_io select failed: $!";
150161 next if ($n < 0 and $! == Errno::EINTR());
151162 return undef;
152163 }
187198 sub _conn_lost {
188199 my ($sftp, $status, $err, @str) = @_;
189200
201 $debug and $debug & 32 and _debug("_conn_lost");
202
190203 $sftp->{_status} or
191204 $sftp->_set_status(defined $status ? $status : SSH2_FX_CONNECTION_LOST);
192205
229242 return $msg;
230243 }
231244
245 sub _ipc_open2_bug_workaround {
246 # in some cases, IPC::Open3::open2 returns from the child
247 my $pid = shift;
248 unless ($pid == $$) {
249 require POSIX;
250 POSIX::_exit(-1);
251 }
252 }
253
232254 sub new {
233255 ${^TAINT} and &_catch_tainted_args;
234256
238260
239261 my $sftp = { _msg_id => 0,
240262 _queue_size => ($windows ? 4 : 10),
241 _block_size => 16384,
242 _read_ahead => 16384 * 4,
243263 _bout => '',
244264 _bin => '',
245265 _connected => 1,
251271 $sftp->_set_error;
252272
253273 my $transport = delete $opts{transport};
274
275 $sftp->{_block_size} = delete $opts{block_size} || DEFAULT_BLOCK_SIZE;
276 $sftp->{_read_ahead} = $sftp->{_block_size} * 4;
277 $sftp->{_queue_size} = delete $opts{queue_size} || DEFAULT_QUEUE_SIZE;
254278 $sftp->{_timeout} = delete $opts{timeout};
255279 $sftp->{_autoflush} = delete $opts{autoflush};
256280
257 my ($pass, $passphrase);
281 my ($pass, $passphrase, $expect_log_user);
258282
259283 my @open2_cmd;
260284 unless (defined $transport) {
267291 else {
268292 $pass = delete $opts{password};
269293 }
294
295 $expect_log_user = delete $opts{expect_log_user} || 0;
270296
271297 my $open2_cmd = delete $opts{open2_cmd};
272298 if (defined $open2_cmd) {
277303 defined $host or croak "sftp target host not defined";
278304
279305 my $ssh_cmd = delete $opts{ssh_cmd};
280 @open2_cmd = defined $ssh_cmd ? $ssh_cmd : 'ssh';
306 $ssh_cmd = 'ssh' unless defined $ssh_cmd;
307 @open2_cmd = ($ssh_cmd);
308
309 my $ssh_cmd_interface = delete $opts{ssh_cmd_interface};
310 unless (defined $ssh_cmd_interface) {
311 $ssh_cmd_interface = ( $ssh_cmd =~ /\bplink(?:\.exe)?$/i
312 ? 'plink'
313 : 'ssh');
314 }
281315
282316 my $port = delete $opts{port};
283 push @open2_cmd, -p => $port if defined $port;
284
285317 my $user = delete $opts{user};
318
319 my $more = delete $opts{more};
320 carp "'more' argument looks like if it needs to be splited first"
321 if (defined $more and !ref($more) and $more =~ /^-\w\s+\S/);
322
323 if ($ssh_cmd_interface eq 'plink') {
324 $pass and !$passphrase
325 and croak "Password authentication via Expect is not supported for the plink client";
326 push @open2_cmd, -P => $port if defined $port;
327 }
328 elsif ($ssh_cmd_interface eq 'ssh') {
329 push @open2_cmd, -p => $port if defined $port;
330 }
331 else {
332 die "Unsupported ssh_cmd_interface '$ssh_cmd_interface'";
333 }
286334 push @open2_cmd, -l => $user if defined $user;
287
288 my $more = delete $opts{more};
289 if (defined $more) {
290 if (!ref($more) and $more =~ /^-\w\s+\S/) {
291 carp "'more' argument looks like it needs to be splited first"
292 }
293 push @open2_cmd, _ensure_list($more)
294 }
295
335 push @open2_cmd, _ensure_list($more) if defined $more;
296336 push @open2_cmd, $host, -s => 'sftp';
297337 }
298338 }
314354 _tcroak('Insecure $ENV{PATH}')
315355 }
316356
317 my $pid = $$;
357 my $this_pid = $$;
318358 local $@;
319359 local $SIG{__DIE__};
320360
323363 # user has requested to use a password or a passphrase for authentication
324364 # we use Expect to handle that
325365
366 eval { require IO::Pty };
367 $@ and croak "password authentication is not available, IO::Pty and Expect are not installed";
326368 eval { require Expect };
327369 $@ and croak "password authentication is not available, Expect is not installed";
328370
332374 my $name = $passphrase ? 'Passphrase' : 'Password';
333375 my $eto = $sftp->{_timeout} ? $sftp->{_timeout} * 4 : 120;
334376
335 my $conn = $sftp->{ssh_in} = $sftp->{ssh_out} = Expect->new;
336 $sftp->{_ssh_out_is_not_dupped} = 1;
337
338 $conn->raw_pty(1);
339 $conn->log_user(0);
340
341 my $ok = $conn->spawn(@open2_cmd);
342
343 if ($$ != $pid) {
344 require POSIX;
345 POSIX::_exit(-1);
377 my $pty = IO::Pty->new;
378 my $expect = Expect->init($pty);
379 $expect->raw_pty(1);
380 $expect->log_user($expect_log_user);
381
382 my $child = eval { open2($sftp->{ssh_in}, $sftp->{ssh_out}, '-') };
383 if (defined $child and !$child) {
384 $pty->make_slave_controlling_terminal;
385 exec @open2_cmd;
386 exit -1;
346387 }
347
348 unless ($ok) {
349 $sftp->_conn_failed("Spawning the SSH process failed", $conn->error);
388 _ipc_open2_bug_workaround $this_pid;
389
390 unless (defined $child) {
391 $sftp->_conn_failed("Bad ssh command", $!);
350392 return $sftp;
351393 }
352
353 $ok = $conn->expect($eto, ":");
354 unless ($ok) {
355 $sftp->_conn_failed("$name not requested as expected", $conn->error);
394 $sftp->{pid} = $child;
395 $sftp->{_expect} = $expect;
396
397 unless($expect->expect($eto, ":")) {
398 $sftp->_conn_failed("$name not requested as expected", $expect->error);
356399 return $sftp;
357400 }
358
359 $conn->send("$pass\n");
360 $ok = $conn->expect($eto, "\n");
361 unless ($ok) {
362 $sftp->_conn_failed("$name interchange did not complete", $conn->error);
401 $expect->send("$pass\n");
402
403 unless ($expect->expect($eto, "\n")) {
404 $sftp->_conn_failed("$name interchange did not complete", $expect->error);
363405 return $sftp;
364406 }
365407 }
366408 else {
367 warn "ssh cmd: @open2_cmd\n" if ($debug and $debug & 1);
409 _debug "ssh cmd: @open2_cmd\n" if ($debug and $debug & 1);
368410
369411 $sftp->{pid} = eval { open2($sftp->{ssh_in}, $sftp->{ssh_out}, @open2_cmd) };
370 if ($pid != $$) { # that's to workaround a bug in IPC::Open3:
371 require POSIX;
372 POSIX::_exit(-1);
373 }
412 _ipc_open2_bug_workaround $this_pid;
374413 unless (defined $sftp->{pid}) {
375414 $sftp->_conn_failed("Bad ssh command", $!);
376415 return $sftp;
605644
606645 my ($sftp, $path, $flags, $a) = @_;
607646 $path = $sftp->_rel2abs($path);
608 $flags ||= 0;
609 $a ||= Net::SFTP::Foreign::Attributes->new;
647 defined $flags or $flags = SSH2_FXF_READ;
648 defined $a or $a = Net::SFTP::Foreign::Attributes->new;
610649 my $id = $sftp->_queue_new_msg(SSH2_FXP_OPEN, str => $path,
611650 int32 => $flags, attr => $a);
612651
664703
665704 unless ($size) {
666705 return '' if defined $size;
667 $size = COPY_SIZE;
706 $size = $sftp->{_block_size};
668707 }
669708
670709 my $rfid = $sftp->_rfid($rfh);
806845 my $len = length $$bout;
807846
808847 $sftp->flush($rfh, 'out')
809 if ($len > COPY_SIZE or ($len and $sftp->{_autoflush} ));
848 if ($len > $sftp->{_block_size} or ($len and $sftp->{_autoflush} ));
810849
811850 return $datalen;
812851 }
838877 my $off = 0;
839878 my $written = $sftp->_write($rfh, $start,
840879 sub {
841 my $data = substr($$bout, $off, COPY_SIZE);
880 my $data = substr($$bout, $off, $sftp->{_block_size});
842881 $off += length $data;
843882 $data;
844883 } );
13291368 my $cb = delete $opts{callback};
13301369 my $umask = delete $opts{umask};
13311370 my $perm = delete $opts{perm};
1332 my $copy_perms = delete $opts{copy_perms};
1371 my $copy_perm = delete $opts{exists $opts{copy_perm} ? 'copy_perm' : 'copy_perms'};
13331372 my $copy_time = delete $opts{copy_time};
13341373 my $overwrite = delete $opts{overwrite};
13351374 my $block_size = delete $opts{block_size} || $sftp->{_block_size};
13431382 croak "'perm' and 'umask' options can not be used simultaneously"
13441383 if (defined $perm and defined $umask);
13451384
1346 croak "'perm' and 'copy_perms' options can not be used simultaneously"
1347 if (defined $perm and defined $copy_perms);
1385 croak "'perm' and 'copy_perm' options can not be used simultaneously"
1386 if (defined $perm and defined $copy_perm);
13481387
13491388 my $numask;
13501389
13571396 }
13581397
13591398 $overwrite = 1 unless defined $overwrite;
1360 $copy_perms = 1 unless (defined $perm or defined $copy_perms);
1399 $copy_perm = 1 unless (defined $perm or defined $copy_perm);
13611400 $copy_time = 1 unless defined $copy_time;
13621401
1363 my $a = $sftp->stat($remote)
1364 or return undef;
1365 my $size = $a->size;
1402 my $size;
1403 my $a = $sftp->stat($remote);
1404 if (defined $a) {
1405 $size = $a->size
1406 }
1407 else {
1408 if ($copy_time or $copy_perm ) {
1409 return undef;
1410 }
1411 $sftp->_set_status;
1412 $sftp->_set_error;
1413 $size = -1;
1414 }
13661415
13671416 my $rfh = $sftp->open($remote, SSH2_FXF_READ);
13681417 defined $rfh or return undef;
13801429 return undef
13811430 }
13821431
1383 if ($copy_perms) {
1432 if ($copy_perm) {
13841433 my $aperm = $a->perm;
13851434 $perm = 0666 unless defined $perm;
13861435 $a->perm =~ /^(\d+)$/ or die "perm is not numeric";
14291478
14301479 while (1) {
14311480 # request a new block if queue is not full
1432 while (!@msgid or ($size > $askoff and @msgid < $queue_size and $n != 1)) {
1481 while (!@msgid or (($size == -1 or $size > $askoff) and @msgid < $queue_size and $n != 1)) {
14331482
14341483 my $id = $sftp->_queue_new_msg(SSH2_FXP_READ, str=> $rfid,
14351484 int64 => $askoff, int32 => $block_size);
14521501 unless ($msg) {
14531502 if ($sftp->{_status} == SSH2_FX_EOF) {
14541503 $sftp->_set_error();
1455 next if $roff != $loff;
1504 $roff != $loff and next;
14561505 }
14571506 last;
14581507 }
14721521 }
14731522
14741523 if (defined $cb) {
1475 $size = $loff if $loff > $size;
1524 # $size = $loff if ($loff > $size and $size != -1);
14761525 $cb->($sftp, $data, $roff, $size);
14771526
14781527 last if $sftp->error;
15491598
15501599 my $umask = delete $opts{umask};
15511600 my $perm = delete $opts{perm};
1552 my $copy_perms = delete $opts{copy_perms};
1601 my $copy_perm = delete $opts{copy_perm} || delete $opts{copy_perms};
15531602 my $copy_time = delete $opts{copy_time};
15541603 my $overwrite = delete $opts{overwrite};
1555 my $block_size = delete $opts{block_size} || COPY_SIZE;
1556 my $queue_size = delete $opts{queue_size} || 10;
1604 my $block_size = delete $opts{block_size} || $sftp->{_block_size};
1605 my $queue_size = delete $opts{queue_size} || $sftp->{_queue_size};
15571606
15581607 %opts and croak "invalid option(s) '".CORE::join("', '", keys %opts)."'";
15591608
15601609 croak "'perm' and 'umask' options can not be used simultaneously"
15611610 if (defined $perm and defined $umask);
15621611
1563 croak "'perm' and 'copy_perms' options can not be used simultaneously"
1564 if (defined $perm and defined $copy_perms);
1612 croak "'perm' and 'copy_perm' options can not be used simultaneously"
1613 if (defined $perm and defined $copy_perm);
15651614
15661615 my $numask;
15671616
15731622 $numask = 0777 & ~$umask;
15741623 }
15751624 $overwrite = 1 unless defined $overwrite;
1576 $copy_perms = 1 unless (defined $perm or defined $copy_perms);
1625 $copy_perm = 1 unless (defined $perm or defined $copy_perm);
15771626 $copy_time = 1 unless defined $copy_time;
15781627
15791628 my $fh;
15931642 return undef;
15941643 }
15951644
1596 $perm = $lmode & $numask if defined $copy_perms;
1645 $perm = $lmode & $numask if $copy_perm;
15971646
15981647 my $attrs = Net::SFTP::Foreign::Attributes->new;
1599 $attrs->set_perm($perm);
1648 $attrs->set_perm($perm) if defined $perm;
16001649
16011650 my $rfh = $sftp->open($remote,
16021651 SSH2_FXF_WRITE | SSH2_FXF_CREAT |
16051654 or return undef;
16061655
16071656 # open does not set the attributes for existant files so we do it again:
1608 $sftp->fsetstat($rfh, $attrs)
1609 or return undef;
1657 if (defined $perm) {
1658 $sftp->fsetstat($rfh, $attrs)
1659 or return undef;
1660 }
16101661
16111662 my $rfid = $sftp->_rfid($rfh);
16121663 defined $rfid or return undef;
18411892 my @parents = @res;
18421893 @res = ();
18431894 my $part = shift @parts;
1844 my $re = _glob_to_regex($part, $strict_leading_dot, $ignore_case);
1895 my ($re, $has_wildcards) = _glob_to_regex($part, $strict_leading_dot, $ignore_case);
18451896
18461897 for my $parent (@parents) {
18471898 my $pfn = $parent->{filename};
1848 $sftp->ls( $pfn,
1849 ordered => $ordered,
1850 _wanted => sub {
1851 my $e = $_[1];
1852 if ($e->{filename} =~ $re) {
1853 my $fn = $e->{filename} = $sftp->join($pfn, $e->{filename});
1854 if ( (@parts or $follow_links)
1855 and S_ISLNK($e->{a}->perm) ) {
1856 if (my $a = $sftp->stat($fn)) {
1857 $e->{a} = $a;
1858 }
1859 else {
1860 $sftp->_call_on_error($on_error, $e);
1861 return undef;
1862 }
1863 }
1864 if (@parts) {
1865 push @res, $e if S_ISDIR($e->{a}->perm)
1866 }
1867 elsif (!$wanted or $wanted->($sftp, $e)) {
1868 if ($wantarray) {
1869 if ($realpath) {
1870 $e->{realpath} = $sftp->realpath($e->{filename});
1871 unless (defined $e->{realpath}) {
1872 $sftp->_call_on_error($on_error, $e);
1873 return undef;
1899 if ($has_wildcards) {
1900 $sftp->ls( $pfn,
1901 ordered => $ordered,
1902 _wanted => sub {
1903 my $e = $_[1];
1904 if ($e->{filename} =~ $re) {
1905 my $fn = $e->{filename} = $sftp->join($pfn, $e->{filename});
1906 if ( (@parts or $follow_links)
1907 and S_ISLNK($e->{a}->perm) ) {
1908 if (my $a = $sftp->stat($fn)) {
1909 $e->{a} = $a;
1910 }
1911 else {
1912 $sftp->_call_on_error($on_error, $e);
1913 return undef;
1914 }
1915 }
1916 if (@parts) {
1917 push @res, $e if S_ISDIR($e->{a}->perm)
1918 }
1919 elsif (!$wanted or $wanted->($sftp, $e)) {
1920 if ($wantarray) {
1921 if ($realpath) {
1922 my $rp = $e->{realpath} = $sftp->realpath($e->{filename});
1923 unless (defined $rp) {
1924 $sftp->_call_on_error($on_error, $e);
1925 return undef;
1926 }
18741927 }
1928 push @res, ($names_only
1929 ? ($realpath ? $e->{realpath} : $e->{filename} )
1930 : $e);
18751931 }
1876 push @res, ($names_only
1877 ? ($realpath ? $e->{realpath} : $e->{filename} )
1878 : $e);
1932 $res++;
18791933 }
1880 $res++;
1881 }
1882 }
1883 return undef
1884 } )
1885 or $sftp->_call_on_error($on_error, $parent);
1886 }
1934 }
1935 return undef
1936 } )
1937 or $sftp->_call_on_error($on_error, $parent);
1938 }
1939 else {
1940 my $fn = $sftp->join($pfn, $part);
1941 my $method = ((@parts or $follow_links) ? 'stat' : 'lstat');
1942 if (my $a = $sftp->$method($fn)) {
1943 my $e = { filename => $fn, a => $a };
1944 if (@parts) {
1945 push @res, $e if S_ISDIR($a->{perm})
1946 }
1947 elsif (!$wanted or $wanted->($sftp, $e)) {
1948 if ($wantarray) {
1949 if ($realpath) {
1950 my $rp = $fn = $e->{realpath} = $sftp->realpath($fn);
1951 unless (defined $rp) {
1952 $sftp->_call_on_error($on_error, $e);
1953 next;
1954 }
1955 }
1956 push @res, ($names_only ? $fn : $e)
1957 }
1958 $res++;
1959 }
1960 }
1961 }
1962 }
18871963 }
18881964 return wantarray ? @res : $res;
18891965 }
19492025
19502026 # my $cb = delete $opts{callback};
19512027 my $umask = delete $opts{umask};
1952 my $copy_perms = delete $opts{copy_perms};
2028 my $copy_perm = delete $opts{copy_perm} || delete $opts{copy_perms};
19532029 my $copy_time = delete $opts{copy_time};
19542030 my $block_size = delete $opts{block_size};
19552031 my $queue_size = delete $opts{queue_size};
19712047
19722048 $umask = umask $umask if (defined $umask);
19732049
1974 $copy_perms = 1 unless defined $copy_perms;
2050 $copy_perm = 1 unless defined $copy_perm;
19752051 $copy_time = 1 unless defined $copy_time;
19762052
19772053 require File::Spec;
19932069 return 1;
19942070 }
19952071 else {
1996 if (CORE::mkdir $lpath, ($copy_perms ? $e->{a}->perm & 0777 : 0777)) {
2072 if (CORE::mkdir $lpath, ($copy_perm ? $e->{a}->perm & 0777 : 0777)) {
19972073 $count++;
19982074 return 1;
19992075 }
20452121 overwrite => $overwrite,
20462122 queue_size => $queue_size,
20472123 block_size => $block_size,
2048 copy_perms => $copy_perms,
2124 copy_perm => $copy_perm,
20492125 copy_time => $copy_time)) {
20502126 $count++;
20512127 return undef;
20822158
20832159 # my $cb = delete $opts{callback};
20842160 my $umask = delete $opts{umask};
2085 my $copy_perms = delete $opts{copy_perms};
2161 my $copy_perm = delete $opts{copy_perm} || delete $opts{copy_perms};
20862162 my $copy_time = delete $opts{copy_time};
20872163 my $block_size = delete $opts{block_size};
20882164 my $queue_size = delete $opts{queue_size};
21052181 my $qlocal = quotemeta $local;
21062182 my $relocal = qr/^$qlocal(.*)$/i;
21072183
2108 $copy_perms = 1 unless defined $copy_perms;
2184 $copy_perm = 1 unless defined $copy_perm;
21092185 $copy_time = 1 unless defined $copy_time;
21102186
21112187 $umask = umask unless defined $umask;
21372213 }
21382214 else {
21392215 my $a = Net::SFTP::Foreign::Attributes->new;
2140 $a->set_perm(($copy_perms ? $e->{a}->perm & 0777 : 0777) & $mask);
2216 $a->set_perm(($copy_perm ? $e->{a}->perm & 0777 : 0777) & $mask);
21412217 if ($sftp->mkdir($rpath, $a)) {
21422218 $count++;
21432219 return 1;
21852261 overwrite => $overwrite,
21862262 queue_size => $queue_size,
21872263 block_size => $block_size,
2188 perm => ($copy_perms ? $e->{a}->perm : 0777) & $mask,
2264 perm => ($copy_perm ? $e->{a}->perm : 0777) & $mask,
21892265 copy_time => $copy_time)) {
21902266 $count++;
21912267 return undef;
24912567
24922568 =head1 NAME
24932569
2494 Net::SFTP::Foreign - Secure File Transfer Protocol client
2570 Net::SFTP::Foreign - SSH File Transfer Protocol client
24952571
24962572 =head1 SYNOPSIS
24972573
25022578
25032579 =head1 DESCRIPTION
25042580
2505 SFTP stands for Secure File Transfer Protocol and is a method of
2581 SFTP stands for SSH File Transfer Protocol and is a method of
25062582 transferring files between machines over a secure, encrypted
25072583 connection (as opposed to regular FTP, which functions over an
25082584 insecure connection). The security in SFTP comes through its
25092585 integration with SSH, which provides an encrypted transport layer over
25102586 which the SFTP commands are executed.
25112587
2512 Net::SFTP::Foreign is a Perl client for the SFTP. It provides a subset
2513 of the commands listed in the SSH File Transfer Protocol IETF draft,
2514 which can be found at
2588 Net::SFTP::Foreign is a Perl client for the SFTP version 3. It
2589 provides a subset of the commands listed in the SSH File Transfer
2590 Protocol IETF draft, which can be found at
25152591 L<http://www.openssh.org/txt/draft-ietf-secsh-filexfer-02.txt> (also
2516 included on this package distribution, on the C<rfc> directory).
2592 included on this package distribution, on the C<rfc> directory) plus
2593 some additional handy high level methods.
25172594
25182595 Net::SFTP::Foreign uses any compatible C<ssh> command installed on
2519 your system (for instance, OpenSSH C<ssh>) to establish the secure
2596 the system (for instance, OpenSSH C<ssh>) to establish the secure
25202597 connection to the remote server.
25212598
25222599 Formerly, Net::SFTP::Foreign was a hacked version of Net::SFTP, but
25652642 success. C<$sftp-E<gt>error> can be used to explicitly check for
25662643 errors after every method call.
25672644
2645 Don't forget to read also the FAQ and BUGS sections at the end of this
2646 document!
2647
25682648 =over 4
25692649
25702650 =item Net::SFTP::Foreign->new($host, %args)
25732653
25742654 Opens a new SFTP connection with a remote host C<$host>, and returns a
25752655 Net::SFTP::Foreign object representing that open connection.
2656
2657 An explicit check for errors should be included always after the
2658 constructor call:
2659
2660 my $sftp = Net::SFTP::Foreign->new(...);
2661 $sftp->error and die "SSH connection failed: " . $sftp->error;
25762662
25772663 C<%args> can contain:
25782664
26012687
26022688 my $sftp = Net::SFTP::Foreign->new($host, more => '-v');
26032689
2690 Note that this option expects a single command argument or a reference
2691 to an array of arguments. For instance:
2692
2693 more => '-v' # RIGHT
2694 more => ['-v'] # RIGHT
2695 more => "-i $key" # WRONG!!!
2696 more => [-i => $key] # RIGHT
26042697
26052698 =item ssh_cmd =E<gt> $sshcmd
26062699
26072700 name of the external SSH client. By default C<ssh> is used.
2701
2702 For instance:
2703
2704 my $sftp = Net::SFTP::Foreign->new($host, ssh_cmd => 'plink');
2705
2706 =item ssh_cmd_interface =E<gt> 'plink' or 'ssh'
2707
2708 declares the command line interface that the SSH client used to
2709 connect to the remote host understands. Currently C<plink> and C<ssh>
2710 are supported.
2711
2712 This option would be rarely required as the module infers the
2713 interface from the SSH command name.
26082714
26092715 =item open2_cmd =E<gt> [@cmd]
26102716
26352741
26362742 =item transport =E<gt> [$in_fh, $out_fh, $pid]
26372743
2638 This option allows to use an already open pipe or socket as the
2639 transport for the SFTP protocol.
2744 allows to use an already open pipe or socket as the transport for the
2745 SFTP protocol.
26402746
26412747 It can be (ab)used to make this module work with password
26422748 authentication or with keys requiring a passphrase.
26462752 C<$pid> argument can be used to instruct this module to kill that
26472753 process if it doesn't exit by itself.
26482754
2649 =item password => $password
2650
2651 =item passphrase => $passphrase
2652
2653 Use L<Expect> to handle password authentication or keys requiring a
2755 =item password =E<gt> $password
2756
2757 =item passphrase =E<gt> $passphrase
2758
2759 uses L<Expect> to handle password authentication or keys requiring a
26542760 passphrase. This is an experimental feature!
26552761
2762 =item expect_log_user =E<gt> $bool
2763
2764 activates password/passphrase authentication interaction loging (see
2765 C<Expect::log_user> method documentation).
2766
2767 =item block_size =E<gt> $default_block_size
2768
2769 =item queue_size =E<gt> $default_queue_size
2770
2771 default C<block_size> and C<queue_size> used for read and write
2772 operations (see the C<put> or C<get> documentation).
2773
26562774 =back
2657
2658 An explicit check for errors should be included always after the
2659 constructor call:
2660
2661 my $sftp = Net::SFTP::Foreign->new(...);
2662 $sftp->error and die "SSH connection failed: " . $sftp->error;
26632775
26642776 =item $sftp-E<gt>error
26652777
27072819 determines if access and modification time attributes have to be
27082820 copied from remote file. Default is to copy them.
27092821
2710 =item copy_perms =E<gt> $bool
2822 =item copy_perm =E<gt> $bool
27112823
27122824 determines if permision attributes have to be copied from remote
27132825 file. Default is to copy them after applying the local process umask.
27262838
27272839 size of the blocks the file is being splittered on for
27282840 transfer. Incrementing this value can improve performance but some
2729 servers limit its size.
2841 servers limit the maximum size.
2842
2843 =item queue_size =E<gt> $size
2844
2845 read and write requests are pipelined in order to maximize transfer
2846 throughput. This option allows to set the maximum number of requests
2847 that can be concurrently waiting for a server response.
27302848
27312849 =item callback =E<gt> $callback
27322850
27452863 my($sftp, $data, $offset, $size) = @_;
27462864 print "Read $offset / $size bytes\r";
27472865 }
2748
2749 =back
27502866
27512867 The C<abort> method can be called from inside the callback to abort
27522868 the transfer:
27592875 }
27602876
27612877
2878 =back
2879
27622880 =item $sftp-E<gt>get_content($remote)
27632881
27642882 Returns the content of the remote file.
27772895 determines if access and modification time attributes have to be
27782896 copied from remote file. Default is to copy them.
27792897
2780 =item copy_perms =E<gt> $bool
2898 =item copy_perm =E<gt> $bool
27812899
27822900 determines if permision attributes have to be copied from remote
27832901 file. Default is to copy them after applying the local process umask.
27982916 transfer. Incrementing this value can improve performance but some
27992917 servers limit its size and if this limit is overpassed the command
28002918 will fail.
2919
2920 =item queue_size =E<gt> $size
2921
2922 read and write requests are pipelined in order to maximize transfer
2923 throughput. This option allows to set the maximum number of requests
2924 that can be concurrently waiting for a server response.
28012925
28022926 =item callback =E<gt> $callback
28032927
31003224 use umask C<$umask> to set permissions on the files and directories
31013225 created.
31023226
3103 =item copy_perms =E<gt> $bool;
3227 =item copy_perm =E<gt> $bool;
31043228
31053229 if set to a true value, file and directory permissions are copied to
31063230 the remote server (after applying the umask). On by default.
31643288 use umask C<$umask> to set permissions on the files and directories
31653289 created.
31663290
3167 =item copy_perms =E<gt> $bool;
3291 =item copy_perm =E<gt> $bool;
31683292
31693293 if set to a true value, file and directory permissions are copied
31703294 to the remote server (after applying the umask). On by default.
35593683 my $sftp = Net::SFTP::Foreign->new($host,
35603684 more => [qw(-i /home/foo/.ssh/id_dsa)]);
35613685
3686 =item Plink and password authentication
3687
3688 B<Q>: Why password authentication is not supported for the plink SSH
3689 client?
3690
3691 B<A>: A bug in plink breaks it.
3692
3693 As a work around, you can use plink C<-pw> argument to pass the
3694 password on the command line, but it is B<highly insecure>, anyone
3695 with a shell account on the machine would be able to get the password.
3696 Use at your own risk!:
3697
3698 # HIGHLY INSECURE!!!
3699 my $sftp = Net::SFTP::Foreign->new('foo@bar',
3700 ssh_cmd => 'plink',
3701 more => [-pw => $password]);
3702 $sftp->error and die $sftp->error;
3703
3704 =item Plink
3705
3706 B<Q>: What is C<plink>?
3707
3708 B<A>: Plink is a command line tool distributed with the
3709 L<PuTTY|http://the.earth.li/~sgtatham/putty/> SSH client. Very popular
3710 between MS Windows users, it is also available for Linux and other
3711 Unixes now.
3712
35623713 =back
35633714
3715
3716
35643717 =head1 BUGS
35653718
3566 Doesn't work on VMS. The problem is related to L<IPC::Open2> not
3567 working on VMS. Patches are welcome!
3719 These are the currently known bugs:
3720
3721 =over 4
3722
3723 =item - Doesn't work on VMS:
3724
3725 The problem is related to L<IPC::Open2> not working on VMS. Patches
3726 are welcome!
3727
3728 =item - Dirty cleanup:
35683729
35693730 On some operative systems, closing the pipes used to comunicate with
3570 the slave ssh process does not terminate it and a work around has to
3731 the slave SSH process does not terminate it and a work around has to
35713732 be applied. If you find that your scripts hung when the $sftp object
35723733 gets out of scope, try setting C<$Net::SFTP::Foreign::dirty_cleanup>
35733734 to a true value and also send me a report including the value of
35743735 C<$^O> on your machine and the OpenSSH version.
35753736
35763737 From version 0.90_18 upwards, a dirty cleanup is performed anyway when
3577 the ssh process does not terminate by itself in 8 seconds or less.
3578
3579 Support for Windows OSs is still experimental!
3738 the SSH process does not terminate by itself in 8 seconds or less.
3739
3740 =back
3741
3742 Support for MS Windows OSs is still experimental!
35803743
35813744 Support for taint mode is experimental!
35823745
35833746 Support for setcwd/cwd is experimental!
35843747
3585 Support for password/passphrase handling via Expect is also experimental!
3748 Support for password/passphrase handling via Expect is also
3749 experimental. On Windows it only works under the cygwin version of
3750 Perl.
3751
3752
35863753
35873754 To report bugs, please, send me and email or use
35883755 L<http://rt.cpan.org>.
3838 @ssh = qw( /usr/bin/ssh
3939 /usr/local/bin/ssh
4040 /usr/local/openssh/bin/ssh
41 /opt/openssh/bin/ssh );
41 /opt/openssh/bin/ssh
42 /opt/ssh/bin/ssh );
4243 }
4344
4445 if (eval {require File::Which; 1}) {