Regression test for getftp bug (fails).

tests/ChangeLog

@@ -1,3 +1,24 @@
+2009-09-06  Micah Cowan  <micah@cowan.name>
+
+	* WgetTest.pm.in (_setup): Don't expect error codes from
+	_setup_server; none are returned.
+	(quotechar, _show_diff): Added facilities for expounding on where
+	output didn't match expectations.
+	(_verify_download): Use _show_diff.
+
+	* FTPTest.pm (_setup_server): Pass value of server_behavior to
+	FTPServer initialization.
+
+	* Test-ftp-pasv-fail.px: Added.
+	* run-px, Makefile.am (EXTRA_DIST): Added Test-ftp-pasv-fail.px.
+
+	* WgetTest.pm.in: Added "server_behavior" to the set of accepted
+	initialization values.
+	* FTPServer.pm (__open_data_connection): Add "server_behavior" to
+	the set of accepted initialization values.
+	(run): Honor the 'fail_on_pasv' server behavior setting, to
+	trigger the Wget getftp glitch.
+
 2009-09-05  Micah Cowan  <micah@cowan.name>
 
 	* Test-ftp-recursive.px: Added.

tests/FTPServer.pm

@@ -443,11 +443,12 @@ sub __open_data_connection
 
 {
     my %_attr_data = ( # DEFAULT
-        _input      => undef,
+        _input           => undef,
-        _localAddr  => 'localhost',
+        _localAddr       => 'localhost',
-        _localPort  => undef,
+        _localPort       => undef,
-        _reuseAddr  => 1,
+        _reuseAddr       => 1,
-        _rootDir    => Cwd::getcwd(),
+        _rootDir         => Cwd::getcwd(),
+        _server_behavior => {},
     );
 
     sub _default_for
@@ -562,13 +563,13 @@ sub run
             print STDERR "in child\n" if $log;
 
             my $conn = { 
-                'paths'        => FTPPaths->new($self->{'_input'}),
+                'paths'           => FTPPaths->new($self->{'_input'}),
-                'socket'       => $socket, 
+                'socket'          => $socket, 
-                'state'        => $_connection_states{NEWCONN},
+                'state'           => $_connection_states{NEWCONN},
-                'dir'          => '/',
+                'dir'             => '/',
-                'restart'      => 0,
+                'restart'         => 0,
-                'idle_timeout' => 60, # 1 minute timeout
+                'idle_timeout'    => 60, # 1 minute timeout
-                'rootdir'      => $self->{_rootDir},
+                'rootdir'         => $self->{_rootDir},
             };
 
             print {$conn->{socket}} "220 GNU Wget Testing FTP Server ready.\r\n";
@@ -618,6 +619,13 @@ sub run
                     last;
                 }
 
+                if (defined ($self->{_server_behavior}{fail_on_pasv})
+                        && $cmd eq 'PASV') {
+                    undef $self->{_server_behavior}{fail_on_pasv};
+                    close $socket;
+                    last;
+                }
+
                 # Run the command.
                 &{$command_table->{$cmd}} ($conn, $cmd, $rest);
             }

tests/FTPTest.pm

@@ -33,6 +33,8 @@ sub _setup_server {
     my $self = shift;
 
     $self->{_server} = FTPServer->new (input => $self->{_input},
+                                       server_behavior =>
+                                           $self->{_server_behavior},
                                        LocalAddr => 'localhost',
                                        ReuseAddr => 1,
                                        rootDir => "$self->{_workdir}/$self->{_name}/input") or die "Cannot create server!!!";

tests/Makefile.am

@@ -72,6 +72,7 @@ EXTRA_DIST = FTPServer.pm FTPTest.pm HTTPServer.pm HTTPTest.pm \
              Test-E-k-K.px \
              Test-E-k.px \
              Test-ftp.px \
+	     Test-ftp-pasv-fail.px \
              Test-ftp-recursive.px \
              Test-ftp-iri.px \
              Test-ftp-iri-fallback.px \

tests/Test-ftp-pasv-fail.px

@@ -0,0 +1,58 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use FTPTest;
+
+# This file exercises a problem in Wget, where if an error was
+# encountered in ftp.c:getftp before the actual file download
+# had started, Wget would believe that it had already downloaded the
+# full contents of the file, and would send a corresponding (erroneous)
+# REST value.
+
+###############################################################################
+
+# From bug report. :)
+my $afile = <<EOF;
+I've included log output (using the -d switch) from when this happens
+below. You'll see that for the retry wget sends a REST command to
+reset the start position before starting the RETR command. I'm
+confused about the argument to REST: 51132. It's the full length in
+bytes of the file to be retrieved. The RETR then shows the entire
+contents of the file being skipped, and wget announces that it
+successfully retrieved and saved 0 bytes.
+EOF
+
+$afile =~ s/\n/\r\n/g;
+
+
+# code, msg, headers, content
+my %urls = (
+    '/afile.txt' => {
+        content => $afile,
+    },
+);
+
+my $cmdline = $WgetTest::WGETPATH . " -S ftp://localhost:{{port}}/afile.txt";
+
+my $expected_error_code = 0;
+
+my %expected_downloaded_files = (
+    'afile.txt' => {
+        content => $afile,
+    },
+);
+
+###############################################################################
+
+my $the_test = FTPTest->new (name => "Test-ftp-pasv-fail",
+                             server_behavior => {fail_on_pasv => 1},
+                             input => \%urls, 
+                             cmdline => $cmdline, 
+                             errcode => $expected_error_code, 
+                             output => \%expected_downloaded_files);
+exit $the_test->run();
+
+# vim: et ts=4 sw=4
+

tests/WgetTest.pm.in

@@ -24,6 +24,7 @@ my @unexpected_downloads = ();
         _input        => {},
         _name         => "",
         _output       => {},
+        _server_behavior => {},
     );
 
     sub _default_for
