diff --git a/tests/ChangeLog b/tests/ChangeLog index 5f37f634..5097871f 100644 --- a/tests/ChangeLog +++ b/tests/ChangeLog @@ -1,3 +1,12 @@ +2014-10-31 Pär Karlsson + * WgetTests.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 + 2014-10-30 Mike Frysinger * WgetFeature.pm: fix skip exit code to 77 diff --git a/tests/FTPServer.pm b/tests/FTPServer.pm index 1603caaa..3d7d8a58 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); + "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) { + 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}}) { + # 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}}) + { 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}, - }; + '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"; + 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,49 @@ 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 ($b =~ m.^/.) { - $a = ''; - $b =~ s.^/..; + if (!$path_b) + { + return $path_a; } - $a =~ s./$..; - my @components = split('/', $b); + if ($path_b =~ m.^/.) + { + $path_a = ''; + $path_b =~ s.^/..; + } + $path_a =~ s./$..; - foreach my $c (@components) { - if ($c =~ /^\.?$/) { + my @components = split m{/}msx, $path_b; + + 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 +824,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 +849,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 +894,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 +979,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 98fc061f..50385ad0 100644 --- a/tests/FTPTest.pm +++ b/tests/FTPTest.pm @@ -9,9 +9,8 @@ use WgetTests; 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 adadb457..aacc460c 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 e0e436f5..00f079f8 100644 --- a/tests/HTTPTest.pm +++ b/tests/HTTPTest.pm @@ -9,9 +9,8 @@ use WgetTests; 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/WgetFeature.pm b/tests/WgetFeature.pm index 118e79c4..880a2386 100644 --- a/tests/WgetFeature.pm +++ b/tests/WgetFeature.pm @@ -3,26 +3,41 @@ package WgetFeature; use strict; use warnings; +our $VERSION = 0.01; + +use Carp; +use English qw(-no_match_vars); use WgetTests; -our %skip_messages; -require 'WgetFeature.cfg'; +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/WgetTests.pm b/tests/WgetTests.pm index b3d4bc67..889a65bb 100644 --- a/tests/WgetTests.pm +++ b/tests/WgetTests.pm @@ -1,85 +1,103 @@ package WgetTest; -$VERSION = 0.01; 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"; +our $WGETPATH = '../src/wget'; my @unexpected_downloads = (); { - my %_attr_data = ( # DEFAULT - _cmdline => "", - _workdir => Cwd::getcwd(), - _errcode => 0, - _existing => {}, - _input => {}, - _name => $0, - _output => {}, - _server_behavior => {}, - ); + 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) = @_; - $_attr_data{$attr}; + return $_attr_data{$attr}; } sub _standard_keys { - keys %_attr_data; + return keys %_attr_data; } } - -sub new { +sub new +{ my ($caller, %args) = @_; - my $caller_is_obj = ref($caller); + 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()) { + for my $attrname ($self->_standard_keys()) + { + #print STDERR "attrname = ", $attrname, " value = "; - my ($argname) = ($attrname =~ /^_(.*)/); - if (exists $args{$argname}) { + my ($argname) = ($attrname =~ m/^_(.*)/msx); + if (exists $args{$argname}) + { + #printf STDERR "Setting up $attrname\n"; $self->{$attrname} = $args{$argname}; - } elsif ($caller_is_obj) { + } + elsif ($caller_is_obj) + { + #printf STDERR "Copying $attrname\n"; $self->{$attrname} = $caller->{$attrname}; - } else { + } + 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; +sub run +{ + my $self = shift; my $result_message = "Test successful.\n"; my $errcode; - $self->{_name} =~ s{.*/}{}; # remove path - $self->{_name} =~ s{\.[^.]+$}{}; # remove extension + $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"); - if (defined $new_result) { + 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; + $errcode = 1; goto cleanup; } @@ -87,140 +105,175 @@ sub run { my $pid = $self->_fork_and_launch_server(); # Call wget - chdir ("$self->{_workdir}/$self->{_name}/output"); + 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{^/.*}) ? $cmdline : "$self->{_workdir}/$cmdline"; + $cmdline = + ($cmdline =~ m{^/.*}msx) ? $cmdline : "$self->{_workdir}/$cmdline"; my $valgrind = $ENV{VALGRIND_TESTS}; - if (!defined $valgrind || $valgrind == "" || $valgrind == "0") { + 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; + } + 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. + $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); + kill 'TERM', $pid; # Verify download - unless ($errcode == $self->{_errcode}) { - $result_message = "Test failed: wrong code returned (was: $errcode, expected: $self->{_errcode})\n"; - goto cleanup; + 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()) { + if ($error_str = $self->_verify_download()) + { $result_message = $error_str; } - cleanup: + CLEANUP: $self->_cleanup(); print $result_message; return $errcode != $self->{_errcode} || ($error_str ? 1 : 0); } - -sub _setup { +sub _setup +{ my $self = shift; - #print $self->{_name}, "\n"; - chdir ($self->{_workdir}); + chdir $self->{_workdir} + or carp "Could not chdir into $self->{_workdir}: $ERRNO"; # Create temporary directory - mkdir ($self->{_name}); - chdir ($self->{_name}); - mkdir ("input"); - mkdir ("output"); + 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"); - foreach my $filename (keys %{$self->{_existing}}) { - open (FILE, ">$filename") - or return "Test failed: cannot open pre-existing file $filename\n"; + 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 FILE $file->{content} - or return "Test failed: cannot write pre-existing file $filename\n"; + print {$fh} $file->{content} + or return "Test failed: cannot write pre-existing file $filename\n"; - close (FILE); + close $fh or carp $ERRNO; - if (exists($file->{timestamp})) { + if (exists($file->{timestamp})) + { utime $file->{timestamp}, $file->{timestamp}, $filename - or return "Test failed: cannot set timestamp on pre-existing file $filename\n"; + or return + "Test failed: cannot set timestamp on pre-existing file $filename\n"; } } - chdir ("../input"); + chdir '../input' or carp "Cannot chdir into '../input': $ERRNO"; $self->_setup_server(); - chdir ($self->{_workdir}); + chdir $self->{_workdir} + or carp "Cannot chdir into '$self->{_workdir}': $ERRNO"; return; } - -sub _cleanup { +sub _cleanup +{ my $self = shift; - chdir ($self->{_workdir}); - File::Path::rmtree ($self->{_name}) unless $ENV{WGET_TEST_NO_CLEANUP}; + 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 '\\' . qw(a b t n v f r)[$c - 0x7]; - } else { - return sprintf('\\x%02x', $c); +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 { +sub _show_diff +{ + my ($expected, $actual) = @_; my $SNIPPET_SIZE = 10; - my ($expected, $actual) = @_; - - my $str = ''; + my $str = q{}; my $explen = length $expected; my $actlen = length $actual; - if ($explen != $actlen) { + if ($explen != $actlen) + { $str .= "Sizes don't match: expected = $explen, actual = $actlen\n"; } - my $min = $explen <= $actlen? $explen : $actlen; + my $min = $explen <= $actlen ? $explen : $actlen; my $line = 1; - my $col = 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') { + + # 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 { + } + else + { $col++; } } my $snip_start = $i - ($SNIPPET_SIZE / 2); - if ($snip_start < 0) { - $SNIPPET_SIZE += $snip_start; # Take it from the end. + 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; + 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"; @@ -228,102 +281,138 @@ sub _show_diff { return $str; } -sub _verify_download { +sub _verify_download +{ my $self = shift; - chdir ("$self->{_workdir}/$self->{_name}/output"); + 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 = $/; - undef $/; + my $old_input_record_separator = $INPUT_RECORD_SEPARATOR; + local $INPUT_RECORD_SEPARATOR = undef; - while (my ($filename, $filedata) = each %{$self->{_output}}) { - open (FILE, $filename) - or return "Test failed: file $filename not downloaded\n"; + 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 $content = ; my $expected_content = $filedata->{'content'}; $expected_content = $self->_substitute_port($expected_content); - unless ($content eq $expected_content) { + if ($content ne $expected_content) + { return "Test failed: wrong content for file $filename\n" - . _show_diff($expected_content, $content); + . _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; + 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"; + or return "Test failed: wrong timestamp for file $filename\n"; } - close (FILE); } - $/ = $old_input_record_separator; + local $INPUT_RECORD_SEPARATOR = $old_input_record_separator; # make sure no unexpected files were downloaded - chdir ("$self->{_workdir}/$self->{_name}/output"); + chdir "$self->{_workdir}/$self->{_name}/output" + or carp "Could not change into output directory: $ERRNO"; - __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"; + __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 ""; + return q{}; } - -sub __dir_walk { +sub __dir_walk +{ my ($top, $filefunc, $dirfunc) = @_; my $DIR; - if (-d $top) { + if (-d $top) + { my $file; - unless (opendir $DIR, $top) { - warn "Couldn't open directory $DIR: $!; skipping.\n"; + if (!opendir $DIR, $top) + { + warn "Couldn't open directory $DIR: $ERRNO; skipping.\n"; return; } my @results; - while ($file = readdir $DIR) { - next if $file eq '.' || $file eq '..'; - my $nextdir = $top eq '.' ? $file : "$top/$file"; + 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) : () ; + 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]); + 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) + { - my $pid = fork(); - if ($pid < 0) { - die "Cannot fork"; - } elsif ($pid == 0) { # child - close FROM_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 }); - } else { + setlocale(LC_ALL, 'C'); + $self->_launch_server( + sub { + print {*TO_PARENT} "SYNC\n"; + close TO_PARENT or carp $ERRNO; + } + ); + } + else + { # father - close TO_PARENT; + close TO_PARENT or carp $ERRNO; chomp(my $line = ); - close FROM_CHILD; + close FROM_CHILD or carp $ERRNO; } return $pid;