On Thursday 25 September 2014 15:38:49 Darshit Shah wrote: > On Thu, Sep 25, 2014 at 11:40:57AM +0200, Tim Ruehsen wrote: > > Hi, > > > > here is patch version #2. > > > > - fixed some little scratches > > - got rid of WgetTest.pm.in (WgetTest.pm now reads $top_srcdir from ENV). > > - got rid of run-px > > > > With these changes you can make use of TESTS_ENVIRONMENT variable, e.g. > > > > TESTS_ENVIRONMENT="LC_ALL=tr_TR.utf8" make check -j4 > > > > To run the tests with a turkish locale. > > ;-) Some tests break, but I am up to fix a few (e.g. the perl FTP server > > has a locale issue which I already fixed - patch comes today). > > Hi Tim, > > A couple of points about this patch. The patch now puts the WgetTest.pm file > under version control. Everyone who already has a development environment > for Wget already setup will not be able to apply this patch without manual > intervention. > > Instead, I suggest that we rename WgetTest.pm to something else so that the > conflict does not arise. It could be called WgetTests.pm for example.
I wasn't aware of that. I'll rename WgetTest.pm to WgetTests.pm as you
suggest.
> The WgetTest.pm file included in this patch contains the old Warning for an
> autogenerated file. Maybe we should remove that one since the file is no
> longer being autogenerated.
I agree.
> Do you think having the tests being run in a different locale is necessary?
Yes - definitely. There are Wget bugs that come out only when running the
tests with a different locale than C. The test suite should be fixed so that
it works for any non-developer who downloads the source, compiles and tests it
(make check). These people want to know that Wget correctly works on their
system which also includes their current locale. But this at a later time.
Right now, by default the tests run with LC_ALL=C. This can only be changed by
setting TESTS_ENVIRONMENT. So for the moment, nothing changes for anybody by
default. Though developers now have the possibility to use TESTS_ENVIRONMENT
which doesn't work for the old serial test suite.
At least here, I still get english messages from the test suite, even with
TESTS_ENVIRONMENT="LC_ALL=tr_TR.utf8" make check -j4
(is it LC_MESSAGES still being en_US.UTF-8 ? have to make some tests...)
Of course, should the test suite messages be english - that is what people
send to the developers.
patch version #3 is attached
TimFrom e64cb80beb0e9c39552da3c3c295598ce1d32cc9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Tim Rühsen?= <[email protected]> Date: Wed, 24 Sep 2014 16:40:03 +0200 Subject: [PATCH] Switched to parallel test harness --- .gitignore | 1 - ChangeLog | 5 + configure.ac | 2 +- tests/ChangeLog | 8 + tests/FTPTest.pm | 2 +- tests/HTTPTest.pm | 2 +- tests/Makefile.am | 32 ++-- tests/Test-proxied-https-auth.px | 12 +- tests/WgetFeature.pm | 2 +- tests/WgetTest.pm.in | 323 -------------------------------------- tests/WgetTests.pm | 324 +++++++++++++++++++++++++++++++++++++++ 11 files changed, 362 insertions(+), 351 deletions(-) delete mode 100644 tests/WgetTest.pm.in create mode 100644 tests/WgetTests.pm diff --git a/.gitignore b/.gitignore index 2b3c596..3a9b9ce 100644 --- a/.gitignore +++ b/.gitignore @@ -81,7 +81,6 @@ testenv/Makefile.in # tests/ tests/Makefile tests/Makefile.in -tests/WgetTest.pm tests/unit-tests # util/ util/Makefile diff --git a/ChangeLog b/ChangeLog index 8b693be..f9507d7 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2014-09-25 Tim Ruehsen <[email protected]> + + * configure.ac: removed WgetTest.pm.in + * .gitignore: removed WgetTest.pm + 2014-07-25 Darshit Shah <[email protected]> * .gitignore: Add a gitignore file for the project. diff --git a/configure.ac b/configure.ac index 273fc64..3cbe618 100644 --- a/configure.ac +++ b/configure.ac @@ -578,7 +578,7 @@ dnl dnl Create output dnl AC_CONFIG_FILES([Makefile src/Makefile doc/Makefile util/Makefile - po/Makefile.in tests/Makefile tests/WgetTest.pm + po/Makefile.in tests/Makefile lib/Makefile testenv/Makefile]) AC_CONFIG_HEADERS([src/config.h]) AC_OUTPUT diff --git a/tests/ChangeLog b/tests/ChangeLog index d957b57..8b3b2e5 100644 --- a/tests/ChangeLog +++ b/tests/ChangeLog @@ -1,3 +1,11 @@ +2014-09-25 Tim Ruehsen <[email protected]> + + * Makefile.am: Modified to use parallel test harness + * Test-proxied-https-auth.px: get $top_srcdir from ENV + * run-px: removed + * WgetTest.pm.in: removed + * WgetTest.pm: get $top_srcdir from ENV + 2014-06-11 Giuseppe Scrivano <[email protected]> * Makefile.am: Remove @VAR@ with $FOO. diff --git a/tests/FTPTest.pm b/tests/FTPTest.pm index f1412fa..98fc061 100644 --- a/tests/FTPTest.pm +++ b/tests/FTPTest.pm @@ -4,7 +4,7 @@ use strict; use warnings; use FTPServer; -use WgetTest; +use WgetTests; our @ISA = qw(WgetTest); my $VERSION = 0.01; diff --git a/tests/HTTPTest.pm b/tests/HTTPTest.pm index 04213b2..e0e436f 100644 --- a/tests/HTTPTest.pm +++ b/tests/HTTPTest.pm @@ -4,7 +4,7 @@ use strict; use warnings; use HTTPServer; -use WgetTest; +use WgetTests; our @ISA = qw(WgetTest); my $VERSION = 0.01; diff --git a/tests/Makefile.am b/tests/Makefile.am index 4bd3ebf..ecb7001 100644 --- a/tests/Makefile.am +++ b/tests/Makefile.am @@ -27,20 +27,12 @@ # shall include the source code for the parts of OpenSSL used as well # as that of the covered work. +# see http://www.gnu.org/software/automake/manual/html_node/Parallel-Test-Harness.html#Parallel-Test-Harness + # # Version: $(VERSION) # -PERL = perl -PERLRUN = $(PERL) -I$(srcdir) - -LIBS += $(LIBICONV) $(LIBINTL) $(LIB_CLOCK_GETTIME) - -.PHONY: test run-unit-tests run-px-tests - -check-local: test - -test: ../src/wget$(EXEEXT) run-unit-tests run-px-tests ../src/wget$(EXEEXT): cd ../src && $(MAKE) $(AM_MAKEFLAGS) @@ -53,14 +45,7 @@ test: ../src/wget$(EXEEXT) run-unit-tests run-px-tests ../lib/libgnu.a: cd ../lib && $(MAKE) $(AM_MAKEFLAGS) -run-unit-tests: unit-tests$(EXEEXT) ../src/libunittest.a - ./unit-tests$(EXEEXT) - -run-px-tests: WgetTest.pm ../src/wget$(EXEEXT) - $(srcdir)/run-px $(top_srcdir) - -EXTRA_DIST = FTPServer.pm FTPTest.pm HTTPServer.pm HTTPTest.pm \ - WgetFeature.pm WgetFeature.cfg \ +PX_TESTS = \ Test-auth-basic.px \ Test-auth-no-challenge.px \ Test-auth-no-challenge-url.px \ @@ -142,7 +127,10 @@ EXTRA_DIST = FTPServer.pm FTPTest.pm HTTPServer.pm HTTPTest.pm \ Test--start-pos.px \ Test--start-pos--continue.px \ Test--httpsonly-r.px \ - Test-204.px \ + Test-204.px + +EXTRA_DIST = FTPServer.pm FTPTest.pm HTTPServer.pm HTTPTest.pm \ + WgetFeature.pm WgetFeature.cfg $(PX_TESTS) \ run-px certs check_PROGRAMS = unit-tests @@ -150,3 +138,9 @@ unit_tests_SOURCES LDADD = ../src/libunittest.a ../lib/libgnu.a $(LIBS) CLEANFILES = *~ *.bak core core.[0-9]* + +TESTS = ./unit-tests$(EXEEXT) $(PX_TESTS) +TEST_EXTENSIONS = .pl +AM_TESTS_ENVIRONMENT = export top_srcdir=$(top_srcdir); export WGETRC=/dev/null; export SYSTEM_WGETRC=/dev/null; +PL_LOG_COMPILER = $(PERL) +AM_PL_LOG_FLAGS = -I$(top_srcdir) diff --git a/tests/Test-proxied-https-auth.px b/tests/Test-proxied-https-auth.px index 1de5357..347ea66 100755 --- a/tests/Test-proxied-https-auth.px +++ b/tests/Test-proxied-https-auth.px @@ -4,16 +4,20 @@ use strict; use warnings; use WgetFeature qw(https); -use WgetTest; # For $WGETPATH. +use WgetTests; # For $WGETPATH. my $cert_path; my $key_path; +my $top_srcdir; if (@ARGV) { - my $top_srcdir = shift @ARGV; - $key_path = "$top_srcdir/tests/certs/server-key.pem"; - $cert_path = "$top_srcdir/tests/certs/server-cert.pem"; + $top_srcdir = shift @ARGV; +} else { + $top_srcdir = $ENV{top_srcdir}; } +$key_path = "$top_srcdir/tests/certs/server-key.pem"; +$cert_path = "$top_srcdir/tests/certs/server-cert.pem"; + use HTTP::Daemon; use HTTP::Request; diff --git a/tests/WgetFeature.pm b/tests/WgetFeature.pm index f58b998..0762314 100644 --- a/tests/WgetFeature.pm +++ b/tests/WgetFeature.pm @@ -3,7 +3,7 @@ package WgetFeature; use strict; use warnings; -use WgetTest; +use WgetTests; our %skip_messages; require 'WgetFeature.cfg'; diff --git a/tests/WgetTest.pm.in b/tests/WgetTest.pm.in deleted file mode 100644 index 4151445..0000000 --- a/tests/WgetTest.pm.in +++ /dev/null @@ -1,323 +0,0 @@ -# WARNING! -# WgetTest.pm is a generated file! Do not edit! Edit WgetTest.pm.in -# instead. - -package WgetTest; -$VERSION = 0.01; - -use strict; -use warnings; - -use Cwd; -use File::Path; - -our $WGETPATH = "@abs_top_builddir@/src/wget"; - -my @unexpected_downloads = (); - -{ - my %_attr_data = ( # DEFAULT - _cmdline => "", - _workdir => Cwd::getcwd(), - _errcode => 0, - _existing => {}, - _input => {}, - _name => "", - _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; - - 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); - print "Calling $cmdline\n"; - $errcode - ($cmdline =~ m{^/.*}) - ? system ($cmdline) - : system ("$self->{_workdir}/../src/$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; - $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 diff --git a/tests/WgetTests.pm b/tests/WgetTests.pm new file mode 100644 index 0000000..607ccd7 --- /dev/null +++ b/tests/WgetTests.pm @@ -0,0 +1,324 @@ +package WgetTest; +$VERSION = 0.01; + +use strict; +use warnings; + +use Cwd; +use File::Path; +use POSIX qw(locale_h); +use locale; + +my $top_srcdir = $ENV{top_srcdir}; +our $WGETPATH = "$top_srcdir/src/wget"; + +my @unexpected_downloads = (); + +{ + my %_attr_data = ( # DEFAULT + _cmdline => "", + _workdir => Cwd::getcwd(), + _errcode => 0, + _existing => {}, + _input => {}, + _name => "", + _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; + + 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); + print "Calling $cmdline\n"; + $errcode + ($cmdline =~ m{^/.*}) + ? system ($cmdline) + : system ("$self->{_workdir}/../src/$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.1.1
signature.asc
Description: This is a digitally signed message part.