@@ -151,10 +152,10 @@ sub _setup {
     }
 
     chdir ("../input");
-    my $ret = $self->_setup_server();
+    $self->_setup_server();
 
     chdir ($self->{_workdir});
-    return $ret;
+    return;
 }
 
 
@@ -165,6 +166,58 @@ sub _cleanup {
     File::Path::rmtree ($self->{_name}) unless $ENV{WGET_TEST_NO_CLEANUP};
 }
 
+# not a method
+sub quotechar {
+    my $c = ord( shift );
+    if ($c >= 0x7 && $c <= 0xD) {
+       return '\\' . qw(a b t n v f r)[$c - 0x7];
+    } else {
+        return sprintf('\\x%02x', $c);
+    }
+}
+
+# not a method
+sub _show_diff {
+    my $SNIPPET_SIZE = 10;
+
+    my ($expected, $actual) = @_;
+
+    my $str = '';
+    my $explen = length $expected;
+    my $actlen = length $actual;
+
+    if ($explen != $actlen) {
+        $str .= "Sizes don't match: expected = $explen, actual = $actlen\n";
+    }
+
+    my $min = $explen <= $actlen? $explen : $actlen;
+    my $line = 1;
+    my $col = 1;
+    my $i;
+    for ($i=0; $i != $min; ++$i) {
+        last if substr($expected, $i, 1) ne substr($actual, $i, 1);
+        if (substr($expected, $i, 1) eq '\n') {
+            $line++;
+            $col = 0;
+        } else {
+            $col++;
+        }
+    }
+    my $snip_start = $i - ($SNIPPET_SIZE / 2);
+    if ($snip_start < 0) {
+        $SNIPPET_SIZE += $snip_start; # Take it from the end.
+        $snip_start = 0;
+    }
+    my $exp_snip = substr($expected, $snip_start, $SNIPPET_SIZE);
+    my $act_snip = substr($actual, $snip_start, $SNIPPET_SIZE);
+    $exp_snip =~s/[^[:print:]]/ quotechar($&) /ge;
+    $act_snip =~s/[^[:print:]]/ quotechar($&) /ge;
+    $str .= "Mismatch at line $line, col $col:\n";
+    $str .= "    $exp_snip\n";
+    $str .= "    $act_snip\n";
+
+    return $str;
+}
 
 sub _verify_download {
     my $self = shift;
@@ -182,8 +235,10 @@ sub _verify_download {
         my $content = <FILE>;
         my $expected_content = $filedata->{'content'};
         $expected_content = $self->_substitute_port($expected_content);
-        $content eq $expected_content
+        unless ($content eq $expected_content) {
-            or return "Test failed: wrong content for file $filename\n";
+            return "Test failed: wrong content for file $filename\n"
+                . _show_diff($expected_content, $content);
+        }
 
         if (exists($filedata->{'timestamp'})) {
             my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,

tests/run-px

@@ -27,6 +27,7 @@ my @tests = (
     'Test-E-k-K.px',
     'Test-E-k.px',
     'Test-ftp.px',
+    'Test-ftp-pasv-fail.px',
     'Test-ftp-recursive.px',
     'Test-ftp-iri.px',
     'Test-ftp-iri-fallback.px',