r39440 - in /branches/upstream/libnet-sftp-foreign-perl/current: ./ lib/Net/SFTP/ lib/Net/SFTP/Foreign/ samples/ t/
ryan52-guest at users.alioth.debian.org
ryan52-guest at users.alioth.debian.org
Tue Jul 7 03:59:17 UTC 2009
Author: ryan52-guest
Date: Tue Jul 7 03:59:11 2009
New Revision: 39440
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=39440
Log:
[svn-upgrade] Integrating new upstream version, libnet-sftp-foreign-perl (1.53+dfsg)
Added:
branches/upstream/libnet-sftp-foreign-perl/current/debug.txt
branches/upstream/libnet-sftp-foreign-perl/current/samples/sftp_tail.pl
branches/upstream/libnet-sftp-foreign-perl/current/t/4_perl5_11.t
Modified:
branches/upstream/libnet-sftp-foreign-perl/current/Changes
branches/upstream/libnet-sftp-foreign-perl/current/MANIFEST
branches/upstream/libnet-sftp-foreign-perl/current/META.yml
branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign.pm
branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Attributes.pm
branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Buffer.pm
branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Common.pm
branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Constants.pm
branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Helpers.pm
branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Local.pm
branches/upstream/libnet-sftp-foreign-perl/current/samples/passwd_conn.pl
Modified: branches/upstream/libnet-sftp-foreign-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/Changes?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/Changes (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/Changes Tue Jul 7 03:59:11 2009
@@ -1,4 +1,41 @@
Revision history for Net::SFTP::Foreign
+
+1.53 Jul 6, 2009
+ - re-released as stable
+
+1.52_12 Jul 2, 2009
+ - also if using password authentication, detect when the
+ remote host key doesn't match the key stored in know_hosts
+ and abort the connection (bug report by Ryan Niebur).
+ - if using password authentication, detect when the target
+ host key has not been accepted yet (bug report by Ryan
+ Niebur)
+ - work around for IPC::Open3 feature missing in old versions
+ of that module that caused password authentication to fail
+ under 5.6.x perls (bug report by Vetrivel).
+ - find method would not follow links passed as arguments to
+ the method or others found when ordered mode was selected
+ (bug report by Paul Kolano)
+ - detect bad passwords and other password authentication
+ improvements
+ - sample scripts added
+ - atomic_rename was returning the wrong error code/string
+ - Perl 5.11 changes the EOF call interface for tied file
+ handles
+ - attributes flags slot was incorrectly set on new_from_buffer
+ - get/put_int64 optimization
+ - add calling function name to debug output
+ - add debug hexdumps for sysreads and syswrites
+ - optimize some common ls usages to reduce CPU utilization
+ - implement pipelining for ls command
+ - ls bug, wanted was being called with the wrong arguments
+ - add timestamps to debugging output
+ - ensure that attribute arguments are of class
+ Net::SFTP::Foreign::Attributes (feature request by Todd
+ Rinaldo)
+ - put_attributes was broken
+ - move _hexdump to Helpers package
+ - debug subsystem cleanup
1.51 Apr 7, 2009
- "get" corrupted the fetched files if $\ was non empty (bug
Modified: branches/upstream/libnet-sftp-foreign-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/MANIFEST?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/MANIFEST (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/MANIFEST Tue Jul 7 03:59:11 2009
@@ -1,7 +1,5 @@
Changes
-samples/psftp
-samples/passwd_conn.pl
-samples/capture_stderr.pl
+debug.txt
lib/Net/SFTP/Foreign.pm
lib/Net/SFTP/Foreign/Attributes.pm
lib/Net/SFTP/Foreign/Attributes/Compat.pm
@@ -16,11 +14,16 @@
MANIFEST
META.yml Module meta-data (added by MakeMaker)
README
-TODO
+samples/capture_stderr.pl
+samples/passwd_conn.pl
+samples/psftp
+samples/sftp_tail.pl
t/1_run.t
t/2_pods.t
t/3_convert.t
+t/4_perl5_11.t
+t/common.pm
t/data.txd
t/data.txu
-t/common.pm
t/Net-SFTP-Foreign-Compat.t
+TODO
Modified: branches/upstream/libnet-sftp-foreign-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/META.yml?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/META.yml (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/META.yml Tue Jul 7 03:59:11 2009
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Net-SFTP-Foreign
-version: 1.51
+version: 1.53
abstract: Secure File Transfer Protocol client
license: ~
author:
Added: branches/upstream/libnet-sftp-foreign-perl/current/debug.txt
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/debug.txt?rev=39440&op=file
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/debug.txt (added)
+++ branches/upstream/libnet-sftp-foreign-perl/current/debug.txt Tue Jul 7 03:59:11 2009
@@ -1,0 +1,13 @@
+ 1 - message queueing/dequeuing
+ 2 - remote file/dir open/close
+ 4 - DESTROY calls
+ 8 - hexdumps of incomming packets
+ 16 - hexdumps of outgoing packets
+ 32 - _do_io, _conn_lost
+ 64 - _set_error, _set_status
+ 128 - on the fly transformations
+ 256 - add timestamp and process id
+ 512 -
+1024 - hexdump of sysreads
+2048 - hexdump of syswrites
+
Modified: branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign.pm?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign.pm (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign.pm Tue Jul 7 03:59:11 2009
@@ -1,6 +1,6 @@
package Net::SFTP::Foreign;
-our $VERSION = '1.51';
+our $VERSION = '1.53';
use strict;
use warnings;
@@ -26,41 +26,30 @@
}
}
+# we make $Net::SFTP::Foreign::Helpers::debug an alias for
+# $Net::SFTP::Foreign::debug so that the user can set it without
+# knowing anything about the Helpers package!
our $debug;
-our $dirty_cleanup;
-my $windows;
-
-BEGIN {
- $windows = $^O =~ /Win32/;
-
- if ($^O =~ /solaris/i) {
- $dirty_cleanup = 1 unless defined $dirty_cleanup;
- }
-}
-
-sub _hexdump {
- no warnings qw(uninitialized);
- my $data = shift;
- while ($data =~ /(.{1,32})/smg) {
- my $line=$1;
- my @c= (( map { sprintf "%02x",$_ } unpack('C*', $line)),
- ((" ") x 32))[0..31];
- $line=~s/(.)/ my $c=$1; unpack("c",$c)>=32 ? $c : '.' /egms;
- local $\;
- print STDERR join(" ", @c, '|', $line), "\n";
- }
-}
-
+BEGIN { *Net::SFTP::Foreign::Helpers::debug = \$debug };
+use Net::SFTP::Foreign::Helpers;
use Net::SFTP::Foreign::Constants qw( :fxp :flags :att
:status :error
SSH2_FILEXFER_VERSION );
use Net::SFTP::Foreign::Attributes;
use Net::SFTP::Foreign::Buffer;
-use Net::SFTP::Foreign::Helpers;
-
use Net::SFTP::Foreign::Common;
our @ISA = qw(Net::SFTP::Foreign::Common);
+our $dirty_cleanup;
+my $windows;
+
+BEGIN {
+ $windows = $^O =~ /Win32/;
+
+ if ($^O =~ /solaris/i) {
+ $dirty_cleanup = 1 unless defined $dirty_cleanup;
+ }
+}
use constant DEFAULT_BLOCK_SIZE => 32768;
use constant DEFAULT_QUEUE_SIZE => ($windows ? 4 : 32);
@@ -89,7 +78,7 @@
_debug(sprintf("queueing msg len: %i, code:%i, id:%i ... [$sftp->{_queued}]",
$len, unpack(CN => $bytes)));
- ($debug & 16) and _hexdump(pack('N', length($bytes)) . $bytes);
+ $debug & 16 and _hexdump(pack('N', length($bytes)) . $bytes);
}
$sftp->{_bout} .= pack('N', length($bytes));
@@ -129,17 +118,21 @@
local $SIG{PIPE} = 'IGNORE';
+ my $len;
while (1) {
my $lbin = length $$bin;
- if ($lbin >= 4) {
- my $len = 4 + unpack N => $$bin;
+ if (defined $len) {
return 1 if $lbin >= $len;
+ }
+ elsif ($lbin >= 4) {
+ $len = 4 + unpack N => $$bin;
if ($len > 256 * 1024) {
$sftp->_set_status(SSH2_FX_BAD_MESSAGE);
$sftp->_set_error(SFTP_ERR_REMOTE_BAD_MESSAGE,
"bad remote message received");
return undef;
}
+ return 1 if $lbin >= $len;
}
my $rv1 = $rv;
@@ -150,11 +143,14 @@
my $n = select($rv1, $wv1, undef, $timeout);
if ($n > 0) {
if (vec($wv1, $fnoout, 1)) {
- my $written = syswrite($sftp->{ssh_out}, $$bout, 20480);
- $debug and $debug & 32 and _debug (sprintf "_do_io write queue: %d, syswrite: %s, max: %d",
- length $$bout,
- (defined $written ? $written : 'undef'),
- 20480);
+ my $written = syswrite($sftp->{ssh_out}, $$bout, 64 * 1024);
+ if ($debug and $debug & 32) {
+ _debug (sprintf "_do_io write queue: %d, syswrite: %s, max: %d",
+ length $$bout,
+ (defined $written ? $written : 'undef'),
+ 64 * 1024);
+ $debug & 2048 and $written and _hexdump(substr($$bout, 0, $written));
+ }
unless ($written) {
$sftp->_conn_lost;
return undef;
@@ -162,10 +158,13 @@
substr($$bout, 0, $written, '');
}
if (vec($rv1, $fnoin, 1)) {
- my $read = sysread($sftp->{ssh_in}, $$bin, 20480, length($$bin));
- $debug and $debug & 32 and _debug (sprintf "_do_io read sysread: %s, total read: %d",
- (defined $read ? $read : 'undef'),
- length $sftp->{_bin});
+ my $read = sysread($sftp->{ssh_in}, $$bin, 64 * 1024, length($$bin));
+ if ($debug and $debug & 32) {
+ _debug (sprintf "_do_io read sysread: %s, total read: %d",
+ (defined $read ? $read : 'undef'),
+ length $$bin);
+ $debug & 1024 and $read and _hexdump(substr($$bin, -$read));
+ }
unless ($read) {
$sftp->_conn_lost;
return undef;
@@ -249,10 +248,11 @@
if ($debug and $debug & 1) {
$sftp->{_queued}--;
my ($code, $id, $status) = unpack( CNN => $$msg);
+ $id = '-' if $code == SSH2_FXP_VERSION;
$status = '-' unless $code == SSH2_FXP_STATUS;
- _debug(sprintf("got it!, len:%i, code:%i, id:%i, status: %s",
+ _debug(sprintf("got it!, len:%i, code:%i, id:%s, status: %s",
$len, $code, $id, $status));
- ($debug & 8) and _hexdump($$msg);
+ $debug & 8 and _hexdump($$msg);
}
return $msg;
@@ -337,6 +337,7 @@
}
else {
$pass = delete $opts{password};
+ defined $pass and $sftp->{_password_authentication} = 1;
}
$expect_log_user = delete $opts{expect_log_user} || 0;
@@ -375,6 +376,8 @@
}
elsif ($ssh_cmd_interface eq 'ssh') {
push @open2_cmd, -p => $port if defined $port;
+ push @open2_cmd, -o => 'NumberOfPasswordPrompts=1'
+ if $pass and !$passphrase;
}
else {
die "Unsupported ssh_cmd_interface '$ssh_cmd_interface'";
@@ -419,22 +422,36 @@
my $name = $passphrase ? 'Passphrase' : 'Password';
my $eto = $sftp->{_timeout} ? $sftp->{_timeout} * 4 : 120;
- my $pty = IO::Pty->new;
- my $expect = Expect->init($pty);
- $expect->raw_pty(1);
- $expect->log_user($expect_log_user);
-
- my $child = do {
- local ($@, $SIG{__DIE__}, $SIG{__WARN__});
- eval { open2($sftp->{ssh_in}, $sftp->{ssh_out}, '-') }
- };
- if (defined $child and !$child) {
- $pty->make_slave_controlling_terminal;
- do { exec @open2_cmd }; # work around suppress warning under mod_perl
- exit -1;
- }
- _ipc_open2_bug_workaround $this_pid;
-
+ my $child;
+ my $expect;
+ if (eval $IPC::Open3::VERSION >= 1.0105) {
+ # open2(..., '-') only works from this IPC::Open3 version upwards;
+ my $pty = IO::Pty->new;
+ $expect = Expect->init($pty);
+ $expect->raw_pty(1);
+ $expect->log_user($expect_log_user);
+
+ $child = do {
+ local ($@, $SIG{__DIE__}, $SIG{__WARN__});
+ eval { open2($sftp->{ssh_in}, $sftp->{ssh_out}, '-') }
+ };
+ if (defined $child and !$child) {
+ $pty->make_slave_controlling_terminal;
+ do { exec @open2_cmd }; # work around suppress warning under mod_perl
+ exit -1;
+ }
+ _ipc_open2_bug_workaround $this_pid;
+ $pty->close_slave();
+ }
+ else {
+ $expect = Expect->new;
+ $expect->raw_pty(1);
+ $expect->log_user($expect_log_user);
+ $expect->spawn(@open2_cmd);
+ $sftp->{ssh_in} = $sftp->{ssh_out} = $expect;
+ $sftp->{_ssh_out_is_not_dupped} = 1;
+ $child = $expect->pid;
+ }
unless (defined $child) {
$sftp->_conn_failed("Bad ssh command", $!);
return $sftp;
@@ -442,11 +459,18 @@
$sftp->{pid} = $child;
$sftp->{_expect} = $expect;
- unless($expect->expect($eto, ":")) {
+ unless($expect->expect($eto, ':', '?')) {
$sftp->_conn_failed("$name not requested as expected", $expect->error);
return $sftp;
}
+ my $before = $expect->before;
+ if ($before =~ /^The authenticity of host /i or
+ $before =~ /^Warning: the \w+ host key for /i) {
+ $sftp->_conn_failed("the authenticity of the target host can not be established, connect from the command line first");
+ return $sftp;
+ }
$expect->send("$pass\n");
+ $sftp->{_password_sent} = 1;
unless ($expect->expect($eto, "\n")) {
$sftp->_conn_failed("$name interchange did not complete", $expect->error);
@@ -499,7 +523,7 @@
my $sftp = shift;
my $pid = $sftp->{pid};
- $debug and $debug & 4 and Net::SFTP::Foreign::_debug("$sftp->disconnect called (ssh pid: ".($pid||'').")");
+ $debug and $debug & 4 and _debug("$sftp->disconnect called (ssh pid: ".($pid||'').")");
$sftp->_conn_lost;
@@ -559,7 +583,7 @@
my $sftp = shift;
my $dbpid = $sftp->{_disconnect_by_pid};
- $debug and $debug & 4 and Net::SFTP::Foreign::_debug("$sftp->DESTROY called (current pid: $$, disconnect_by_pid: ".($dbpid||'').")");
+ $debug and $debug & 4 and _debug("$sftp->DESTROY called (current pid: $$, disconnect_by_pid: ".($dbpid||'').")");
$sftp->disconnect if (!defined $dbpid or $dbpid == $$);
}
@@ -588,6 +612,12 @@
$sftp->_conn_lost(SSH2_FX_BAD_MESSAGE,
SFTP_ERR_REMOTE_BAD_MESSAGE,
"bad packet type, expecting SSH2_FXP_VERSION, got $type");
+ }
+ elsif ($sftp->status == SSH2_FX_CONNECTION_LOST
+ and $sftp->{_password_authentication}
+ and $sftp->{_password_sent}) {
+ $sftp->_set_error(SFTP_ERR_PASSWORD_AUTHENTICATION_FAILED,
+ "Password authentication failed or connection lost");
}
return undef;
}
@@ -1315,7 +1345,7 @@
"Couldn't close remote file");
if ($debug and $debug & 2) {
- _debug("closing file handle, return: $ok, rid:");
+ _debug sprintf("closing file handle, return: %s, rid:", (defined $ok ? $ok : '-'));
_hexdump($sftp->_rid($_[0]));
}
@@ -1491,8 +1521,8 @@
my ($sftp, $old, $new) = @_;
$sftp->_check_extension('posix-rename at openssh.com' => 1,
- SFTP_ERR_REMOTE_FSTATVFS_FAILED,
- "fstatvfs failed")
+ SFTP_ERR_REMOTE_RENAME_FAILED,
+ "atomic rename failed")
or return undef;
$old = $sftp->_rel2abs($old);
@@ -2208,11 +2238,28 @@
my $atomic_readdir = delete $opts{atomic_readdir};
my $names_only = delete $opts{names_only};
my $realpath = delete $opts{realpath};
- my $wanted = delete $opts{_wanted} ||
- _gen_wanted(delete $opts{wanted},
- delete $opts{no_wanted});
+ my $queue_size = delete $opts{queue_size};
+ my $cheap = ($names_only and !$realpath);
+ my ($cheap_wanted, $wanted);
+ if ($cheap and
+ ref $opts{wanted} eq 'RegExp' and
+ not defined $opts{no_wanted}) {
+ $cheap_wanted = delete $opts{wanted}
+ }
+ else {
+ $wanted = (delete $opts{_wanted} ||
+ _gen_wanted(delete $opts{wanted},
+ delete $opts{no_wanted}));
+ undef $cheap if defined $wanted;
+ }
%opts and _croak_bad_options(keys %opts);
+
+ my $delayed_wanted = ($atomic_readdir and $wanted);
+ $queue_size = 1 if ($follow_links or $realpath or
+ ($wanted and not $delayed_wanted));
+ my $max_queue_size = $queue_size || $sftp->{_queue_size};
+ $queue_size ||= 2;
$dir = '.' unless defined $dir;
$dir = $sftp->_rel2abs($dir);
@@ -2224,54 +2271,71 @@
defined $rdid or return undef;
my @dir;
+ my @msgid;
+
OK: while (1) {
- my $id = $sftp->_queue_str_request(SSH2_FXP_READDIR, $rdid);
-
+ push @msgid, $sftp->_queue_str_request(SSH2_FXP_READDIR, $rdid)
+ while (@msgid < $queue_size);
+
+ my $id = shift @msgid;
if (my $msg = $sftp->_get_msg_and_check(SSH2_FXP_NAME, $id,
SFTP_ERR_REMOTE_READDIR_FAILED,
"Couldn't read directory '$dir'" )) {
my $count = $msg->get_int32 or last;
- for (1..$count) {
- my $fn = $sftp->_fs_decode($msg->get_str);
- my $ln = $sftp->_fs_decode($msg->get_str); #
- my $a = $msg->get_attributes;
-
- my $entry = { filename => $fn,
- longname => $ln,
- a => $a };
-
- if ($follow_links and S_ISLNK($a->perm)) {
-
- if ($a = $sftp->stat($sftp->join($dir, $fn))) {
- $entry->{a} = $a;
+ if ($cheap) {
+ for (1..$count) {
+ my $fn = $sftp->_fs_decode($msg->get_str);
+ push @dir, $fn if (!defined $cheap_wanted or $fn =~ $cheap_wanted);
+ $msg->skip_str;
+ Net::SFTP::Foreign::Attributes->skip_from_buffer($msg);
+ }
+ }
+ else {
+ for (1..$count) {
+ my $fn = $sftp->_fs_decode($msg->get_str);
+ my $ln = $sftp->_fs_decode($msg->get_str);
+ # my $a = $msg->get_attributes;
+ my $a = Net::SFTP::Foreign::Attributes->new_from_buffer($msg);
+
+ my $entry = { filename => $fn,
+ longname => $ln,
+ a => $a };
+
+ if ($follow_links and S_ISLNK($a->perm)) {
+
+ if ($a = $sftp->stat($sftp->join($dir, $fn))) {
+ $entry->{a} = $a;
+ }
+ else {
+ $sftp->_set_error;
+ $sftp->_set_status;
+ }
}
- else {
- $sftp->_set_error;
- $sftp->_set_status;
+
+ if ($realpath) {
+ my $rp = $sftp->realpath($fn);
+ if (defined $rp) {
+ $fn = $entry->{realpath} = $rp;
+ }
+ else {
+ $sftp->_set_error;
+ $sftp->_set_status;
+ }
+ }
+
+ if (!$wanted or $delayed_wanted or $wanted->($sftp, $entry)) {
+ push @dir, (($names_only and !$delayed_wanted) ? $fn : $entry);
}
}
-
-
- if ($realpath) {
- my $rp = $sftp->realpath($fn);
- if (defined $rp) {
- $fn = $entry->{realpath} = $rp;
- }
- else {
- $sftp->_set_error;
- $sftp->_set_status;
- }
- }
-
- if ($atomic_readdir or !$wanted or $wanted->($sftp, $entry)) {
- push @dir, ($names_only ? $fn : $entry);
- }
- }
+ }
+
+ $queue_size ++ if $queue_size < $max_queue_size;
}
else {
$sftp->_set_error if $sftp->{_status} == SSH2_FX_EOF;
+ $sftp->_get_msg for @msgid;
last;
}
}
@@ -2279,10 +2343,14 @@
$sftp->_closedir_save_status($rdh) if $rdh;
unless ($sftp->{_error}) {
- if ($atomic_readdir and $wanted) {
+ if ($delayed_wanted) {
@dir = grep { $wanted->($sftp, $_) } @dir;
+ @dir = map { defined $_->{realpath}
+ ? $_->{realpath}
+ : $_->{filename} } @dir
+ if $names_only;
}
-
+
if ($ordered) {
if ($names_only) {
@dir = sort @dir;
@@ -3011,8 +3079,16 @@
undef;
}
+sub EOF {
+ my $self = $_[0];
+ $self->_check or return undef;
+ my $sftp = $self->_sftp;
+ my $ret = $sftp->eof($self);
+ $sftp->_set_errno unless defined $ret;
+ $ret;
+}
+
*GETC = $gen_proxy_method->('getc');
-*EOF = $gen_proxy_method->('eof');
*TELL = $gen_proxy_method->('tell');
*SEEK = $gen_proxy_method->('seek');
*CLOSE = $gen_proxy_method->('close');
@@ -3637,7 +3713,11 @@
print "$_->{filename}\n" for (@$ls);
-The options accepted by this method are:
+
+
+The options accepted by this method are as follows (note that usage of
+some of them can degrade the method performance when reading large
+directories):
=over 4
@@ -3676,7 +3756,7 @@
When both C<no_wanted> and C<wanted> rules are used, the C<no_wanted>
rule is applied first and then the C<wanted> one (order is important
-if the callbacks have side effects).
+if the callbacks have side effects, experiment!).
=item ordered =E<gt> 1
Modified: branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Attributes.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Attributes.pm?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Attributes.pm (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Attributes.pm Tue Jul 7 03:59:11 2009
@@ -32,34 +32,57 @@
sub new_from_buffer {
my ($class, $buf) = @_;
my $self = $class->new;
-
- $self->{flags} = $buf->get_int32;
-
- if ($self->{flags} & SSH2_FILEXFER_ATTR_SIZE) {
+ my $flags = $self->{flags} = $buf->get_int32;
+
+ if ($flags & SSH2_FILEXFER_ATTR_SIZE) {
$self->{size} = $buf->get_int64;
}
- if ($self->{flags} & SSH2_FILEXFER_ATTR_UIDGID) {
+ if ($flags & SSH2_FILEXFER_ATTR_UIDGID) {
$self->{uid} = $buf->get_int32;
$self->{gid} = $buf->get_int32;
}
- if ($self->{flags} & SSH2_FILEXFER_ATTR_PERMISSIONS) {
+ if ($flags & SSH2_FILEXFER_ATTR_PERMISSIONS) {
$self->{perm} = $buf->get_int32;
}
- if ($self->{flags} & SSH2_FILEXFER_ATTR_ACMODTIME) {
+ if ($flags & SSH2_FILEXFER_ATTR_ACMODTIME) {
$self->{atime} = $buf->get_int32;
$self->{mtime} = $buf->get_int32;
}
- if ($self->{flags} & SSH2_FILEXFER_ATTR_EXTENDED) {
+ if ($flags & SSH2_FILEXFER_ATTR_EXTENDED) {
my $n = $buf->get_int32;
+ $n >= 0 and $n <= 10000 or return undef;
my @pairs = map $buf->get_str, 1..2*$n;
$self->{extended} = \@pairs;
}
$self;
+}
+
+sub skip_from_buffer {
+ my ($class, $buf) = @_;
+ my $flags = $buf->get_int32;
+ if ($flags == ( SSH2_FILEXFER_ATTR_SIZE |
+ SSH2_FILEXFER_ATTR_UIDGID |
+ SSH2_FILEXFER_ATTR_PERMISSIONS |
+ SSH2_FILEXFER_ATTR_ACMODTIME )) {
+ $buf->skip_bytes(28);
+ }
+ else {
+ my $len = 0;
+ $len += 8 if $flags & SSH2_FILEXFER_ATTR_SIZE;
+ $len += 8 if $flags & SSH2_FILEXFER_ATTR_UIDGID;
+ $len += 4 if $flags & SSH2_FILEXFER_ATTR_PERMISSIONS;
+ $len += 8 if $flags & SSH2_FILEXFER_ATTR_ACMODTIME;
+ $buf->skip_bytes($len);
+ if ($flags & SSH2_FILEXFER_ATTR_EXTENDED) {
+ my $n = $buf->get_int32;
+ $buf->skip_str, $buf->skip_str for (1..$n);
+ }
+ }
}
sub as_buffer {
Modified: branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Buffer.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Buffer.pm?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Buffer.pm (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Buffer.pm Tue Jul 7 03:59:11 2009
@@ -1,6 +1,6 @@
package Net::SFTP::Foreign::Buffer;
-our $VERSION = '1.45';
+our $VERSION = '1.52';
use strict;
use warnings;
@@ -38,30 +38,28 @@
unpack(N => substr(${$_[0]}, 0, 4, ''));
}
-sub get_int64 {
- my $self = shift;
- length $$self >=8 or return undef;
- if (HAS_QUADS) {
- return unpack(Q => substr($$self, 0, 8, ''))
+sub get_int64_quads { unpack Q => substr(${$_[0]}, 0, 8, '') }
+
+sub get_int64_no_quads {
+ length ${$_[0]} >= 8 or return undef;
+ my ($big, $small) = unpack(NN => substr(${$_[0]}, 0, 8, ''));
+ if ($big) {
+ # too big for an integer, try to handle it as a float:
+ my $high = $big * 4294967296;
+ my $result = $high + $small;
+ unless ($result - $high == $small) {
+ # too big event for a float, use a BigInt;
+ require Math::BigInt;
+ $result = Math::BigInt->new($big);
+ $result <<= 32;
+ $result += $small;
+ }
+ return $result;
}
- else {
- my ($big, $small) = unpack(NN => substr($$self, 0, 8, ''));
- if ($big) {
- # too big for an integer, try to handle it as a float:
- my $high = $big * 4294967296;
- my $result = $high + $small;
- unless ($result - $high == $small) {
- # too big event for a float, use a BigInt;
- require Math::BigInt;
- $result = Math::BigInt->new($big);
- $result <<= 32;
- $result += $small;
- }
- return $result;
- }
- return $small;
- }
+ return $small;
}
+
+*get_int64 = (HAS_QUADS ? \&get_int64_quads : \&get_int64_no_quads);
sub get_str {
my $self = shift;
@@ -71,38 +69,53 @@
substr($$self, 0, $len, '');
}
-
sub get_attributes { Net::SFTP::Foreign::Attributes->new_from_buffer($_[0]) }
+
+sub skip_bytes { substr(${$_[0]}, 0, $_[1], '') }
+
+sub skip_str {
+ my $self = shift;
+ my $len = $self->get_int32;
+ substr($$self, 0, $len, '');
+}
sub put_int8 { ${$_[0]} .= pack(C => $_[1]) }
sub put_int32 { ${$_[0]} .= pack(N => $_[1]) }
-sub put_int64 {
- if (HAS_QUADS) {
- ${$_[0]} .= pack(Q => $_[1])
+sub put_int64_quads { ${$_[0]} .= pack(Q => $_[1]) }
+
+sub put_int64_no_quads {
+ if ($_[1] >= 4294967296) {
+ my $high = int ( $_[1] / 4294967296);
+ my $low = int ($_[1] - $high * 4294967296);
+ ${$_[0]} .= pack(NN => $high, $low)
}
else {
- if ($_[1] >= 4294967296) {
- my $high = int ( $_[1] / 4294967296);
- my $low = int ($_[1] - $high * 4294967296);
- ${$_[0]} .= pack(NN => $high, $low)
- }
- else {
- ${$_[0]} .= pack(NN => 0, $_[1])
- }
+ ${$_[0]} .= pack(NN => 0, $_[1])
}
}
+*put_int64 = (HAS_QUADS ? \&put_int64_quads : \&put_int64_no_quads);
+
sub put_str {
- utf8::is_utf8($_[1]) and croak "UTF8 data reached the SFTP buffer";
+ utf8::downgrade($_[1]) or croak "UTF8 data reached the SFTP buffer";
${$_[0]} .= pack(N => length($_[1])) . $_[1]
}
sub put_char { ${$_[0]} .= $_[1] }
-sub put_attributes { ${$_[0]} .= ${$_[0]->as_buffer} }
+sub _attrs_as_buffer {
+ my $attrs = shift;
+ my $ref = ref $attrs;
+ Net::SFTP::Foreign::Attributes->isa($ref)
+ or croak("Object of class Net::SFTP::Foreign::Attributes "
+ . "expected, $ref found");
+ $attrs->as_buffer;
+}
+
+sub put_attributes { ${$_[0]} .= ${_attrs_as_buffer $_[1]} }
my %unpack = ( int8 => \&get_int8,
int32 => \&get_int32,
@@ -134,7 +147,7 @@
},
str => sub { pack(N => length($_[0])), $_[0] },
char => sub { $_[0] },
- attr => sub { ${$_[0]->as_buffer} } );
+ attr => sub { ${_attrs_as_buffer $_[0]} } );
sub put {
my $buf =shift;
Modified: branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Common.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Common.pm?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Common.pm (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Common.pm Tue Jul 7 03:59:11 2009
@@ -8,7 +8,7 @@
use Scalar::Util qw(dualvar tainted);
use Fcntl qw(S_ISLNK S_ISDIR);
-use Net::SFTP::Foreign::Helpers qw(_gen_wanted _ensure_list _debug);
+use Net::SFTP::Foreign::Helpers qw(_gen_wanted _ensure_list _debug $debug);
use Net::SFTP::Foreign::Constants qw(:status);
my %status_str = ( SSH2_FX_OK, "OK",
@@ -21,7 +21,6 @@
SSH2_FX_CONNECTION_LOST, "Connection lost",
SSH2_FX_OP_UNSUPPORTED, "Operation unsupported" );
-*debug = \$Net::SFTP::Foreign::debug;
our $debug;
sub _set_status {
@@ -159,7 +158,7 @@
next unless (defined $rp and not $rpdone{$rp}++);
}
}
-
+
if ($follow) {
my $a = $self->stat($fn);
if (defined $a) {
@@ -169,7 +168,7 @@
}
next;
}
-
+
if (!$wanted or $wanted->($self, $entry)) {
if ($wantarray) {
push @res, ( $names_only
@@ -193,10 +192,11 @@
no warnings 'uninitialized';
$try = shift @queue;
my $fn = $try->{filename};
- next if $done{$fn}++;
my $a = $try->{a} ||= $self->lstat($fn)
or next;
+
+ next if (S_ISDIR($a->perm) and $done{$fn}++);
$task->($try);
Modified: branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Constants.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Constants.pm?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Constants.pm (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Constants.pm Tue Jul 7 03:59:11 2009
@@ -1,6 +1,6 @@
package Net::SFTP::Foreign::Constants;
-our $VERSION = '1.30';
+our $VERSION = '1.52';
use strict;
use warnings;
@@ -116,6 +116,7 @@
SFTP_ERR_LOCAL_SEEK_FAILED => 47,
SFTP_ERR_REMOTE_STATVFS_FAILED => 48,
SFTP_ERR_REMOTE_FSTATVFS_FAILED => 49,
+ SFTP_ERR_PASSWORD_AUTHENTICATION_FAILED => 50,
);
for my $key (keys %constants) {
Modified: branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Helpers.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Helpers.pm?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Helpers.pm (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Helpers.pm Tue Jul 7 03:59:11 2009
@@ -1,6 +1,6 @@
package Net::SFTP::Foreign::Helpers;
-our $VERSION = '1.41';
+our $VERSION = '1.52';
use strict;
use warnings;
@@ -21,19 +21,48 @@
_catch_tainted_args
_debug
_gen_converter
+ _hexdump
+ $debug
);
-sub _do_nothing {}
+our $debug;
+
+BEGIN {
+ eval "use Time::HiRes 'time'"
+ if ($debug and $debug & 256)
+}
sub _debug {
local $\;
- if ($Net::SFTP::Foreign::debug & 256) {
- print STDERR "#", $$, " ", @_,"\n"
+ my $caller = '';
+ if ( $debug & 8192) {
+ $caller = (caller 1)[3];
+ $caller =~ s/[\w:]*:://;
+ $caller .= ': ';
+ }
+ if ($debug & 256) {
+ my $ts = sprintf("%010.5f", time);
+ print STDERR "#$$ $ts $caller", @_,"\n"
}
else {
- print STDERR '# ', @_,"\n"
- }
-}
+ print STDERR '# $caller', @_,"\n"
+ }
+}
+
+sub _hexdump {
+ no warnings qw(uninitialized);
+ my $data = shift;
+ while ($data =~ /(.{1,32})/smg) {
+ my $line=$1;
+ my @c= (( map { sprintf "%02x",$_ } unpack('C*', $line)),
+ ((" ") x 32))[0..31];
+ $line=~s/(.)/ my $c=$1; unpack("c",$c)>=32 ? $c : '.' /egms;
+ local $\;
+ print STDERR join(" ", @c, '|', $line), "\n";
+ }
+}
+
+sub _do_nothing {}
{
my $has_sk;
@@ -203,10 +232,9 @@
my $done;
sub {
$done and die "Internal error: bad calling sequence for unix2dos transformation";
- my $debug = ($Net::SFTP::Foreing::debug and $Net::SFTP::Foreing::debug & 128);
my $adjustment = 0;
for (@_) {
- if ($debug) {
+ if ($debug and $debug & 128) {
_debug ("before dos2unixunix2dos: previous: $previous, data follows...");
_hexdump($_);
}
@@ -224,7 +252,7 @@
$adjustment++;
$_ = "\x0d";
}
- if ($debug) {
+ if ($debug and $debug & 128) {
_debug ("after dos2unix: previous: $previous, adjustment: $adjustment, data follows...");
_hexdump($_);
}
@@ -234,13 +262,12 @@
}
sub _unix2dos {
- my $debug = ($Net::SFTP::Foreing::debug and $Net::SFTP::Foreing::debug & 128);
- if ($debug) {
+ if ($debug and $debug & 128) {
_debug ("before unix2dos: data follows...");
_hexdump($_[0]);
}
my $adjustment = $_[0] =~ s/\x0a/\x0d\x0a/gs;
- if ($debug) {
+ if ($debug and $debug & 128) {
_debug ("before unix2dos: adjustment: $adjustment, data follows...");
_hexdump($_[0]);
}
Modified: branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Local.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Local.pm?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Local.pm (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/lib/Net/SFTP/Foreign/Local.pm Tue Jul 7 03:59:11 2009
@@ -8,12 +8,8 @@
use File::Spec;
use Net::SFTP::Foreign::Attributes;
-use Net::SFTP::Foreign::Constants qw( :error );
-
-use Net::SFTP::Foreign::Helpers qw( _sort_entries
- _gen_wanted
- _do_nothing );
-
+use Net::SFTP::Foreign::Constants qw(:error);
+use Net::SFTP::Foreign::Helpers qw(_sort_entries _gen_wanted _do_nothing);
use Net::SFTP::Foreign::Common;
our @ISA = qw(Net::SFTP::Foreign::Common);
Modified: branches/upstream/libnet-sftp-foreign-perl/current/samples/passwd_conn.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/samples/passwd_conn.pl?rev=39440&op=diff
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/samples/passwd_conn.pl (original)
+++ branches/upstream/libnet-sftp-foreign-perl/current/samples/passwd_conn.pl Tue Jul 7 03:59:11 2009
@@ -1,4 +1,15 @@
#!/usr/bin/perl
+
+# This sample is obsolete and should not be used as a reference.
+#
+# Current versions of Net::SFTP::Foreign support password
+# authentication as long as the Expect module is installed:
+#
+# my $sftp = Net::SFTP::Foreign->new($host,
+# user => "me",
+# passwd => "quite-secret-passwd");
+# $sftp->error and die "unable to connect ro $host";
+#
use strict;
use warnings;
Added: branches/upstream/libnet-sftp-foreign-perl/current/samples/sftp_tail.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/samples/sftp_tail.pl?rev=39440&op=file
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/samples/sftp_tail.pl (added)
+++ branches/upstream/libnet-sftp-foreign-perl/current/samples/sftp_tail.pl Tue Jul 7 03:59:11 2009
@@ -1,0 +1,41 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Net::SFTP::Foreign;
+use Fcntl qw(SEEK_END);
+
+ at ARGV == 1
+ or usage();
+
+my ($host, $file) = $ARGV[0] =~ /([^:]+):(.+)/ or usage();
+
+my $sftp = Net::SFTP::Foreign->new($host);
+$sftp->error and die "Unable to connect to remote host: ".$sftp->error."\n";
+
+my $fh = $sftp->open($file)
+ or die "Unable to open file $file: ".$sftp->error."\n";
+
+# goto end of file
+seek($fh, 0, SEEK_END);
+
+my $sleep = 1;
+while (1) {
+ while (<$fh>) {
+ print;
+ $sleep = 1;
+ }
+ print "### sleeping $sleep\n";
+ sleep $sleep;
+ $sleep++ unless $sleep > 5;
+}
+
+sub usage {
+ warn <<EOW;
+Usage:
+ $0 [user@]host:/path/to/file
+EOW
+ exit 0;
+
+}
Added: branches/upstream/libnet-sftp-foreign-perl/current/t/4_perl5_11.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-sftp-foreign-perl/current/t/4_perl5_11.t?rev=39440&op=file
==============================================================================
--- branches/upstream/libnet-sftp-foreign-perl/current/t/4_perl5_11.t (added)
+++ branches/upstream/libnet-sftp-foreign-perl/current/t/4_perl5_11.t Tue Jul 7 03:59:11 2009
@@ -1,0 +1,27 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib "./t";
+use common;
+
+my $server; # = 'localhost';
+my $sscmd = sftp_server;
+
+plan skip_all => "tests not supported on inferior OS"
+ if (is_windows and eval "no warnings; getlogin ne 'salva'");
+plan skip_all => "sftp-server not found"
+ unless defined $sscmd;
+
+plan tests => 2;
+
+use Net::SFTP::Foreign;
+
+my $sftp = Net::SFTP::Foreign->new(open2_cmd => $sscmd, timeout => 20);
+my $fn = File::Spec->rel2abs('t/data.txd');
+
+ok(my $fh = $sftp->open($fn), "open");
+ok (!eof($fh), "eof");
More information about the Pkg-perl-cvs-commits
mailing list