[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Bug-wget] [PATCH] Stylistic and idiomatic cleanups in Perl tests
|
From: |
Pär Karlsson |
|
Subject: |
Re: [Bug-wget] [PATCH] Stylistic and idiomatic cleanups in Perl tests |
|
Date: |
Fri, 31 Oct 2014 18:44:03 +0100 |
Oh, and the test suite works on all stable versions of perl from 5.6
through 5.20.
No problems with any of these versions:
perl-5.6.2
perl-5.8.9
perl-5.10.1
perl-5.12.5
perl-5.14.4
perl-5.16.3
perl-5.18.4
perl-5.20.1
And I realize now I probably need some guidance how to format patches
properly for git format-patch/send-email. Sorry about the spam :-/
Best regards,
/Pär
2014-10-30 20:54 GMT+01:00 <address@hidden>:
> From: Pär Karlsson <address@hidden>
>
> ---
> tests/ChangeLog | 12 +
> tests/FTPServer.pm | 597
> +++++++++++++++++++++++----------------
> tests/FTPTest.pm | 36 +--
> tests/HTTPServer.pm | 208 +++++++++-----
> tests/HTTPTest.pm | 28 +-
> tests/Makefile.am | 2 +-
> tests/Test-proxied-https-auth.px | 2 +-
> tests/WgetFeature.pm | 41 ++-
> tests/WgetTest.pm | 423 +++++++++++++++++++++++++++
> tests/WgetTests.pm | 334 ----------------------
> 10 files changed, 993 insertions(+), 690 deletions(-)
>
> diff --git a/tests/ChangeLog b/tests/ChangeLog
> index 5f37f63..a05d65c 100644
> --- a/tests/ChangeLog
> +++ b/tests/ChangeLog
> @@ -1,3 +1,15 @@
> +2014-10-30 Pär Karlsson <address@hidden>
> + * WgetTests.pm: Renamed to WgetTest.pm to match package definition
> + * WgetTest.pm: Proper conditional operators, tidied up code,
> idiomatic
> + improvements as per modern Perl best practices.
> + * WgetFeature.pm: Tidied up code, idiomatic improvements for
> readability
> + * FTPServer.pm: Tidied up code (perltidy -gnu)
> + * FTPTest.pm: Likewise
> + * HTTPServer.pm: Likewise
> + * HTTPTest.pm: Likewise
> + * Makefile.am: Track name change of WgetTests.pm => WgetTest.pm
> + * Test-proxied-https-auth.px: Tidied up code
> +
> 2014-10-30 Mike Frysinger <address@hidden>
>
> * WgetFeature.pm: fix skip exit code to 77
> diff --git a/tests/FTPServer.pm b/tests/FTPServer.pm
> index 1603caa..6d8ad72 100644
> --- a/tests/FTPServer.pm
> +++ b/tests/FTPServer.pm
> @@ -19,43 +19,40 @@ my $GOT_SIGURG = 0;
>
> # connection states
> my %_connection_states = (
> - 'NEWCONN' => 0x01,
> - 'WAIT4PWD' => 0x02,
> - 'LOGGEDIN' => 0x04,
> - 'TWOSOCKS' => 0x08,
> -);
> + 'NEWCONN' => 0x01,
> + 'WAIT4PWD' => 0x02,
> + 'LOGGEDIN' => 0x04,
> + 'TWOSOCKS' => 0x08,
> + );
>
> # subset of FTP commands supported by these server and the respective
> # connection states in which they are allowed
> my %_commands = (
> +
> # Standard commands from RFC 959.
> - 'CWD' => $_connection_states{LOGGEDIN} |
> - $_connection_states{TWOSOCKS},
> -# 'EPRT' => $_connection_states{LOGGEDIN},
> -# 'EPSV' => $_connection_states{LOGGEDIN},
> + 'CWD' => $_connection_states{LOGGEDIN} |
> $_connection_states{TWOSOCKS},
> +
> + # 'EPRT' => $_connection_states{LOGGEDIN},
> + # 'EPSV' => $_connection_states{LOGGEDIN},
> 'LIST' => $_connection_states{TWOSOCKS},
> -# 'LPRT' => $_connection_states{LOGGEDIN},
> -# 'LPSV' => $_connection_states{LOGGEDIN},
> +
> + # 'LPRT' => $_connection_states{LOGGEDIN},
> + # 'LPSV' => $_connection_states{LOGGEDIN},
> 'PASS' => $_connection_states{WAIT4PWD},
> 'PASV' => $_connection_states{LOGGEDIN},
> 'PORT' => $_connection_states{LOGGEDIN},
> - 'PWD' => $_connection_states{LOGGEDIN} |
> - $_connection_states{TWOSOCKS},
> - 'QUIT' => $_connection_states{LOGGEDIN} |
> - $_connection_states{TWOSOCKS},
> + 'PWD' => $_connection_states{LOGGEDIN} |
> $_connection_states{TWOSOCKS},
> + 'QUIT' => $_connection_states{LOGGEDIN} |
> $_connection_states{TWOSOCKS},
> 'REST' => $_connection_states{TWOSOCKS},
> 'RETR' => $_connection_states{TWOSOCKS},
> 'SYST' => $_connection_states{LOGGEDIN},
> - 'TYPE' => $_connection_states{LOGGEDIN} |
> - $_connection_states{TWOSOCKS},
> + 'TYPE' => $_connection_states{LOGGEDIN} |
> $_connection_states{TWOSOCKS},
> 'USER' => $_connection_states{NEWCONN},
> +
> # From ftpexts Internet Draft.
> - 'SIZE' => $_connection_states{LOGGEDIN} |
> - $_connection_states{TWOSOCKS},
> + 'SIZE' => $_connection_states{LOGGEDIN} |
> $_connection_states{TWOSOCKS},
> );
>
> -
> -
> # COMMAND-HANDLING ROUTINES
>
> sub _CWD_command
> @@ -67,7 +64,8 @@ sub _CWD_command
> my $new_path = FTPPaths::path_merge($conn->{'dir'}, $path);
>
> # Split the path into its component parts and process each separately.
> - if (! $paths->dir_exists($new_path)) {
> + if (!$paths->dir_exists($new_path))
> + {
> print {$conn->{socket}} "550 Directory not found.\r\n";
> return;
> }
> @@ -81,25 +79,24 @@ sub _LIST_command
> my ($conn, $cmd, $path) = @_;
> my $paths = $conn->{'paths'};
>
> - my $ReturnEmptyList = ( $paths->GetBehavior('list_empty_if_list_a') &&
> - $path eq '-a');
> - my $SkipHiddenFiles = ( $paths->GetBehavior('list_no_hidden_if_list')
> &&
> - ( ! $path ) );
> + my $ReturnEmptyList =
> + ($paths->GetBehavior('list_empty_if_list_a') && $path eq '-a');
> + my $SkipHiddenFiles =
> + ($paths->GetBehavior('list_no_hidden_if_list') && (!$path));
>
> if ($paths->GetBehavior('list_fails_if_list_a') && $path eq '-a')
> - {
> - print {$conn->{socket}} "500 Unknown command\r\n";
> - return;
> - }
> -
> + {
> + print {$conn->{socket}} "500 Unknown command\r\n";
> + return;
> + }
>
> if (!$paths->GetBehavior('list_dont_clean_path'))
> - {
> + {
> # This is something of a hack. Some clients expect a Unix server
> # to respond to flags on the 'ls command line'. Remove these flags
> # and ignore them. This is particularly an issue with ncftp 2.4.3.
> $path =~ s/^-[a-zA-Z0-9]+\s?//;
> - }
> + }
>
> my $dir = $conn->{'dir'};
>
> @@ -111,39 +108,44 @@ sub _LIST_command
>
> my $listing;
> if (!$ReturnEmptyList)
> - {
> + {
> $dir = FTPPaths::path_merge($dir, $path);
> - $listing = $paths->get_list($dir,$SkipHiddenFiles);
> - unless ($listing) {
> + $listing = $paths->get_list($dir, $SkipHiddenFiles);
> + unless ($listing)
> + {
> print {$conn->{socket}} "550 File or directory not
> found.\r\n";
> return;
> }
> - }
> + }
>
> print STDERR "_LIST_command - dir is: $dir\n" if $log;
>
> print {$conn->{socket}} "150 Opening data connection for file
> listing.\r\n";
>
> # Open a path back to the client.
> - my $sock = __open_data_connection ($conn);
> - unless ($sock) {
> + my $sock = __open_data_connection($conn);
> + unless ($sock)
> + {
> print {$conn->{socket}} "425 Can't open data connection.\r\n";
> return;
> }
>
> if (!$ReturnEmptyList)
> - {
> - for my $item (@$listing) {
> + {
> + for my $item (@$listing)
> + {
> print $sock "$item\r\n";
> }
> - }
> + }
>
> - unless ($sock->close) {
> + unless ($sock->close)
> + {
> print {$conn->{socket}} "550 Error closing data connection:
> $!\r\n";
> return;
> }
>
> - print {$conn->{socket}} "226 Listing complete. Data connection has
> been closed.\r\n";
> + print {$conn->{socket}}
> + "226 Listing complete. Data connection has been closed.\r\n";
> }
>
> sub _PASS_command
> @@ -155,10 +157,15 @@ sub _PASS_command
> print STDERR "switching to LOGGEDIN state\n" if $log;
> $conn->{state} = $_connection_states{LOGGEDIN};
>
> - if ($conn->{username} eq "anonymous") {
> - print {$conn->{socket}} "202 Anonymous user access is always
> granted.\r\n";
> - } else {
> - print {$conn->{socket}} "230 Authentication not implemented yet,
> access is always granted.\r\n";
> + if ($conn->{username} eq "anonymous")
> + {
> + print {$conn->{socket}}
> + "202 Anonymous user access is always granted.\r\n";
> + }
> + else
> + {
> + print {$conn->{socket}}
> + "230 Authentication not implemented yet, access is always
> granted.\r\n";
> }
> }
>
> @@ -167,28 +174,31 @@ sub _PASV_command
> my ($conn, $cmd, $rest) = @_;
>
> # Open a listening socket - but don't actually accept on it yet.
> - "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
> - my $sock = IO::Socket::INET->new (LocalHost => '127.0.0.1',
> - LocalPort => '0',
> - Listen => 1,
> - Reuse => 1,
> - Proto => 'tcp',
> - Type => SOCK_STREAM);
> -
> - unless ($sock) {
> + "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
> + my $sock = IO::Socket::INET->new(
> + LocalHost => '127.0.0.1',
> + LocalPort => '0',
> + Listen => 1,
> + Reuse => 1,
> + Proto => 'tcp',
> + Type => SOCK_STREAM
> + );
> +
> + unless ($sock)
> + {
> # Return a code 550 here, even though this is not in the RFC. XXX
> print {$conn->{socket}} "550 Can't open a listening socket.\r\n";
> return;
> }
>
> - $conn->{passive} = 1;
> + $conn->{passive} = 1;
> $conn->{passive_socket} = $sock;
>
> # Get our port number.
> my $sockport = $sock->sockport;
>
> # Split the port number into high and low components.
> - my $p1 = int ($sockport / 256);
> + my $p1 = int($sockport / 256);
> my $p2 = $sockport % 256;
>
> $conn->{state} = $_connection_states{TWOSOCKS};
> @@ -204,33 +214,42 @@ sub _PORT_command
> # The arguments to PORT are a1,a2,a3,a4,p1,p2 where a1 is the
> # most significant part of the address (eg. 127,0,0,1) and
> # p1 is the most significant part of the port.
> - unless ($rest =~
> /^\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3})/)
> {
> + unless ($rest =~
> +
> /^\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3})/
> + )
> + {
> print {$conn->{socket}} "501 Syntax error in PORT command.\r\n";
> return;
> }
>
> # Check host address.
> - unless ($1 > 0 && $1 < 224 &&
> - $2 >= 0 && $2 < 256 &&
> - $3 >= 0 && $3 < 256 &&
> - $4 >= 0 && $4 < 256) {
> + unless ( $1 > 0
> + && $1 < 224
> + && $2 >= 0
> + && $2 < 256
> + && $3 >= 0
> + && $3 < 256
> + && $4 >= 0
> + && $4 < 256)
> + {
> print {$conn->{socket}} "501 Invalid host address.\r\n";
> return;
> }
>
> # Construct host address and port number.
> my $peeraddrstring = "$1.$2.$3.$4";
> - my $peerport = $5 * 256 + $6;
> + my $peerport = $5 * 256 + $6;
>
> # Check port number.
> - unless ($peerport > 0 && $peerport < 65536) {
> + unless ($peerport > 0 && $peerport < 65536)
> + {
> print {$conn->{socket}} "501 Invalid port number.\r\n";
> }
>
> $conn->{peeraddrstring} = $peeraddrstring;
> - $conn->{peeraddr} = inet_aton ($peeraddrstring);
> - $conn->{peerport} = $peerport;
> - $conn->{passive} = 0;
> + $conn->{peeraddr} = inet_aton($peeraddrstring);
> + $conn->{peerport} = $peerport;
> + $conn->{passive} = 0;
>
> $conn->{state} = $_connection_states{TWOSOCKS};
>
> @@ -253,8 +272,10 @@ sub _REST_command
> {
> my ($conn, $cmd, $restart_from) = @_;
>
> - unless ($restart_from =~ /^([1-9][0-9]*|0)$/) {
> - print {$conn->{socket}} "501 REST command needs a numeric
> argument.\r\n";
> + unless ($restart_from =~ /^([1-9][0-9]*|0)$/)
> + {
> + print {$conn->{socket}}
> + "501 REST command needs a numeric argument.\r\n";
> return;
> }
>
> @@ -270,19 +291,21 @@ sub _RETR_command
> $path = FTPPaths::path_merge($conn->{dir}, $path);
> my $info = $conn->{'paths'}->get_info($path);
>
> - unless ($info->{'_type'} eq 'f') {
> + unless ($info->{'_type'} eq 'f')
> + {
> print {$conn->{socket}} "550 File not found.\r\n";
> return;
> }
>
> - print {$conn->{socket}} "150 Opening " .
> - ($conn->{type} eq 'A' ? "ASCII mode" : "BINARY mode") .
> - " data connection.\r\n";
> + print {$conn->{socket}} "150 Opening "
> + . ($conn->{type} eq 'A' ? "ASCII mode" : "BINARY mode")
> + . " data connection.\r\n";
>
> # Open a path back to the client.
> - my $sock = __open_data_connection ($conn);
> + my $sock = __open_data_connection($conn);
>
> - unless ($sock) {
> + unless ($sock)
> + {
> print {$conn->{socket}} "425 Can't open data connection.\r\n";
> return;
> }
> @@ -290,13 +313,14 @@ sub _RETR_command
> my $content = $info->{'content'};
>
> # Restart the connection from previous point?
> - if ($conn->{restart}) {
> + if ($conn->{restart})
> + {
> $content = substr($content, $conn->{restart});
> $conn->{restart} = 0;
> }
>
> # What mode are we sending this file in?
> - unless ($conn->{type} eq 'A') # Binary type.
> + unless ($conn->{type} eq 'A') # Binary type.
> {
> my ($r, $buffer, $n, $w, $sent);
>
> @@ -310,14 +334,16 @@ sub _RETR_command
> # Restart alarm clock timer.
> alarm $conn->{idle_timeout};
>
> - for ($n = 0; $n < $r; )
> + for ($n = 0 ; $n < $r ;)
> {
> - $w = syswrite ($sock, $buffer, $r - $n, $n);
> + $w = syswrite($sock, $buffer, $r - $n, $n);
>
> # Cleanup and exit if there was an error.
> - unless (defined $w) {
> + unless (defined $w)
> + {
> close $sock;
> - print {$conn->{socket}} "426 File retrieval error:
> $!. Data connection has been closed.\r\n";
> + print {$conn->{socket}}
> + "426 File retrieval error: $!. Data connection has
> been closed.\r\n";
> return;
> }
>
> @@ -325,25 +351,32 @@ sub _RETR_command
> }
>
> # Transfer aborted by client?
> - if ($GOT_SIGURG) {
> + if ($GOT_SIGURG)
> + {
> $GOT_SIGURG = 0;
> close $sock;
> - print {$conn->{socket}} "426 Transfer aborted. Data
> connection closed.\r\n";
> + print {$conn->{socket}}
> + "426 Transfer aborted. Data connection closed.\r\n";
> return;
> }
> $sent += $r;
> }
>
> # Cleanup and exit if there was an error.
> - unless (defined $r) {
> + unless (defined $r)
> + {
> close $sock;
> - print {$conn->{socket}} "426 File retrieval error: $!. Data
> connection has been closed.\r\n";
> + print {$conn->{socket}}
> + "426 File retrieval error: $!. Data connection has been
> closed.\r\n";
> return;
> }
> - } else { # ASCII type.
> - # Copy data.
> + }
> + else
> + { # ASCII type.
> + # Copy data.
> my @lines = split /\r\n?|\n/, $content;
> - for (@lines) {
> + for (@lines)
> + {
> # Remove any native line endings.
> s/[\n\r]+$//;
>
> @@ -354,21 +387,25 @@ sub _RETR_command
> print $sock "$_\r\n";
>
> # Transfer aborted by client?
> - if ($GOT_SIGURG) {
> + if ($GOT_SIGURG)
> + {
> $GOT_SIGURG = 0;
> close $sock;
> - print {$conn->{socket}} "426 Transfer aborted. Data
> connection closed.\r\n";
> + print {$conn->{socket}}
> + "426 Transfer aborted. Data connection closed.\r\n";
> return;
> }
> }
> }
>
> - unless (close ($sock)) {
> + unless (close($sock))
> + {
> print {$conn->{socket}} "550 File retrieval error: $!.\r\n";
> return;
> }
>
> - print {$conn->{socket}} "226 File retrieval complete. Data connection
> has been closed.\r\n";
> + print {$conn->{socket}}
> + "226 File retrieval complete. Data connection has been closed.\r\n";
> }
>
> sub _SIZE_command
> @@ -377,13 +414,16 @@ sub _SIZE_command
>
> $path = FTPPaths::path_merge($conn->{dir}, $path);
> my $info = $conn->{'paths'}->get_info($path);
> - unless ($info) {
> + unless ($info)
> + {
> print {$conn->{socket}} "550 File or directory not found.\r\n";
> return;
> }
>
> - if ($info->{'_type'} eq 'd') {
> - print {$conn->{socket}} "550 SIZE command is not supported on
> directories.\r\n";
> + if ($info->{'_type'} eq 'd')
> + {
> + print {$conn->{socket}}
> + "550 SIZE command is not supported on directories.\r\n";
> return;
> }
>
> @@ -397,13 +437,14 @@ sub _SYST_command
> my ($conn, $cmd, $dummy) = @_;
>
> if ($conn->{'paths'}->GetBehavior('syst_response'))
> - {
> - print {$conn->{socket}}
> $conn->{'paths'}->GetBehavior('syst_response') . "\r\n";
> - }
> + {
> + print {$conn->{socket}}
> $conn->{'paths'}->GetBehavior('syst_response')
> + . "\r\n";
> + }
> else
> - {
> + {
> print {$conn->{socket}} "215 UNIX Type: L8\r\n";
> - }
> + }
> }
>
> sub _TYPE_command
> @@ -411,14 +452,22 @@ sub _TYPE_command
> my ($conn, $cmd, $type) = @_;
>
> # See RFC 959 section 5.3.2.
> - if ($type =~ /^([AI])$/i) {
> + if ($type =~ /^([AI])$/i)
> + {
> $conn->{type} = $1;
> - } elsif ($type =~ /^([AI])\sN$/i) {
> + }
> + elsif ($type =~ /^([AI])\sN$/i)
> + {
> $conn->{type} = $1;
> - } elsif ($type =~ /^L\s8$/i) {
> + }
> + elsif ($type =~ /^L\s8$/i)
> + {
> $conn->{type} = 'L8';
> - } else {
> - print {$conn->{socket}} "504 This server does not support TYPE
> $type.\r\n";
> + }
> + else
> + {
> + print {$conn->{socket}}
> + "504 This server does not support TYPE $type.\r\n";
> return;
> }
>
> @@ -435,14 +484,16 @@ sub _USER_command
> print STDERR "switching to WAIT4PWD state\n" if $log;
> $conn->{state} = $_connection_states{WAIT4PWD};
>
> - if ($conn->{username} eq "anonymous") {
> + if ($conn->{username} eq "anonymous")
> + {
> print {$conn->{socket}} "230 Anonymous user access granted.\r\n";
> - } else {
> + }
> + else
> + {
> print {$conn->{socket}} "331 Password required.\r\n";
> }
> }
>
> -
> # HELPER ROUTINES
>
> sub __open_data_connection
> @@ -451,36 +502,41 @@ sub __open_data_connection
>
> my $sock;
>
> - if ($conn->{passive}) {
> + if ($conn->{passive})
> + {
> # Passive mode - wait for a connection from the client.
> - accept ($sock, $conn->{passive_socket}) or return undef;
> - } else {
> + accept($sock, $conn->{passive_socket}) or return undef;
> + }
> + else
> + {
> # Active mode - connect back to the client.
> - "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
> - $sock = IO::Socket::INET->new (LocalAddr => '127.0.0.1',
> - PeerAddr =>
> $conn->{peeraddrstring},
> - PeerPort => $conn->{peerport},
> - Proto => 'tcp',
> - Type => SOCK_STREAM) or return
> undef;
> + "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
> + $sock = IO::Socket::INET->new(
> + LocalAddr => '127.0.0.1',
> + PeerAddr =>
> $conn->{peeraddrstring},
> + PeerPort => $conn->{peerport},
> + Proto => 'tcp',
> + Type => SOCK_STREAM
> + )
> + or return undef;
> }
>
> return $sock;
> }
>
> -
>
> ###########################################################################
> # FTPSERVER CLASS
>
> ###########################################################################
>
> {
> - my %_attr_data = ( # DEFAULT
> - _input => undef,
> - _localAddr => 'localhost',
> - _localPort => undef,
> - _reuseAddr => 1,
> - _rootDir => Cwd::getcwd(),
> - _server_behavior => {},
> - );
> + my %_attr_data = ( # DEFAULT
> + _input => undef,
> + _localAddr => 'localhost',
> + _localPort => undef,
> + _reuseAddr => 1,
> + _rootDir => Cwd::getcwd(),
> + _server_behavior => {},
> + );
>
> sub _default_for
> {
> @@ -494,34 +550,44 @@ sub __open_data_connection
> }
> }
>
> -
> -sub new {
> +sub new
> +{
> my ($caller, %args) = @_;
> my $caller_is_obj = ref($caller);
> - my $class = $caller_is_obj || $caller;
> - my $self = bless {}, $class;
> - foreach my $attrname ($self->_standard_keys()) {
> + my $class = $caller_is_obj || $caller;
> + my $self = bless {}, $class;
> + foreach my $attrname ($self->_standard_keys())
> + {
> my ($argname) = ($attrname =~ /^_(.*)/);
> - if (exists $args{$argname}) {
> + if (exists $args{$argname})
> + {
> $self->{$attrname} = $args{$argname};
> - } elsif ($caller_is_obj) {
> + }
> + elsif ($caller_is_obj)
> + {
> $self->{$attrname} = $caller->{$attrname};
> - } else {
> + }
> + else
> + {
> $self->{$attrname} = $self->_default_for($attrname);
> }
> }
> +
> # create server socket
> - "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
> - $self->{_server_sock}
> - = IO::Socket::INET->new (LocalHost =>
> $self->{_localAddr},
> - LocalPort =>
> $self->{_localPort},
> - Listen => 1,
> - Reuse => $self->{_reuseAddr},
> - Proto => 'tcp',
> - Type => SOCK_STREAM)
> - or die "bind: $!";
> -
> - foreach my $file (keys %{$self->{_input}}) {
> + "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
> + $self->{_server_sock} =
> + IO::Socket::INET->new(
> + LocalHost => $self->{_localAddr},
> + LocalPort => $self->{_localPort},
> + Listen => 1,
> + Reuse => $self->{_reuseAddr},
> + Proto => 'tcp',
> + Type => SOCK_STREAM
> + )
> + or die "bind: $!";
> +
> + foreach my $file (keys %{$self->{_input}})
> + {
> my $ref = \$self->{_input}{$file}{content};
> $$ref =~ s/{{port}}/$self->sockport/eg;
> }
> @@ -529,18 +595,18 @@ sub new {
> return $self;
> }
>
> -
> sub run
> {
> my ($self, $synch_callback) = @_;
> my $initialized = 0;
>
> # turn buffering off on STDERR
> - select((select(STDERR), $|=1)[0]);
> + select((select(STDERR), $| = 1)[0]);
>
> # initialize command table
> my $command_table = {};
> - foreach (keys %_commands) {
> + foreach (keys %_commands)
> + {
> my $subname = "_${_}_command";
> $command_table->{$_} = \&$subname;
> }
> @@ -548,7 +614,8 @@ sub run
> my $old_ils = $/;
> $/ = "\r\n";
>
> - if (!$initialized) {
> + if (!$initialized)
> + {
> $synch_callback->();
> $initialized = 1;
> }
> @@ -557,14 +624,14 @@ sub run
> my $server_sock = $self->{_server_sock};
>
> # the accept loop
> - while (my $client_addr = accept (my $socket, $server_sock))
> + while (my $client_addr = accept(my $socket, $server_sock))
> {
> # turn buffering off on $socket
> - select((select($socket), $|=1)[0]);
> + select((select($socket), $| = 1)[0]);
>
> # find out who connected
> - my ($client_port, $client_ip) = sockaddr_in ($client_addr);
> - my $client_ipnum = inet_ntoa ($client_ip);
> + my ($client_port, $client_ip) = sockaddr_in($client_addr);
> + my $client_ipnum = inet_ntoa($client_ip);
>
> # print who connected
> print STDERR "got a connection from: $client_ipnum\n" if $log;
> @@ -577,11 +644,12 @@ sub run
> # next;
> # }
>
> - if (1) { # Child process.
> + if (1)
> + { # Child process.
>
> # install signals
> - $SIG{URG} = sub {
> - $GOT_SIGURG = 1;
> + $SIG{URG} = sub {
> + $GOT_SIGURG = 1;
> };
>
> $SIG{PIPE} = sub {
> @@ -590,33 +658,35 @@ sub run
> };
>
> $SIG{ALRM} = sub {
> - print STDERR "Connection idle timeout expired. Closing
> server.\n";
> + print STDERR
> + "Connection idle timeout expired. Closing server.\n";
> exit;
> };
>
> #$SIG{CHLD} = 'IGNORE';
>
> -
> print STDERR "in child\n" if $log;
>
> my $conn = {
> - 'paths' => FTPPaths->new($self->{'_input'},
> - $self->{'_server_behavior'}),
> - 'socket' => $socket,
> - 'state' => $_connection_states{NEWCONN},
> - 'dir' => '/',
> - 'restart' => 0,
> - 'idle_timeout' => 60, # 1 minute timeout
> - 'rootdir' => $self->{_rootDir},
> - };
> -
> - print {$conn->{socket}} "220 GNU Wget Testing FTP Server
> ready.\r\n";
> + 'paths' =>
> + FTPPaths->new($self->{'_input'},
> $self->{'_server_behavior'}),
> + 'socket' => $socket,
> + 'state' => $_connection_states{NEWCONN},
> + 'dir' => '/',
> + 'restart' => 0,
> + 'idle_timeout' => 60, # 1 minute timeout
> + 'rootdir' => $self->{_rootDir},
> + };
> +
> + print {$conn->{socket}}
> + "220 GNU Wget Testing FTP Server ready.\r\n";
>
> # command handling loop
> - for (;;) {
> + for (; ;)
> + {
> print STDERR "waiting for request\n" if $log;
>
> - last unless defined (my $req = <$socket>);
> + last unless defined(my $req = <$socket>);
>
> # Remove trailing CRLF.
> $req =~ s/[\n\r]+$//;
> @@ -625,7 +695,8 @@ sub run
>
> # Get the command.
> # See also RFC 2640 section 3.1.
> - unless ($req =~ m/^([A-Z]{3,4})\s?(.*)/i) {
> + unless ($req =~ m/^([A-Z]{3,4})\s?(.*)/i)
> + {
> # badly formed command
> exit 0;
> }
> @@ -640,34 +711,41 @@ sub run
> my ($cmd, $rest) = (uc $1, $2);
>
> # Got a command which matches in the table?
> - unless (exists $command_table->{$cmd}) {
> + unless (exists $command_table->{$cmd})
> + {
> print {$conn->{socket}} "500 Unrecognized
> command.\r\n";
> next;
> }
>
> # Command requires user to be authenticated?
> - unless ($_commands{$cmd} | $conn->{state}) {
> + unless ($_commands{$cmd} | $conn->{state})
> + {
> print {$conn->{socket}} "530 Not logged in.\r\n";
> next;
> }
>
> # Handle the QUIT command specially.
> - if ($cmd eq "QUIT") {
> - print {$conn->{socket}} "221 Goodbye. Service closing
> connection.\r\n";
> + if ($cmd eq "QUIT")
> + {
> + print {$conn->{socket}}
> + "221 Goodbye. Service closing connection.\r\n";
> last;
> }
>
> - if (defined ($self->{_server_behavior}{fail_on_pasv})
> - && $cmd eq 'PASV') {
> + 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);
> + &{$command_table->{$cmd}}($conn, $cmd, $rest);
> }
> - } else { # Father
> + }
> + else
> + { # Father
> close $socket;
> }
> }
> @@ -675,18 +753,19 @@ sub run
> $/ = $old_ils;
> }
>
> -sub sockport {
> +sub sockport
> +{
> my $self = shift;
> return $self->{_server_sock}->sockport;
> }
>
> -
> package FTPPaths;
>
> use POSIX qw(strftime);
>
> # not a method
> -sub final_component {
> +sub final_component
> +{
> my $path = shift;
>
> $path =~ s|.*/||;
> @@ -694,34 +773,48 @@ sub final_component {
> }
>
> # not a method
> -sub path_merge {
> - my ($a, $b) = @_;
> +sub path_merge
> +{
> + my ($path_a, $path_b) = @_;
>
> - return $a unless $b;
> + if (!$path_b)
> + {
> + return $path_a;
> + }
>
> - if ($b =~ m.^/.) {
> - $a = '';
> - $b =~ s.^/..;
> + if ($path_b =~ m.^/.)
> + {
> + $path_a = '';
> + $path_b =~ s.^/..;
> }
> - $a =~ s./$..;
> + $path_a =~ s./$..;
>
> - my @components = split('/', $b);
> + my @components = split m{/}msx, $path_b;
>
> - foreach my $c (@components) {
> - if ($c =~ /^\.?$/) {
> + foreach my $c (@components)
> + {
> + if ($c =~ /^\.?$/)
> + {
> next;
> - } elsif ($c eq '..') {
> - next if $a eq '';
> - $a =~ s|/[^/]*$||;
> - } else {
> - $a .= "/$c";
> + }
> + elsif ($c eq '..')
> + {
> + if (!$path_a) {
> + next;
> + }
> + $path_a =~ s|/[^/]*$||;
> + }
> + else
> + {
> + $path_a .= "/$c";
> }
> }
>
> - return $a;
> + return $path_a;
> }
>
> -sub new {
> +sub new
> +{
> my ($this, @args) = @_;
> my $class = ref($this) || $this;
> my $self = {};
> @@ -730,19 +823,23 @@ sub new {
> return $self;
> }
>
> -sub initialize {
> +sub initialize
> +{
> my ($self, $urls, $behavior) = @_;
> my $paths = {_type => 'd'};
>
> # From a path like '/foo/bar/baz.txt', construct $paths such that
> # $paths->{'foo'}->{'bar'}->{'baz.txt'} is
> # $urls->{'/foo/bar/baz.txt'}.
> - for my $path (keys %$urls) {
> - my @components = split('/', $path);
> + for my $path (keys %$urls)
> + {
> + my @components = split m{/}msx, $path;
> shift @components;
> my $x = $paths;
> - for my $c (@components) {
> - unless (exists $x->{$c}) {
> + for my $c (@components)
> + {
> + if (!exists $x->{$c})
> + {
> $x->{$c} = {_type => 'd'};
> }
> $x = $x->{$c};
> @@ -751,32 +848,40 @@ sub initialize {
> $x->{_type} = 'f';
> }
>
> - $self->{'_paths'} = $paths;
> + $self->{'_paths'} = $paths;
> $self->{'_behavior'} = $behavior;
> + return 1;
> }
>
> -sub get_info {
> +sub get_info
> +{
> my ($self, $path, $node) = @_;
> $node = $self->{'_paths'} unless $node;
> my @components = split('/', $path);
> shift @components if @components && $components[0] eq '';
>
> - for my $c (@components) {
> - if ($node->{'_type'} eq 'd') {
> + for my $c (@components)
> + {
> + if ($node->{'_type'} eq 'd')
> + {
> $node = $node->{$c};
> - } else {
> - return undef;
> + }
> + else
> + {
> + return;
> }
> }
> return $node;
> }
>
> -sub dir_exists {
> +sub dir_exists
> +{
> my ($self, $path) = @_;
> - return $self->exists($path, 'd');
> + return $self->path_exists($path, 'd');
> }
>
> -sub exists {
> +sub path_exists
> +{
> # type is optional, in which case we don't check it.
> my ($self, $path, $type) = @_;
> my $paths = $self->{'_paths'};
> @@ -788,52 +893,67 @@ sub exists {
> return 1;
> }
>
> -sub _format_for_list {
> +sub _format_for_list
> +{
> my ($self, $name, $info) = @_;
>
> # XXX: mode should be specifyable as part of the node info.
> my $mode_str;
> - if ($info->{'_type'} eq 'd') {
> + if ($info->{'_type'} eq 'd')
> + {
> $mode_str = 'dr-xr-xr-x';
> - } else {
> + }
> + else
> + {
> $mode_str = '-r--r--r--';
> }
>
> my $size = 0;
> - if ($info->{'_type'} eq 'f') {
> - $size = length $info->{'content'};
> - if ($self->{'_behavior'}{'bad_list'}) {
> + if ($info->{'_type'} eq 'f')
> + {
> + $size = length $info->{'content'};
> + if ($self->{'_behavior'}{'bad_list'})
> + {
> $size = 0;
> }
> }
> - my $date = strftime ("%b %e %H:%M", localtime);
> + my $date = strftime("%b %e %H:%M", localtime);
> return "$mode_str 1 0 0 $size $date $name";
> }
>
> -sub get_list {
> +sub get_list
> +{
> my ($self, $path, $no_hidden) = @_;
> my $info = $self->get_info($path);
> - return undef unless defined $info;
> + if ( !defined $info )
> + {
> + return;
> + }
> my $list = [];
>
> - if ($info->{'_type'} eq 'd') {
> - for my $item (keys %$info) {
> + if ($info->{'_type'} eq 'd')
> + {
> + for my $item (keys %$info)
> + {
> next if $item =~ /^_/;
> +
> # 2013-10-17 Andrea Urbani (matfanjol)
> # I skip the hidden files if requested
> - if (($no_hidden) &&
> - (defined($info->{$item}->{'attr'})) &&
> - (index($info->{$item}->{'attr'}, "H")>=0))
> - {
> + if ( ($no_hidden)
> + && (defined($info->{$item}->{'attr'}))
> + && (index($info->{$item}->{'attr'}, "H") >= 0))
> + {
> # This is an hidden file and I don't want to see it!
> print STDERR "get_list: Skipped hidden file [$item]\n";
> - }
> + }
> else
> - {
> + {
> push @$list, $self->_format_for_list($item,
> $info->{$item});
> - }
> + }
> }
> - } else {
> + }
> + else
> + {
> push @$list, $self->_format_for_list(final_component($path),
> $info);
> }
>
> @@ -858,9 +978,10 @@ sub get_list {
> # to the url files
> # syst_response : if defined, its content is printed
> # out as SYST response
> -sub GetBehavior {
> - my ($self, $name) = @_;
> - return $self->{'_behavior'}{$name};
> +sub GetBehavior
> +{
> + my ($self, $name) = @_;
> + return $self->{'_behavior'}{$name};
> }
>
> 1;
> diff --git a/tests/FTPTest.pm b/tests/FTPTest.pm
> index 98fc061..576ce05 100644
> --- a/tests/FTPTest.pm
> +++ b/tests/FTPTest.pm
> @@ -4,14 +4,13 @@ use strict;
> use warnings;
>
> use FTPServer;
> -use WgetTests;
> +use WgetTest;
>
> our @ISA = qw(WgetTest);
> my $VERSION = 0.01;
>
> -
> {
> - my %_attr_data = ( # DEFAULT
> + my %_attr_data = ( # DEFAULT
> );
>
> sub _default_for
> @@ -28,29 +27,32 @@ my $VERSION = 0.01;
> }
> }
>
> -
> -sub _setup_server {
> +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!!!";
> + $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!!!";
> }
>
> -
> -sub _launch_server {
> - my $self = shift;
> +sub _launch_server
> +{
> + my $self = shift;
> my $synch_func = shift;
>
> - $self->{_server}->run ($synch_func);
> + $self->{_server}->run($synch_func);
> }
>
> -sub _substitute_port {
> +sub _substitute_port
> +{
> my $self = shift;
> - my $ret = shift;
> + my $ret = shift;
> $ret =~ s/{{port}}/$self->{_server}->sockport/eg;
> return $ret;
> }
> diff --git a/tests/HTTPServer.pm b/tests/HTTPServer.pm
> index adadb45..aacc460 100644
> --- a/tests/HTTPServer.pm
> +++ b/tests/HTTPServer.pm
> @@ -8,47 +8,58 @@ use HTTP::Status;
> use HTTP::Headers;
> use HTTP::Response;
>
> -our @ISA=qw(HTTP::Daemon);
> +our @ISA = qw(HTTP::Daemon);
> my $VERSION = 0.01;
>
> -my $CRLF = "\015\012"; # "\r\n" is not portable
> -my $log = undef;
> +my $CRLF = "\015\012"; # "\r\n" is not portable
> +my $log = undef;
>
> -sub run {
> +sub run
> +{
> my ($self, $urls, $synch_callback) = @_;
> my $initialized = 0;
>
> - while (1) {
> - if (!$initialized) {
> + while (1)
> + {
> + if (!$initialized)
> + {
> $synch_callback->();
> $initialized = 1;
> }
> my $con = $self->accept();
> print STDERR "Accepted a new connection\n" if $log;
> - while (my $req = $con->get_request) {
> + while (my $req = $con->get_request)
> + {
> #my $url_path = $req->url->path;
> my $url_path = $req->url->as_string;
> - if ($url_path =~ m{/$}) { # append 'index.html'
> + if ($url_path =~ m{/$})
> + { # append 'index.html'
> $url_path .= 'index.html';
> }
> +
> #if ($url_path =~ m{^/}) { # remove trailing '/'
> # $url_path = substr ($url_path, 1);
> #}
> - if ($log) {
> + if ($log)
> + {
> print STDERR "Method: ", $req->method, "\n";
> print STDERR "Path: ", $url_path, "\n";
> print STDERR "Available URLs: ", "\n";
> - foreach my $key (keys %$urls) {
> + foreach my $key (keys %$urls)
> + {
> print STDERR $key, "\n";
> }
> }
> - if (exists($urls->{$url_path})) {
> + if (exists($urls->{$url_path}))
> + {
> print STDERR "Serving requested URL: ", $url_path, "\n"
> if $log;
> next unless ($req->method eq "HEAD" || $req->method eq
> "GET");
>
> my $url_rec = $urls->{$url_path};
> $self->send_response($req, $url_rec, $con);
> - } else {
> + }
> + else
> + {
> print STDERR "Requested wrong URL: ", $url_path, "\n" if
> $log;
> $con->send_error($HTTP::Status::RC_FORBIDDEN);
> last;
> @@ -59,73 +70,89 @@ sub run {
> }
> }
>
> -sub send_response {
> +sub send_response
> +{
> my ($self, $req, $url_rec, $con) = @_;
>
> # create response
> my ($code, $msg, $headers);
> my $send_content = ($req->method eq "GET");
> - if (exists $url_rec->{'auth_method'}) {
> + if (exists $url_rec->{'auth_method'})
> + {
> ($send_content, $code, $msg, $headers) =
> - $self->handle_auth($req, $url_rec);
> - } elsif (!$self->verify_request_headers ($req, $url_rec)) {
> + $self->handle_auth($req, $url_rec);
> + }
> + elsif (!$self->verify_request_headers($req, $url_rec))
> + {
> ($send_content, $code, $msg, $headers) =
> - ('', 400, 'Mismatch on expected headers', {});
> - } else {
> + ('', 400, 'Mismatch on expected headers', {});
> + }
> + else
> + {
> ($code, $msg) = @{$url_rec}{'code', 'msg'};
> $headers = $url_rec->{headers};
> }
> - my $resp = HTTP::Response->new ($code, $msg);
> + my $resp = HTTP::Response->new($code, $msg);
> print STDERR "HTTP::Response: \n", $resp->as_string if $log;
>
> - while (my ($name, $value) = each %{$headers}) {
> + while (my ($name, $value) = each %{$headers})
> + {
> # print STDERR "setting header: $name = $value\n";
> $resp->header($name => $value);
> }
> print STDERR "HTTP::Response with headers: \n", $resp->as_string if
> $log;
>
> - if ($send_content) {
> + if ($send_content)
> + {
> my $content = $url_rec->{content};
> - if (exists($url_rec->{headers}{"Content-Length"})) {
> + if (exists($url_rec->{headers}{"Content-Length"}))
> + {
> # Content-Length and length($content) don't match
> # manually prepare the HTTP response
> - $con->send_basic_header($url_rec->{code}, $resp->message,
> $resp->protocol);
> + $con->send_basic_header($url_rec->{code}, $resp->message,
> + $resp->protocol);
> print $con $resp->headers_as_string($CRLF);
> print $con $CRLF;
> print $con $content;
> next;
> }
> - if ($req->header("Range") && !$url_rec->{'force_code'}) {
> + if ($req->header("Range") && !$url_rec->{'force_code'})
> + {
> $req->header("Range") =~ m/bytes=(\d*)-(\d*)/;
> my $content_len = length($content);
> - my $start = $1 ? $1 : 0;
> - my $end = $2 ? $2 : ($content_len - 1);
> - my $len = $2 ? ($2 - $start) : ($content_len - $start);
> - if ($len > 0) {
> - $resp->header("Accept-Ranges" => "bytes");
> + my $start = $1 ? $1 : 0;
> + my $end = $2 ? $2 : ($content_len - 1);
> + my $len = $2 ? ($2 - $start) : ($content_len -
> $start);
> + if ($len > 0)
> + {
> + $resp->header("Accept-Ranges" => "bytes");
> $resp->header("Content-Length" => $len);
> - $resp->header("Content-Range"
> - => "bytes $start-$end/$content_len");
> + $resp->header(
> + "Content-Range" => "bytes
> $start-$end/$content_len");
> $resp->header("Keep-Alive" => "timeout=15, max=100");
> $resp->header("Connection" => "Keep-Alive");
> $con->send_basic_header(206,
> - "Partial Content", $resp->protocol);
> + "Partial Content",
> $resp->protocol);
> print $con $resp->headers_as_string($CRLF);
> print $con $CRLF;
> print $con substr($content, $start, $len);
> - } else {
> + }
> + else
> + {
> $con->send_basic_header(416, "Range Not Satisfiable",
> - $resp->protocol);
> + $resp->protocol);
> $resp->header("Keep-Alive" => "timeout=15, max=100");
> $resp->header("Connection" => "Keep-Alive");
> print $con $CRLF;
> }
> next;
> }
> +
> # fill in content
> $content = $self->_substitute_port($content) if defined $content;
> $resp->content($content);
> - print STDERR "HTTP::Response with content: \n", $resp->as_string
> if $log;
> + print STDERR "HTTP::Response with content: \n", $resp->as_string
> + if $log;
> }
>
> $con->send_response($resp);
> @@ -134,60 +161,81 @@ sub send_response {
>
> # Generates appropriate response content based on the authentication
> # status of the URL.
> -sub handle_auth {
> +sub handle_auth
> +{
> my ($self, $req, $url_rec) = @_;
> my ($send_content, $code, $msg, $headers);
> +
> # Catch failure to set code, msg:
> $code = 500;
> $msg = "Didn't set response code in handle_auth";
> +
> # Most cases, we don't want to send content.
> $send_content = 0;
> +
> # Initialize headers
> $headers = {};
> my $authhdr = $req->header('Authorization');
>
> # Have we sent the challenge yet?
> - unless ($url_rec->{auth_challenged} || $url_rec->{auth_no_challenge})
> {
> + unless ($url_rec->{auth_challenged} || $url_rec->{auth_no_challenge})
> + {
> # Since we haven't challenged yet, we'd better not
> # have received authentication (for our testing purposes).
> - if ($authhdr) {
> + if ($authhdr)
> + {
> $code = 400;
> $msg = "You sent auth before I sent challenge";
> - } else {
> + }
> + else
> + {
> # Send challenge
> $code = 401;
> $msg = "Authorization Required";
> - $headers->{'WWW-Authenticate'} = $url_rec->{'auth_method'}
> - . " realm=\"wget-test\"";
> + $headers->{'WWW-Authenticate'} =
> + $url_rec->{'auth_method'} . " realm=\"wget-test\"";
> $url_rec->{auth_challenged} = 1;
> }
> - } elsif (!defined($authhdr)) {
> + }
> + elsif (!defined($authhdr))
> + {
> # We've sent the challenge; we should have received valid
> # authentication with this one. A normal server would just
> # resend the challenge; but since this is a test, wget just
> # failed it.
> $code = 400;
> $msg = "You didn't send auth after I sent challenge";
> - if ($url_rec->{auth_no_challenge}) {
> - $msg = "--auth-no-challenge but no auth sent."
> + if ($url_rec->{auth_no_challenge})
> + {
> + $msg = "--auth-no-challenge but no auth sent.";
> }
> - } else {
> + }
> + else
> + {
> my ($sent_method) = ($authhdr =~ /^(\S+)/g);
> - unless ($sent_method eq $url_rec->{'auth_method'}) {
> + unless ($sent_method eq $url_rec->{'auth_method'})
> + {
> # Not the authorization type we were expecting.
> $code = 400;
> - $msg = "Expected auth type $url_rec->{'auth_method'} but got "
> - . "$sent_method";
> - } elsif (($sent_method eq 'Digest'
> - && &verify_auth_digest($authhdr, $url_rec, \$msg))
> - ||
> - ($sent_method eq 'Basic'
> - && &verify_auth_basic($authhdr, $url_rec, \$msg))) {
> + $msg = "Expected auth type $url_rec->{'auth_method'} but got
> "
> + . "$sent_method";
> + }
> + elsif (
> + (
> + $sent_method eq 'Digest'
> + && &verify_auth_digest($authhdr, $url_rec, \$msg)
> + )
> + || ( $sent_method eq 'Basic'
> + && &verify_auth_basic($authhdr, $url_rec, \$msg))
> + )
> + {
> # SUCCESSFUL AUTH: send expected message, headers, content.
> ($code, $msg) = @{$url_rec}{'code', 'msg'};
> - $headers = $url_rec->{headers};
> + $headers = $url_rec->{headers};
> $send_content = 1;
> - } else {
> + }
> + else
> + {
> $code = 400;
> }
> }
> @@ -195,43 +243,58 @@ sub handle_auth {
> return ($send_content, $code, $msg, $headers);
> }
>
> -sub verify_auth_digest {
> - return undef; # Not yet implemented.
> +sub verify_auth_digest
> +{
> + return undef; # Not yet implemented.
> }
>
> -sub verify_auth_basic {
> +sub verify_auth_basic
> +{
> require MIME::Base64;
> my ($authhdr, $url_rec, $msgref) = @_;
> - my $expected = MIME::Base64::encode_base64($url_rec->{'user'} . ':'
> - . $url_rec->{'passwd'}, '');
> + my $expected =
> + MIME::Base64::encode_base64(
> + $url_rec->{'user'} . ':' .
> $url_rec->{'passwd'},
> + '');
> my ($got) = $authhdr =~ /^Basic (.*)$/;
> - if ($got eq $expected) {
> + if ($got eq $expected)
> + {
> return 1;
> - } else {
> + }
> + else
> + {
> $$msgref = "Wanted ${expected} got ${got}";
> return undef;
> }
> }
>
> -sub verify_request_headers {
> +sub verify_request_headers
> +{
> my ($self, $req, $url_rec) = @_;
>
> return 1 unless exists $url_rec->{'request_headers'};
> - for my $hdrname (keys %{$url_rec->{'request_headers'}}) {
> + for my $hdrname (keys %{$url_rec->{'request_headers'}})
> + {
> my $must_not_match;
> my $ehdr = $url_rec->{'request_headers'}{$hdrname};
> - if ($must_not_match = ($hdrname =~ /^!(\w+)/)) {
> + if ($must_not_match = ($hdrname =~ /^!(\w+)/))
> + {
> $hdrname = $1;
> }
> - my $rhdr = $req->header ($hdrname);
> - if ($must_not_match) {
> - if (defined $rhdr && $rhdr =~ $ehdr) {
> + my $rhdr = $req->header($hdrname);
> + if ($must_not_match)
> + {
> + if (defined $rhdr && $rhdr =~ $ehdr)
> + {
> $rhdr = '' unless defined $rhdr;
> print STDERR "\n*** Match forbidden $hdrname: $rhdr =~
> $ehdr\n";
> return undef;
> }
> - } else {
> - unless (defined $rhdr && $rhdr =~ $ehdr) {
> + }
> + else
> + {
> + unless (defined $rhdr && $rhdr =~ $ehdr)
> + {
> $rhdr = '' unless defined $rhdr;
> print STDERR "\n*** Mismatch on $hdrname: $rhdr =~
> $ehdr\n";
> return undef;
> @@ -242,9 +305,10 @@ sub verify_request_headers {
> return 1;
> }
>
> -sub _substitute_port {
> +sub _substitute_port
> +{
> my $self = shift;
> - my $ret = shift;
> + my $ret = shift;
> $ret =~ s/{{port}}/$self->sockport/eg;
> return $ret;
> }
> diff --git a/tests/HTTPTest.pm b/tests/HTTPTest.pm
> index e0e436f..5c7f1e9 100644
> --- a/tests/HTTPTest.pm
> +++ b/tests/HTTPTest.pm
> @@ -4,14 +4,13 @@ use strict;
> use warnings;
>
> use HTTPServer;
> -use WgetTests;
> +use WgetTest;
>
> our @ISA = qw(WgetTest);
> my $VERSION = 0.01;
>
> -
> {
> - my %_attr_data = ( # DEFAULT
> + my %_attr_data = ( # DEFAULT
> );
>
> sub _default_for
> @@ -28,25 +27,26 @@ my $VERSION = 0.01;
> }
> }
>
> -
> -sub _setup_server {
> +sub _setup_server
> +{
> my $self = shift;
> - $self->{_server} = HTTPServer->new (LocalAddr => 'localhost',
> - ReuseAddr => 1)
> - or die "Cannot create server!!!";
> + $self->{_server} = HTTPServer->new(LocalAddr => 'localhost',
> + ReuseAddr => 1)
> + or die "Cannot create server!!!";
> }
>
> -
> -sub _launch_server {
> - my $self = shift;
> +sub _launch_server
> +{
> + my $self = shift;
> my $synch_func = shift;
>
> - $self->{_server}->run ($self->{_input}, $synch_func);
> + $self->{_server}->run($self->{_input}, $synch_func);
> }
>
> -sub _substitute_port {
> +sub _substitute_port
> +{
> my $self = shift;
> - my $ret = shift;
> + my $ret = shift;
> $ret =~ s/{{port}}/$self->{_server}->sockport/eg;
> return $ret;
> }
> diff --git a/tests/Makefile.am b/tests/Makefile.am
> index 58ef5b7..b8fe2fb 100644
> --- a/tests/Makefile.am
> +++ b/tests/Makefile.am
> @@ -129,7 +129,7 @@ PX_TESTS = \
> Test-204.px
>
> EXTRA_DIST = FTPServer.pm FTPTest.pm HTTPServer.pm HTTPTest.pm \
> - WgetTests.pm WgetFeature.pm WgetFeature.cfg $(PX_TESTS) \
> + WgetTest.pm WgetFeature.pm WgetFeature.cfg $(PX_TESTS) \
> certs
>
> check_PROGRAMS = unit-tests
> diff --git a/tests/Test-proxied-https-auth.px
> b/tests/Test-proxied-https-auth.px
> index 272003f..97fb5f0 100755
> --- a/tests/Test-proxied-https-auth.px
> +++ b/tests/Test-proxied-https-auth.px
> @@ -4,7 +4,7 @@ use strict;
> use warnings;
>
> use WgetFeature qw(https);
> -use WgetTests; # For $WGETPATH.
> +use WgetTest; # For $WGETPATH.
>
> my $cert_path;
> my $key_path;
> diff --git a/tests/WgetFeature.pm b/tests/WgetFeature.pm
> index 118e79c..a829fad 100644
> --- a/tests/WgetFeature.pm
> +++ b/tests/WgetFeature.pm
> @@ -3,26 +3,41 @@ package WgetFeature;
> use strict;
> use warnings;
>
> -use WgetTests;
> +our $VERSION = 0.01;
>
> -our %skip_messages;
> -require 'WgetFeature.cfg';
> +use Carp;
> +use English qw(-no_match_vars);
> +use WgetTest;
> +
> +our %SKIP_MESSAGES;
> +{
> + open my $fh, '<', 'WgetFeature.cfg'
> + or croak "Cannot open 'WgetFeature.cfg': $ERRNO";
> + my @lines = <$fh>;
> + close $fh or carp "Cannot close 'WgetFeature.cfg': $ERRNO";
> + eval {
> + @lines;
> + 1;
> + } or carp "Cannot eval 'WgetFeature.cfg': $ERRNO";
> +}
>
> sub import
> {
> my ($class, $feature) = @_;
>
> my $output = `$WgetTest::WGETPATH --version`;
> - my ($list) = $output =~ /^([\+\-]\S+(?:\s+[\+\-]\S+)+)/m;
> - my %have_features = map {
> - my $feature = $_;
> - $feature =~ s/^.//;
> - ($feature, /^\+/ ? 1 : 0);
> - } split /\s+/, $list;
> -
> - unless ($have_features{$feature}) {
> - print $skip_messages{$feature}, "\n";
> - exit 77; # skip
> + my ($list) = $output =~ m/^([+-]\S+(?:\s+[+-]\S+)+)/msx;
> + my %have_features;
> + for my $f (split m/\s+/msx, $list)
> + {
> + my $feat = $f;
> + $feat =~ s/^.//msx;
> + $have_features{$feat} = $f =~ m/^[+]/msx ? 1 : 0;
> + }
> + if (!$have_features{$feature})
> + {
> + print "$SKIP_MESSAGES{$feature}\n";
> + exit 77; # skip
> }
> }
>
> diff --git a/tests/WgetTest.pm b/tests/WgetTest.pm
> new file mode 100644
> index 0000000..889a65b
> --- /dev/null
> +++ b/tests/WgetTest.pm
> @@ -0,0 +1,423 @@
> +package WgetTest;
> +
> +use strict;
> +use warnings;
> +
> +our $VERSION = 0.01;
> +
> +use Carp;
> +use Cwd;
> +use English qw(-no_match_vars);
> +use File::Path;
> +use IO::Handle;
> +use POSIX qw(locale_h);
> +use locale;
> +
> +our $WGETPATH = '../src/wget';
> +
> +my @unexpected_downloads = ();
> +
> +{
> + my %_attr_data = ( # DEFAULT
> + _cmdline => q{},
> + _workdir => Cwd::getcwd(),
> + _errcode => 0,
> + _existing => {},
> + _input => {},
> + _name => $PROGRAM_NAME,
> + _output => {},
> + _server_behavior => {},
> + );
> +
> + sub _default_for
> + {
> + my ($self, $attr) = @_;
> + return $_attr_data{$attr};
> + }
> +
> + sub _standard_keys
> + {
> + return keys %_attr_data;
> + }
> +}
> +
> +sub new
> +{
> + my ($caller, %args) = @_;
> + my $caller_is_obj = ref $caller;
> + my $class = $caller_is_obj || $caller;
> +
> + #print STDERR "class = ", $class, "\n";
> + #print STDERR "_attr_data {workdir} = ",
> $WgetTest::_attr_data{_workdir}, "\n";
> + my $self = bless {}, $class;
> + for my $attrname ($self->_standard_keys())
> + {
> +
> + #print STDERR "attrname = ", $attrname, " value = ";
> + my ($argname) = ($attrname =~ m/^_(.*)/msx);
> + if (exists $args{$argname})
> + {
> +
> + #printf STDERR "Setting up $attrname\n";
> + $self->{$attrname} = $args{$argname};
> + }
> + elsif ($caller_is_obj)
> + {
> +
> + #printf STDERR "Copying $attrname\n";
> + $self->{$attrname} = $caller->{$attrname};
> + }
> + else
> + {
> + #printf STDERR "Using default for $attrname\n";
> + $self->{$attrname} = $self->_default_for($attrname);
> + }
> +
> + #print STDERR $attrname, '=', $self->{$attrname}, "\n";
> + }
> +
> + #printf STDERR "_workdir default = ", $self->_default_for("_workdir");
> + return $self;
> +}
> +
> +sub run
> +{
> + my $self = shift;
> + my $result_message = "Test successful.\n";
> + my $errcode;
> +
> + $self->{_name} =~ s{.*/}{}msx; # remove path
> + $self->{_name} =~ s{[.][^.]+$}{}msx; # remove extension
> + printf "Running test $self->{_name}\n";
> +
> + # Setup
> + my $new_result = $self->_setup();
> + chdir "$self->{_workdir}/$self->{_name}/input"
> + or carp "Could not chdir to input directory: $ERRNO";
> + if (defined $new_result)
> + {
> + $result_message = $new_result;
> + $errcode = 1;
> + goto cleanup;
> + }
> +
> + # Launch server
> + my $pid = $self->_fork_and_launch_server();
> +
> + # Call wget
> + chdir "$self->{_workdir}/$self->{_name}/output"
> + or carp "Could not chdir to output directory: $ERRNO";
> +
> + my $cmdline = $self->{_cmdline};
> + $cmdline = $self->_substitute_port($cmdline);
> + $cmdline =
> + ($cmdline =~ m{^/.*}msx) ? $cmdline : "$self->{_workdir}/$cmdline";
> +
> + my $valgrind = $ENV{VALGRIND_TESTS};
> + if (!defined $valgrind || $valgrind eq q{} || $valgrind == 0)
> + {
> +
> + # Valgrind not requested - leave $cmdline as it is
> + }
> + elsif ($valgrind == 1)
> + {
> + $cmdline =
> + 'valgrind --error-exitcode=301 --leak-check=yes
> --track-origins=yes '
> + . $cmdline;
> + }
> + else
> + {
> + $cmdline = "$valgrind $cmdline";
> + }
> +
> + print "Calling $cmdline\n";
> + $errcode = system $cmdline;
> + $errcode >>= 8; # XXX: should handle abnormal error codes.
> +
> + # Shutdown server
> + # if we didn't explicitely kill the server, we would have to call
> + # waitpid ($pid, 0) here in order to wait for the child process to
> + # terminate
> + kill 'TERM', $pid;
> +
> + # Verify download
> + if ($errcode != $self->{_errcode})
> + {
> + $result_message =
> + "Test failed: wrong code returned (was: $errcode, expected:
> $self->{_errcode})\n";
> + goto CLEANUP;
> + }
> + my $error_str;
> + if ($error_str = $self->_verify_download())
> + {
> + $result_message = $error_str;
> + }
> +
> + CLEANUP:
> + $self->_cleanup();
> +
> + print $result_message;
> + return $errcode != $self->{_errcode} || ($error_str ? 1 : 0);
> +}
> +
> +sub _setup
> +{
> + my $self = shift;
> +
> + chdir $self->{_workdir}
> + or carp "Could not chdir into $self->{_workdir}: $ERRNO";
> +
> + # Create temporary directory
> + mkdir $self->{_name} or carp "Could not mkdir '$self->{_name}':
> $ERRNO";
> + chdir $self->{_name}
> + or carp "Could not chdir into '$self->{_name}': $ERRNO";
> + mkdir 'input' or carp "Could not mkdir 'input' $ERRNO";
> + mkdir 'output' or carp "Could not mkdir 'output': $ERRNO";
> +
> + # Setup existing files
> + chdir 'output' or carp "Could not chdir into 'output': $ERRNO";
> + for my $filename (keys %{$self->{_existing}})
> + {
> + open my $fh, '>', $filename
> + or return "Test failed: cannot open pre-existing file
> $filename\n";
> +
> + my $file = $self->{_existing}->{$filename};
> + print {$fh} $file->{content}
> + or return "Test failed: cannot write pre-existing file
> $filename\n";
> +
> + close $fh or carp $ERRNO;
> +
> + if (exists($file->{timestamp}))
> + {
> + utime $file->{timestamp}, $file->{timestamp}, $filename
> + or return
> + "Test failed: cannot set timestamp on pre-existing file
> $filename\n";
> + }
> + }
> +
> + chdir '../input' or carp "Cannot chdir into '../input': $ERRNO";
> + $self->_setup_server();
> +
> + chdir $self->{_workdir}
> + or carp "Cannot chdir into '$self->{_workdir}': $ERRNO";
> + return;
> +}
> +
> +sub _cleanup
> +{
> + my $self = shift;
> +
> + chdir $self->{_workdir}
> + or carp "Could not chdir into '$self->{_workdir}': $ERRNO";
> + if (!$ENV{WGET_TEST_NO_CLEANUP})
> + {
> + File::Path::rmtree($self->{_name});
> + }
> + return 1;
> +}
> +
> +# not a method
> +sub quotechar
> +{
> + my $c = ord shift;
> + if ($c >= 0x7 && $c <= 0xD)
> + {
> + return q{\\} . qw(a b t n v f r) [$c - 0x7];
> + }
> + else
> + {
> + return sprintf '\\x%02x', $c;
> + }
> +}
> +
> +# not a method
> +sub _show_diff
> +{
> + my ($expected, $actual) = @_;
> + my $SNIPPET_SIZE = 10;
> +
> + my $str = q{};
> + 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) {
> + for my $i (0 .. $min - 1)
> + {
> + last if substr($expected, $i, 1) ne substr $actual, $i, 1;
> + if (substr($expected, $i, 1) eq q{\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($&) /gemsx;
> + $act_snip =~ s/[^[:print:]]/ quotechar($&) /gemsx;
> + $str .= "Mismatch at line $line, col $col:\n";
> + $str .= " $exp_snip\n";
> + $str .= " $act_snip\n";
> +
> + return $str;
> +}
> +
> +sub _verify_download
> +{
> + my $self = shift;
> +
> + chdir "$self->{_workdir}/$self->{_name}/output"
> + or carp "Could not chdir into output directory: $ERRNO";
> +
> + # use slurp mode to read file content
> + my $old_input_record_separator = $INPUT_RECORD_SEPARATOR;
> + local $INPUT_RECORD_SEPARATOR = undef;
> +
> + while (my ($filename, $filedata) = each %{$self->{_output}})
> + {
> + open my $fh, '<', $filename
> + or return "Test failed: file $filename not downloaded\n";
> +
> + my $content = <$fh>;
> +
> + close $fh or carp $ERRNO;
> +
> + my $expected_content = $filedata->{'content'};
> + $expected_content = $self->_substitute_port($expected_content);
> + if ($content ne $expected_content)
> + {
> + 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, $atime, $mtime,
> + $ctime, $blksize, $blocks
> + )
> + = stat $filename;
> +
> + $mtime == $filedata->{'timestamp'}
> + or return "Test failed: wrong timestamp for file
> $filename\n";
> + }
> +
> + }
> +
> + local $INPUT_RECORD_SEPARATOR = $old_input_record_separator;
> +
> + # make sure no unexpected files were downloaded
> + chdir "$self->{_workdir}/$self->{_name}/output"
> + or carp "Could not change into output directory: $ERRNO";
> +
> + __dir_walk(
> + q{.},
> + sub {
> + if (!(exists $self->{_output}{$_[0]} ||
> $self->{_existing}{$_[0]}))
> + {
> + push @unexpected_downloads, $_[0];
> + }
> + },
> + sub { shift; return @_ }
> + );
> + if (@unexpected_downloads)
> + {
> + return 'Test failed: unexpected downloaded files [' . join ', ',
> + @unexpected_downloads . "]\n";
> + }
> +
> + return q{};
> +}
> +
> +sub __dir_walk
> +{
> + my ($top, $filefunc, $dirfunc) = @_;
> +
> + my $DIR;
> +
> + if (-d $top)
> + {
> + my $file;
> + if (!opendir $DIR, $top)
> + {
> + warn "Couldn't open directory $DIR: $ERRNO; skipping.\n";
> + return;
> + }
> +
> + my @results;
> + while ($file = readdir $DIR)
> + {
> + next if $file eq q{.} || $file eq q{..};
> + my $nextdir = $top eq q{.} ? $file : "$top/$file";
> + push @results, __dir_walk($nextdir, $filefunc, $dirfunc);
> + }
> +
> + return $dirfunc ? $dirfunc->($top, @results) : ();
> + }
> + else
> + {
> + return $filefunc ? $filefunc->($top) : ();
> + }
> +}
> +
> +sub _fork_and_launch_server
> +{
> + my $self = shift;
> +
> + pipe FROM_CHILD, TO_PARENT or croak 'Cannot create pipe!';
> + TO_PARENT->autoflush();
> +
> + my $pid = fork;
> + if ($pid < 0)
> + {
> + carp 'Cannot fork';
> + }
> + elsif ($pid == 0)
> + {
> +
> + # child
> + close FROM_CHILD or carp $ERRNO;
> +
> + # FTP Server has to start with english locale due to use of
> strftime month names in LIST command
> + setlocale(LC_ALL, 'C');
> + $self->_launch_server(
> + sub {
> + print {*TO_PARENT} "SYNC\n";
> + close TO_PARENT or carp $ERRNO;
> + }
> + );
> + }
> + else
> + {
> + # father
> + close TO_PARENT or carp $ERRNO;
> + chomp(my $line = <FROM_CHILD>);
> + close FROM_CHILD or carp $ERRNO;
> + }
> +
> + return $pid;
> +}
> +
> +1;
> +
> +# vim: et ts=4 sw=4
> diff --git a/tests/WgetTests.pm b/tests/WgetTests.pm
> deleted file mode 100644
> index b3d4bc6..0000000
> --- a/tests/WgetTests.pm
> +++ /dev/null
> @@ -1,334 +0,0 @@
> -package WgetTest;
> -$VERSION = 0.01;
> -
> -use strict;
> -use warnings;
> -
> -use Cwd;
> -use File::Path;
> -use POSIX qw(locale_h);
> -use locale;
> -
> -our $WGETPATH = "../src/wget";
> -
> -my @unexpected_downloads = ();
> -
> -{
> - my %_attr_data = ( # DEFAULT
> - _cmdline => "",
> - _workdir => Cwd::getcwd(),
> - _errcode => 0,
> - _existing => {},
> - _input => {},
> - _name => $0,
> - _output => {},
> - _server_behavior => {},
> - );
> -
> - sub _default_for
> - {
> - my ($self, $attr) = @_;
> - $_attr_data{$attr};
> - }
> -
> - sub _standard_keys
> - {
> - keys %_attr_data;
> - }
> -}
> -
> -
> -sub new {
> - my ($caller, %args) = @_;
> - my $caller_is_obj = ref($caller);
> - my $class = $caller_is_obj || $caller;
> - #print STDERR "class = ", $class, "\n";
> - #print STDERR "_attr_data {workdir} = ",
> $WgetTest::_attr_data{_workdir}, "\n";
> - my $self = bless {}, $class;
> - foreach my $attrname ($self->_standard_keys()) {
> - #print STDERR "attrname = ", $attrname, " value = ";
> - my ($argname) = ($attrname =~ /^_(.*)/);
> - if (exists $args{$argname}) {
> - #printf STDERR "Setting up $attrname\n";
> - $self->{$attrname} = $args{$argname};
> - } elsif ($caller_is_obj) {
> - #printf STDERR "Copying $attrname\n";
> - $self->{$attrname} = $caller->{$attrname};
> - } else {
> - #printf STDERR "Using default for $attrname\n";
> - $self->{$attrname} = $self->_default_for($attrname);
> - }
> - #print STDERR $attrname, '=', $self->{$attrname}, "\n";
> - }
> - #printf STDERR "_workdir default = ", $self->_default_for("_workdir");
> - return $self;
> -}
> -
> -
> -sub run {
> - my $self = shift;
> - my $result_message = "Test successful.\n";
> - my $errcode;
> -
> - $self->{_name} =~ s{.*/}{}; # remove path
> - $self->{_name} =~ s{\.[^.]+$}{}; # remove extension
> - printf "Running test $self->{_name}\n";
> -
> - # Setup
> - my $new_result = $self->_setup();
> - chdir ("$self->{_workdir}/$self->{_name}/input");
> - if (defined $new_result) {
> - $result_message = $new_result;
> - $errcode = 1;
> - goto cleanup;
> - }
> -
> - # Launch server
> - my $pid = $self->_fork_and_launch_server();
> -
> - # Call wget
> - chdir ("$self->{_workdir}/$self->{_name}/output");
> -
> - my $cmdline = $self->{_cmdline};
> - $cmdline = $self->_substitute_port($cmdline);
> - $cmdline = ($cmdline =~ m{^/.*}) ? $cmdline :
> "$self->{_workdir}/$cmdline";
> -
> - my $valgrind = $ENV{VALGRIND_TESTS};
> - if (!defined $valgrind || $valgrind == "" || $valgrind == "0") {
> - # Valgrind not requested - leave $cmdline as it is
> - } elsif ($valgrind == "1") {
> - $cmdline = "valgrind --error-exitcode=301 --leak-check=yes
> --track-origins=yes " . $cmdline;
> - } else {
> - $cmdline = $valgrind . " " . $cmdline;
> - }
> -
> - print "Calling $cmdline\n";
> - $errcode = system($cmdline);
> - $errcode >>= 8; # XXX: should handle abnormal error codes.
> -
> - # Shutdown server
> - # if we didn't explicitely kill the server, we would have to call
> - # waitpid ($pid, 0) here in order to wait for the child process to
> - # terminate
> - kill ('TERM', $pid);
> -
> - # Verify download
> - unless ($errcode == $self->{_errcode}) {
> - $result_message = "Test failed: wrong code returned (was:
> $errcode, expected: $self->{_errcode})\n";
> - goto cleanup;
> - }
> - my $error_str;
> - if ($error_str = $self->_verify_download()) {
> - $result_message = $error_str;
> - }
> -
> - cleanup:
> - $self->_cleanup();
> -
> - print $result_message;
> - return $errcode != $self->{_errcode} || ($error_str ? 1 : 0);
> -}
> -
> -
> -sub _setup {
> - my $self = shift;
> -
> - #print $self->{_name}, "\n";
> - chdir ($self->{_workdir});
> -
> - # Create temporary directory
> - mkdir ($self->{_name});
> - chdir ($self->{_name});
> - mkdir ("input");
> - mkdir ("output");
> -
> - # Setup existing files
> - chdir ("output");
> - foreach my $filename (keys %{$self->{_existing}}) {
> - open (FILE, ">$filename")
> - or return "Test failed: cannot open pre-existing file
> $filename\n";
> -
> - my $file = $self->{_existing}->{$filename};
> - print FILE $file->{content}
> - or return "Test failed: cannot write pre-existing file
> $filename\n";
> -
> - close (FILE);
> -
> - if (exists($file->{timestamp})) {
> - utime $file->{timestamp}, $file->{timestamp}, $filename
> - or return "Test failed: cannot set timestamp on
> pre-existing file $filename\n";
> - }
> - }
> -
> - chdir ("../input");
> - $self->_setup_server();
> -
> - chdir ($self->{_workdir});
> - return;
> -}
> -
> -
> -sub _cleanup {
> - my $self = shift;
> -
> - chdir ($self->{_workdir});
> - 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;
> -
> - chdir ("$self->{_workdir}/$self->{_name}/output");
> -
> - # use slurp mode to read file content
> - my $old_input_record_separator = $/;
> - undef $/;
> -
> - while (my ($filename, $filedata) = each %{$self->{_output}}) {
> - open (FILE, $filename)
> - or return "Test failed: file $filename not downloaded\n";
> -
> - my $content = <FILE>;
> - my $expected_content = $filedata->{'content'};
> - $expected_content = $self->_substitute_port($expected_content);
> - unless ($content eq $expected_content) {
> - 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,
> - $atime, $mtime, $ctime, $blksize, $blocks) = stat FILE;
> -
> - $mtime == $filedata->{'timestamp'}
> - or return "Test failed: wrong timestamp for file
> $filename\n";
> - }
> -
> - close (FILE);
> - }
> -
> - $/ = $old_input_record_separator;
> -
> - # make sure no unexpected files were downloaded
> - chdir ("$self->{_workdir}/$self->{_name}/output");
> -
> - __dir_walk('.',
> - sub { push @unexpected_downloads,
> - $_[0] unless (exists $self->{_output}{$_[0]} ||
> $self->{_existing}{$_[0]}) },
> - sub { shift; return @_ } );
> - if (@unexpected_downloads) {
> - return "Test failed: unexpected downloaded files [" . join(', ',
> @unexpected_downloads) . "]\n";
> - }
> -
> - return "";
> -}
> -
> -
> -sub __dir_walk {
> - my ($top, $filefunc, $dirfunc) = @_;
> -
> - my $DIR;
> -
> - if (-d $top) {
> - my $file;
> - unless (opendir $DIR, $top) {
> - warn "Couldn't open directory $DIR: $!; skipping.\n";
> - return;
> - }
> -
> - my @results;
> - while ($file = readdir $DIR) {
> - next if $file eq '.' || $file eq '..';
> - my $nextdir = $top eq '.' ? $file : "$top/$file";
> - push @results, __dir_walk($nextdir, $filefunc, $dirfunc);
> - }
> -
> - return $dirfunc ? $dirfunc->($top, @results) : () ;
> - } else {
> - return $filefunc ? $filefunc->($top) : () ;
> - }
> -}
> -
> -
> -sub _fork_and_launch_server
> -{
> - my $self = shift;
> -
> - pipe(FROM_CHILD, TO_PARENT) or die "Cannot create pipe!";
> - select((select(TO_PARENT), $| = 1)[0]);
> -
> - my $pid = fork();
> - if ($pid < 0) {
> - die "Cannot fork";
> - } elsif ($pid == 0) {
> - # child
> - close FROM_CHILD;
> - # FTP Server has to start with english locale due to use of
> strftime month names in LIST command
> - setlocale(LC_ALL,"C");
> - $self->_launch_server(sub { print TO_PARENT "SYNC\n"; close
> TO_PARENT });
> - } else {
> - # father
> - close TO_PARENT;
> - chomp(my $line = <FROM_CHILD>);
> - close FROM_CHILD;
> - }
> -
> - return $pid;
> -}
> -
> -1;
> -
> -# vim: et ts=4 sw=4
> --
> 2.0.4
>
>