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).
> In my opinion, the two test suites should be kept separate, atleast for the
> time being while the new test suite is completed.
I agree. To keep it clean we shouldn't mix python and perl tests.
Thanks for your feedback, Darshit.
Tim
On Thursday 25 September 2014 14:53:44 Darshit Shah wrote:
> On Wed, Sep 24, 2014 at 04:45:59PM +0200, Tim Ruehsen wrote:
> > Hi,
> >
> > here is a first patch to enable the parallel test harness for the perl
> > tests.
> >
> > Please test and comment - i admit I have no older auto* environment to
> > test.
> Looks good! I have only the latest autotools for testing the patch, but I
> don't think this patch should create many issues. Of course, this feature
> was added only in autotools 1.11 I guess, so anything before that
> ./configure will fail. But since we've already used this feature in the
> Python based test suite, I don't think it's a problem any more.
>
> I ran the patch on both, master and parallel-wget without any errors.
>
> One thing this patch does is speed up the Perl-based test suite by a large
> extent and I'm really glad about it.
>
> > If you like it, we could get rid of tests/run-px (not used any more in my
> > patch). Also, we could easily merge the python test suite into the tests/
> > directory.
>
> Yes, I agree we can eliminate run-px completely. I don't see a use for that
> script anymore since you've integrated the tests to use the autotools
> harness.
>
> I'm not too sure about merging the Python tests into the tests/ directory.
> It would fix up the test and supporting files. The Python based tests
> require someone to volunteer to port the tests too. All the HTTP features
> are ready, only the tests are missing. FTP support is woefully lacking
> however and also the support for spawning multiple HTTP Servers for the
> parallel-wget branch's tests.
>
> In my opinion, the two test suites should be kept separate, atleast for the
> time being while the new test suite is completed.
>
> > Tim
From 815c98931203b0385639700455ae4bf825fa4a8b 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/Makefile.am | 34 ++-- tests/Test-proxied-https-auth.px | 10 +- tests/WgetTest.pm | 328 +++++++++++++++++++++++++++++++++++++++ tests/WgetTest.pm.in | 323 -------------------------------------- 8 files changed, 363 insertions(+), 348 deletions(-) create mode 100644 tests/WgetTest.pm delete mode 100644 tests/WgetTest.pm.in 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/Makefile.am b/tests/Makefile.am index 4bd3ebf..f283cc5 100644 --- a/tests/Makefile.am +++ b/tests/Makefile.am @@ -27,40 +27,25 @@ # 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) # Make libunittest "PHONY" so we're always sure we're up-to-date. -.PHONY: ../src/libunittest.a +.PHONY: ../src/libunittest.a WgetTest.pm ../src/libunittest.a: cd ../src && $(MAKE) $(AM_MAKEFLAGS) libunittest.a ../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..45017d0 100755 --- a/tests/Test-proxied-https-auth.px +++ b/tests/Test-proxied-https-auth.px @@ -8,12 +8,16 @@ use WgetTest; # 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/WgetTest.pm b/tests/WgetTest.pm new file mode 100644 index 0000000..987c317 --- /dev/null +++ b/tests/WgetTest.pm @@ -0,0 +1,328 @@ +# 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; +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 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 -- 2.1.1
signature.asc
Description: This is a digitally signed message part.
