X-Git-Url: http://www.privoxy.org/gitweb/?p=privoxy.git;a=blobdiff_plain;f=tools%2Fprivoxy-regression-test.pl;h=60e9d6979c2554961175e366c56cb46665fd9aa5;hp=db5d7e4fda1738dbdd9aa6631715a48dd8928969;hb=04fdd49ca9ebcdffdaadc3274a118d199dbb9d02;hpb=4bbb02c79f2dbce0f0d6a37918f8eddeb0419e73

diff --git a/tools/privoxy-regression-test.pl b/tools/privoxy-regression-test.pl
index db5d7e4f..60e9d697 100755
--- a/tools/privoxy-regression-test.pl
+++ b/tools/privoxy-regression-test.pl
@@ -7,7 +7,7 @@
 # A regression test "framework" for Privoxy. For documentation see:
 # perldoc privoxy-regression-test.pl
 #
-# $Id: privoxy-regression-test.pl,v 1.78 2011/10/30 16:20:35 fabiankeil Exp $
+# $Id: privoxy-regression-test.pl,v 1.83 2013/01/06 18:14:17 fabiankeil Exp $
 #
 # Wish list:
 #
@@ -40,7 +40,7 @@ use strict;
 use Getopt::Long;
 
 use constant {
-    PRT_VERSION => 'Privoxy-Regression-Test 0.4',
+    PRT_VERSION => 'Privoxy-Regression-Test 0.5',
  
     CURL => 'curl',
 
@@ -311,6 +311,7 @@ sub load_regression_tests_through_privoxy () {
     my $curl_url = '';
     my $file_number = 0;
     my $feature;
+    my $privoxy_version = '(Unknown version!)';
 
     $curl_url .= $privoxy_cgi_url;
     $curl_url .= 'show-status';
@@ -342,10 +343,14 @@ sub load_regression_tests_through_privoxy () {
 
             $privoxy_features{$feature} = $1 if defined $feature;
             $feature = undef;
+
+        } elsif (m@This is <a href="http://www.privoxy.org/">Privoxy</a> (\d+\.\d+\.\d+) on@) {
+            $privoxy_version = $1;
         }
     }
 
-    l(LL_FILE_LOADING, "Recognized " . @actionfiles . " actions files");
+    l(LL_STATUS, "Gathering regression tests from " .
+      @actionfiles . " action file(s) delivered by Privoxy $privoxy_version.");
 
     load_action_files(\@actionfiles);
 }
@@ -491,9 +496,6 @@ sub load_action_files ($) {
 
     my $ignored = 0;
 
-    l(LL_STATUS, "Gathering regression tests from " .
-      @actionfiles . " action file(s) delivered by Privoxy.");
-
     for my $file_number (0 .. @actionfiles - 1) {
 
         my $curl_url = quote($actionfiles[$file_number]);
@@ -639,6 +641,16 @@ sub load_action_files ($) {
 #
 ############################################################################
 
+# Fisher Yates shuffle from Perl's "How do I shuffle an array randomly?" FAQ
+sub fisher_yates_shuffle ($) {
+    my $deck = shift;
+    my $i = @$deck;
+    while ($i--) {
+        my $j = int rand($i+1);
+        @$deck[$i,$j] = @$deck[$j,$i];
+    }
+}
+
 sub execute_regression_tests () {
 
     our @regression_tests;
@@ -662,14 +674,30 @@ sub execute_regression_tests () {
         my $failures;
         my $skipped = 0;
 
+        if (cli_option_is_set('shuffle-tests')) {
+
+            # Shuffle both the test sections and
+            # the tests they contain.
+            #
+            # XXX: With the current data layout, shuffling tests
+            #      from different sections isn't possible.
+            #      Is this worth changing the layout?
+            fisher_yates_shuffle(\@regression_tests);
+            for (my $s = 0;  $s < @regression_tests; $s++) {
+                fisher_yates_shuffle($regression_tests[$s]);
+            }
+        }
+
         for (my $s = 0;  $s < @regression_tests; $s++) {
 
             my $r = 0;
 
             while (defined $regression_tests[$s][$r]) {
 
-                die "Section id mismatch" if ($s != $regression_tests[$s][$r]{'section-id'});
-                die "Regression test id mismatch" if ($r != $regression_tests[$s][$r]{'regression-test-id'});
+                unless (cli_option_is_set('shuffle-tests')) {
+                    die "Section id mismatch" if ($s != $regression_tests[$s][$r]{'section-id'});
+                    die "Regression test id mismatch" if ($r != $regression_tests[$s][$r]{'regression-test-id'});
+                }
                 die "Internal error. Test executor missing."
                     unless defined $regression_tests[$s][$r]{executor};
 
@@ -1476,7 +1504,7 @@ sub log_message ($) {
         $message = $time_stamp . ": " . $message;
     }
 
-    printf(STDERR "%s\n", $message);
+    printf("%s\n", $message);
 }
 
 sub log_result ($$) {
@@ -1572,7 +1600,7 @@ sub quote ($) {
 }
 
 sub print_version () {
-    printf PRT_VERSION . "\n" . 'Copyright (C) 2007-2011 Fabian Keil <fk@fabiankeil.de>' . "\n";
+    printf PRT_VERSION . "\n";
 }
 
 sub list_test_types () {
@@ -1617,6 +1645,7 @@ Options and their default values if they have any:
     [--privoxy-address]
     [--retries $cli_options{'retries'}]
     [--show-skipped-tests]
+    [--shuffle-tests]
     [--sleep-time $cli_options{'sleep-time'}]
     [--test-number]
     [--verbose]
@@ -1672,6 +1701,7 @@ sub parse_cli_options () {
         'min-level=i'        => \$cli_options{'min-level'},
         'privoxy-address=s'  => \$cli_options{'privoxy-address'},
         'retries=i'          => \$cli_options{'retries'},
+        'shuffle-tests'      => \$cli_options{'shuffle-tests'},
         'show-skipped-tests' => \$cli_options{'show-skipped-tests'},
         'sleep-time=i'       => \$cli_options{'sleep-time'},
         'test-number=i'      => \$cli_options{'test-number'},
@@ -1922,6 +1952,11 @@ number.
 
 B<--show-skipped-tests> Log skipped tests even if verbose mode is off.
 
+B<--shuffle-tests> Shuffle test sections and their tests before
+executing them. When combined with B<--forks>, this can increase
+the chances of detecting race conditions. Of course some problems
+are easier to detect without this option.
+
 B<--sleep-time seconds> Wait B<seconds> between tests. Useful when
 debugging issues with systems that don't log with millisecond precision.