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