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 <feino...@gmail.com>: > From: Pär Karlsson <feino...@gmail.com> > > --- > 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 <feino...@gmail.com> > + * 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 <vap...@gentoo.org> > > * 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 > >