tools/privoxy-regression-test.pl

   1 #!/usr/bin/perl
   2
   3 ############################################################################
   4 #
   5 # Privoxy-Regression-Test
   6 #
   7 # A regression test "framework" for Privoxy. For documentation see:
   8 # perldoc privoxy-regression-test.pl
   9 #
  10 # $Id: privoxy-regression-test.pl,v 1.81 2011/10/30 16:22:29 fabiankeil Exp $
  11 #
  12 # Wish list:
  13 #
  14 # - Update documentation
  15 # - Validate HTTP times.
  16 # - Implement a HTTP_VERSION directive or allow to
  17 #   specify whole request lines.
  18 # - Support filter regression tests.
  19 # - Document magic Expect Header values
  20 # - Internal fuzz support?
  21 #
  22 # Copyright (c) 2007-2011 Fabian Keil <fk@fabiankeil.de>
  23 #
  24 # Permission to use, copy, modify, and distribute this software for any
  25 # purpose with or without fee is hereby granted, provided that the above
  26 # copyright notice and this permission notice appear in all copies.
  27 #
  28 # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  29 # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  30 # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  31 # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  32 # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  33 # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  34 # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  35 #
  36 ############################################################################
  37
  38 use warnings;
  39 use strict;
  40 use Getopt::Long;
  41
  42 use constant {
  43     PRT_VERSION => 'Privoxy-Regression-Test 0.5',
  44
  45     CURL => 'curl',
  46
  47     # CLI option defaults
  48     CLI_RETRIES   => 1,
  49     CLI_LOOPS     => 1,
  50     CLI_MAX_TIME  => 5,
  51     CLI_MIN_LEVEL => 0,
  52     # XXX: why limit at all?
  53     CLI_MAX_LEVEL => 100,
  54     CLI_FORKS     => 0,
  55     CLI_SLEEP_TIME => 0,
  56
  57     PRIVOXY_CGI_URL  => 'http://p.p/',
  58     FELLATIO_URL     => 'http://127.0.0.1:8080/',
  59     LEADING_LOG_DATE => 1,
  60     LEADING_LOG_TIME => 1,
  61
  62     DEBUG_LEVEL_FILE_LOADING    => 0,
  63     DEBUG_LEVEL_PAGE_FETCHING   => 0,
  64     DEBUG_LEVEL_VERBOSE_FAILURE => 1,
  65     # XXX: Only partly implemented and mostly useless.
  66     DEBUG_LEVEL_VERBOSE_SUCCESS => 0,
  67     DEBUG_LEVEL_STATUS          => 1,
  68
  69     VERBOSE_TEST_DESCRIPTION    => 1,
  70
  71     # Internal use, don't modify
  72     # Available debug bits:
  73     LL_SOFT_ERROR       =>  1,
  74     LL_VERBOSE_FAILURE  =>  2,
  75     LL_PAGE_FETCHING    =>  4,
  76     LL_FILE_LOADING     =>  8,
  77     LL_VERBOSE_SUCCESS  => 16,
  78     LL_STATUS           => 32,
  79
  80     CLIENT_HEADER_TEST  =>  1,
  81     SERVER_HEADER_TEST  =>  2,
  82     DUMB_FETCH_TEST     =>  3,
  83     METHOD_TEST         =>  4,
  84     STICKY_ACTIONS_TEST =>  5,
  85     TRUSTED_CGI_REQUEST =>  6,
  86     BLOCK_TEST          =>  7,
  87     REDIRECT_TEST       =>108,
  88 };
  89
  90 sub init_our_variables () {
  91
  92     our $leading_log_time = LEADING_LOG_TIME;
  93     our $leading_log_date = LEADING_LOG_DATE;
  94     our $privoxy_cgi_url  = PRIVOXY_CGI_URL;
  95     our $verbose_test_description = VERBOSE_TEST_DESCRIPTION;
  96     our $log_level = get_default_log_level();
  97 }
  98
  99 sub get_default_log_level () {
 100
 101     my $log_level = 0;
 102
 103     $log_level |= LL_FILE_LOADING    if DEBUG_LEVEL_FILE_LOADING;
 104     $log_level |= LL_PAGE_FETCHING   if DEBUG_LEVEL_PAGE_FETCHING;
 105     $log_level |= LL_VERBOSE_FAILURE if DEBUG_LEVEL_VERBOSE_FAILURE;
 106     $log_level |= LL_VERBOSE_SUCCESS if DEBUG_LEVEL_VERBOSE_SUCCESS;
 107     $log_level |= LL_STATUS          if DEBUG_LEVEL_STATUS;
 108
 109     # This one is supposed to be always on.
 110     $log_level |= LL_SOFT_ERROR;
 111
 112     return $log_level;
 113 }
 114
 115 ############################################################################
 116 #
 117 # File loading functions
 118 #
 119 ############################################################################
 120
 121 sub parse_tag ($) {
 122
 123     my $tag = shift;
 124
 125     # Remove anchors
 126     $tag =~ s@[\$\^]@@g;
 127     # Unescape brackets and dots
 128     $tag =~ s@\\(?=[{}().+])@@g;
 129
 130     # log_message("Parsed tag: " . $tag);
 131
 132     check_for_forbidden_characters($tag);
 133
 134     return $tag;
 135 }
 136
 137 sub check_for_forbidden_characters ($) {
 138
 139     my $string = shift;
 140     my $allowed = '[-=\dA-Za-z~{}:./();\t ,+@"_%?&*^]';
 141
 142     unless ($string =~ m/^$allowed*$/o) {
 143         my $forbidden = $string;
 144         $forbidden =~ s@^$allowed*(.).*@$1@;
 145
 146         log_and_die("'" . $string . "' contains character '" . $forbidden. "' which is unacceptable.");
 147     }
 148 }
 149
 150 sub load_regression_tests() {
 151     if (cli_option_is_set('local-test-file')) {
 152         load_regression_tests_from_file(get_cli_option('local-test-file'));
 153     } else {
 154         load_regression_tests_through_privoxy();
 155     }
 156 }
 157
 158 # XXX: Contains a lot of code duplicated from load_action_files()
 159 #      that should be factored out.
 160 sub load_regression_tests_from_file ($) {
 161     my $action_file = shift;
 162
 163     # initialized here
 164     our %actions;
 165     our @regression_tests;
 166
 167     my $si = 0;  # Section index
 168     my $ri = -1; # Regression test index
 169     my $count = 0;
 170
 171     my $ignored = 0;
 172
 173     my $sticky_actions = undef;
 174
 175     l(LL_STATUS, "Gathering regression tests from local file " . $action_file);
 176
 177     open(my $ACTION_FILE, "<", $action_file)
 178         or log_and_die("Failed to open $action_file: $!");
 179
 180     while (<$ACTION_FILE>) {
 181
 182         my $no_checks = 0;
 183         chomp;
 184         my ($token, $value) = tokenize($_);
 185
 186         next unless defined $token;
 187
 188         # Load regression tests
 189
 190         if (token_starts_new_test($token)) {
 191
 192             # Beginning of new regression test.
 193             $ri++;
 194             $count++;
 195             enlist_new_test(\@regression_tests, $token, $value, $si, $ri, $count);
 196             $no_checks = 1; # Already validated by enlist_new_test().
 197         }
 198
 199         if ($token =~ /level\s+(\d+)/i) {
 200
 201             my $level = $1;
 202             register_dependency($level, $value);
 203         }
 204
 205         if ($token eq 'sticky actions') {
 206
 207             # Will be used by each following Sticky URL.
 208             $sticky_actions = $value;
 209             if ($sticky_actions =~ /{[^}]*\s/) {
 210                 log_and_die("'Sticky Actions' with whitespace inside the " .
 211                             "action parameters are currently unsupported.");
 212             }
 213         }
 214
 215         if ($si == -1 || $ri == -1) {
 216             # No beginning of a test detected yet,
 217             # so we don't care about any other test
 218             # attributes.
 219             next;
 220         }
 221
 222         if ($token eq 'expect header') {
 223
 224             l(LL_FILE_LOADING, "Detected expectation: " . $value);
 225             $regression_tests[$si][$ri]{'expect-header'} = $value;
 226
 227         } elsif ($token eq 'tag') {
 228
 229             next if ($ri == -1);
 230
 231             my $tag = parse_tag($value);
 232
 233             # We already checked in parse_tag() after filtering
 234             $no_checks = 1;
 235
 236             l(LL_FILE_LOADING, "Detected TAG: " . $tag);
 237
 238             # Save tag for all tests in this section
 239             do {
 240                 $regression_tests[$si][$ri]{'tag'} = $tag;
 241             } while ($ri-- > 0);
 242
 243             $si++;
 244             $ri = -1;
 245
 246         } elsif ($token eq 'ignore' && $value =~ /Yes/i) {
 247
 248             l(LL_FILE_LOADING, "Ignoring section: " . test_content_as_string($regression_tests[$si][$ri]));
 249             $regression_tests[$si][$ri]{'ignore'} = 1;
 250             $ignored++;
 251
 252         } elsif ($token eq 'expect status code') {
 253
 254             l(LL_FILE_LOADING, "Expecting status code: " . $value);
 255             $regression_tests[$si][$ri]{'expected-status-code'} = $value;
 256
 257         } elsif ($token eq 'level') { # XXX: stupid name
 258
 259             $value =~ s@(\d+).*@$1@;
 260             l(LL_FILE_LOADING, "Level: " . $value);
 261             $regression_tests[$si][$ri]{'level'} = $value;
 262
 263         } elsif ($token eq 'method') {
 264
 265             l(LL_FILE_LOADING, "Method: " . $value);
 266             $regression_tests[$si][$ri]{'method'} = $value;
 267
 268         } elsif ($token eq 'redirect destination') {
 269
 270             l(LL_FILE_LOADING, "Redirect destination: " . $value);
 271             $regression_tests[$si][$ri]{'redirect destination'} = $value;
 272
 273         } elsif ($token eq 'url') {
 274
 275             if (defined $sticky_actions) {
 276                 die "WTF? Attempted to overwrite Sticky Actions"
 277                     if defined ($regression_tests[$si][$ri]{'sticky-actions'});
 278
 279                 l(LL_FILE_LOADING, "Sticky actions: " . $sticky_actions);
 280                 $regression_tests[$si][$ri]{'sticky-actions'} = $sticky_actions;
 281             } else {
 282                 log_and_die("Sticky URL without Sticky Actions: $value");
 283             }
 284
 285         } else {
 286
 287             # We don't use it, so we don't need
 288             $no_checks = 1;
 289             l(LL_STATUS, "Enabling no_checks for $token") unless $no_checks;
 290         }
 291
 292         # XXX: Necessary?
 293         unless ($no_checks)  {
 294             check_for_forbidden_characters($value);
 295             check_for_forbidden_characters($token);
 296         }
 297     }
 298
 299     l(LL_FILE_LOADING, "Done loading " . $count . " regression tests."
 300       . " Of which " . $ignored. " will be ignored)\n");
 301
 302 }
 303
 304
 305 sub load_regression_tests_through_privoxy () {
 306
 307     our $privoxy_cgi_url;
 308     our @privoxy_config;
 309     our %privoxy_features;
 310     my @actionfiles;
 311     my $curl_url = '';
 312     my $file_number = 0;
 313     my $feature;
 314
 315     $curl_url .= $privoxy_cgi_url;
 316     $curl_url .= 'show-status';
 317
 318     l(LL_STATUS, "Asking Privoxy for the number of action files available ...");
 319
 320     # Dear Privoxy, please reload the config file if necessary ...
 321     get_cgi_page_or_else($curl_url);
 322
 323     # ... so we get the latest one here.
 324     foreach (@{get_cgi_page_or_else($curl_url)}) {
 325
 326         chomp;
 327         if (/<td>(.*?)<\/td><td class=\"buttons\"><a href=\"\/show-status\?file=actions&amp;index=(\d+)\">/) {
 328
 329             my $url = $privoxy_cgi_url . 'show-status?file=actions&index=' . $2;
 330             $actionfiles[$file_number++] = $url;
 331
 332         } elsif (m@config\.html#.*\">([^<]*)</a>\s+(.*)<br>@) {
 333
 334             my $directive = $1 . " " . $2;
 335             push (@privoxy_config, $directive);
 336
 337         } elsif (m@<td><code>([^<]*)</code></td>@) {
 338
 339             $feature = $1;
 340
 341         } elsif (m@<td> (Yes|No) </td>@) {
 342
 343             $privoxy_features{$feature} = $1 if defined $feature;
 344             $feature = undef;
 345         }
 346     }
 347
 348     l(LL_FILE_LOADING, "Recognized " . @actionfiles . " actions files");
 349
 350     load_action_files(\@actionfiles);
 351 }
 352
 353 sub token_starts_new_test ($) {
 354
 355     my $token = shift;
 356     my @new_test_directives = ('set header', 'fetch test',
 357          'trusted cgi request', 'request header', 'method test',
 358          'blocked url', 'url', 'redirected url');
 359
 360     foreach my $new_test_directive (@new_test_directives) {
 361         return 1 if $new_test_directive eq $token;
 362     }
 363
 364     return 0;
 365 }
 366
 367 sub tokenize ($) {
 368
 369     my ($token, $value) = (undef, undef);
 370
 371     # Remove leading and trailing white space.
 372     s@^\s*@@;
 373     s@\s*$@@;
 374
 375     # Reverse HTML-encoding
 376     # XXX: Seriously incomplete.
 377     s@&quot;@"@g;
 378     s@&amp;@&@g;
 379
 380     # Tokenize
 381     if (/^\#\s*([^=:#]*?)\s*[=]\s*([^#]+)(?:#.*)?$/) {
 382
 383         $token = $1;
 384         $value = $2;
 385
 386         $token =~ s@\s\s+@ @g;
 387         $token =~ tr/[A-Z]/[a-z]/;
 388
 389     } elsif (/^TAG\s*:(.*)$/) {
 390
 391         $token = 'tag';
 392         $value = $1;
 393     }
 394
 395     return ($token, $value);
 396 }
 397
 398 sub enlist_new_test ($$$$$$) {
 399
 400     my ($regression_tests, $token, $value, $si, $ri, $number) = @_;
 401     my $type;
 402     my $executor;
 403
 404     if ($token eq 'set header') {
 405
 406         l(LL_FILE_LOADING, "Header to set: " . $value);
 407         $type = CLIENT_HEADER_TEST;
 408         $executor = \&execute_client_header_regression_test;
 409
 410     } elsif ($token eq 'request header') {
 411
 412         l(LL_FILE_LOADING, "Header to request: " . $value);
 413         $type = SERVER_HEADER_TEST;
 414         $executor = \&execute_server_header_regression_test;
 415         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 416
 417     } elsif ($token eq 'trusted cgi request') {
 418
 419         l(LL_FILE_LOADING, "CGI URL to test in a dumb way: " . $value);
 420         $type = TRUSTED_CGI_REQUEST;
 421         $executor = \&execute_dumb_fetch_test;
 422         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 423
 424     } elsif ($token eq 'fetch test') {
 425
 426         l(LL_FILE_LOADING, "URL to test in a dumb way: " . $value);
 427         $type = DUMB_FETCH_TEST;
 428         $executor = \&execute_dumb_fetch_test;
 429         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 430
 431     } elsif ($token eq 'method test') {
 432
 433         l(LL_FILE_LOADING, "Method to test: " . $value);
 434         $type = METHOD_TEST;
 435         $executor = \&execute_method_test;
 436         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 437
 438     } elsif ($token eq 'blocked url') {
 439
 440         l(LL_FILE_LOADING, "URL to block-test: " . $value);
 441         $executor = \&execute_block_test;
 442         $type = BLOCK_TEST;
 443
 444     } elsif ($token eq 'url') {
 445
 446         l(LL_FILE_LOADING, "Sticky URL to test: " . $value);
 447         $type = STICKY_ACTIONS_TEST;
 448         $executor = \&execute_sticky_actions_test;
 449
 450     } elsif ($token eq 'redirected url') {
 451
 452         l(LL_FILE_LOADING, "Redirected URL to test: " . $value);
 453         $type = REDIRECT_TEST;
 454         $executor = \&execute_redirect_test;
 455
 456     } else {
 457
 458         die "Incomplete '" . $token . "' support detected.";
 459     }
 460
 461     $$regression_tests[$si][$ri]{'type'} = $type;
 462     $$regression_tests[$si][$ri]{'level'} = $type;
 463     $$regression_tests[$si][$ri]{'executor'} = $executor;
 464
 465     check_for_forbidden_characters($value);
 466
 467     $$regression_tests[$si][$ri]{'data'} = $value;
 468
 469     # For function that only get passed single tests
 470     $$regression_tests[$si][$ri]{'section-id'} = $si;
 471     $$regression_tests[$si][$ri]{'regression-test-id'} = $ri;
 472     $$regression_tests[$si][$ri]{'number'} = $number - 1;
 473     l(LL_FILE_LOADING,
 474       "Regression test " . $number . " (section:" . $si . "):");
 475 }
 476
 477 # XXX: Shares a lot of code with load_regression_tests_from_file()
 478 #      that should be factored out.
 479 sub load_action_files ($) {
 480
 481     # initialized here
 482     our %actions;
 483     our @regression_tests;
 484
 485     my $actionfiles_ref = shift;
 486     my @actionfiles = @{$actionfiles_ref};
 487
 488     my $si = 0;  # Section index
 489     my $ri = -1; # Regression test index
 490     my $count = 0;
 491
 492     my $ignored = 0;
 493
 494     l(LL_STATUS, "Gathering regression tests from " .
 495       @actionfiles . " action file(s) delivered by Privoxy.");
 496
 497     for my $file_number (0 .. @actionfiles - 1) {
 498
 499         my $curl_url = quote($actionfiles[$file_number]);
 500         my $actionfile = undef;
 501         my $sticky_actions = undef;
 502
 503         foreach (@{get_cgi_page_or_else($curl_url)}) {
 504
 505             my $no_checks = 0;
 506             chomp;
 507
 508             if (/<h2>Contents of Actions File (.*?)</) {
 509                 $actionfile = $1;
 510                 next;
 511             }
 512             next unless defined $actionfile;
 513
 514             last if (/<\/pre>/);
 515
 516             my ($token, $value) = tokenize($_);
 517
 518             next unless defined $token;
 519
 520             # Load regression tests
 521
 522             if (token_starts_new_test($token)) {
 523
 524                 # Beginning of new regression test.
 525                 $ri++;
 526                 $count++;
 527                 enlist_new_test(\@regression_tests, $token, $value, $si, $ri, $count);
 528                 $no_checks = 1; # Already validated by enlist_new_test().
 529             }
 530
 531             if ($token =~ /level\s+(\d+)/i) {
 532
 533                 my $level = $1;
 534                 register_dependency($level, $value);
 535             }
 536
 537             if ($token eq 'sticky actions') {
 538
 539                 # Will be used by each following Sticky URL.
 540                 $sticky_actions = $value;
 541                 if ($sticky_actions =~ /{[^}]*\s/) {
 542                     log_and_die("'Sticky Actions' with whitespace inside the " .
 543                                 "action parameters are currently unsupported.");
 544                 }
 545             }
 546
 547             if ($si == -1 || $ri == -1) {
 548                 # No beginning of a test detected yet,
 549                 # so we don't care about any other test
 550                 # attributes.
 551                 next;
 552             }
 553
 554             if ($token eq 'expect header') {
 555
 556                 l(LL_FILE_LOADING, "Detected expectation: " . $value);
 557                 $regression_tests[$si][$ri]{'expect-header'} = $value;
 558
 559             } elsif ($token eq 'tag') {
 560
 561                 next if ($ri == -1);
 562
 563                 my $tag = parse_tag($value);
 564
 565                 # We already checked in parse_tag() after filtering
 566                 $no_checks = 1;
 567
 568                 l(LL_FILE_LOADING, "Detected TAG: " . $tag);
 569
 570                 # Save tag for all tests in this section
 571                 do {
 572                     $regression_tests[$si][$ri]{'tag'} = $tag;
 573                 } while ($ri-- > 0);
 574
 575                 $si++;
 576                 $ri = -1;
 577
 578             } elsif ($token eq 'ignore' && $value =~ /Yes/i) {
 579
 580                 l(LL_FILE_LOADING, "Ignoring section: " . test_content_as_string($regression_tests[$si][$ri]));
 581                 $regression_tests[$si][$ri]{'ignore'} = 1;
 582                 $ignored++;
 583
 584             } elsif ($token eq 'expect status code') {
 585
 586                 l(LL_FILE_LOADING, "Expecting status code: " . $value);
 587                 $regression_tests[$si][$ri]{'expected-status-code'} = $value;
 588
 589             } elsif ($token eq 'level') { # XXX: stupid name
 590
 591                 $value =~ s@(\d+).*@$1@;
 592                 l(LL_FILE_LOADING, "Level: " . $value);
 593                 $regression_tests[$si][$ri]{'level'} = $value;
 594
 595             } elsif ($token eq 'method') {
 596
 597                 l(LL_FILE_LOADING, "Method: " . $value);
 598                 $regression_tests[$si][$ri]{'method'} = $value;
 599
 600             } elsif ($token eq 'redirect destination') {
 601
 602                 l(LL_FILE_LOADING, "Redirect destination: " . $value);
 603                 $regression_tests[$si][$ri]{'redirect destination'} = $value;
 604
 605             } elsif ($token eq 'url') {
 606
 607                 if (defined $sticky_actions) {
 608                     die "WTF? Attempted to overwrite Sticky Actions"
 609                         if defined ($regression_tests[$si][$ri]{'sticky-actions'});
 610
 611                     l(LL_FILE_LOADING, "Sticky actions: " . $sticky_actions);
 612                     $regression_tests[$si][$ri]{'sticky-actions'} = $sticky_actions;
 613                 } else {
 614                     log_and_die("Sticky URL without Sticky Actions: $value");
 615                 }
 616
 617             } else {
 618
 619                 # We don't use it, so we don't need
 620                 $no_checks = 1;
 621                 l(LL_STATUS, "Enabling no_checks for $token") unless $no_checks;
 622             }
 623
 624             # XXX: Necessary?
 625             unless ($no_checks)  {
 626                 check_for_forbidden_characters($value);
 627                 check_for_forbidden_characters($token);
 628             }
 629         }
 630     }
 631
 632     l(LL_FILE_LOADING, "Done loading " . $count . " regression tests."
 633       . " Of which " . $ignored. " will be ignored)\n");
 634 }
 635
 636 ############################################################################
 637 #
 638 # Regression test executing functions
 639 #
 640 ############################################################################
 641
 642 # Fisher Yates shuffle from Perl's "How do I shuffle an array randomly?" FAQ
 643 sub fisher_yates_shuffle ($) {
 644     my $deck = shift;
 645     my $i = @$deck;
 646     while ($i--) {
 647         my $j = int rand($i+1);
 648         @$deck[$i,$j] = @$deck[$j,$i];
 649     }
 650 }
 651
 652 sub execute_regression_tests () {
 653
 654     our @regression_tests;
 655     my $loops = get_cli_option('loops');
 656     my $all_tests    = 0;
 657     my $all_failures = 0;
 658     my $all_successes = 0;
 659
 660     unless (@regression_tests) {
 661
 662         l(LL_STATUS, "No regression tests found.");
 663         return;
 664     }
 665
 666     l(LL_STATUS, "Executing regression tests ...");
 667
 668     while ($loops-- > 0) {
 669
 670         my $successes = 0;
 671         my $tests = 0;
 672         my $failures;
 673         my $skipped = 0;
 674
 675         if (cli_option_is_set('shuffle-tests')) {
 676
 677             # Shuffle both the test sections and
 678             # the tests they contain.
 679             #
 680             # XXX: With the current data layout, shuffling tests
 681             #      from different sections isn't possible.
 682             #      Is this worth changing the layout?
 683             fisher_yates_shuffle(\@regression_tests);
 684             for (my $s = 0;  $s < @regression_tests; $s++) {
 685                 fisher_yates_shuffle($regression_tests[$s]);
 686             }
 687         }
 688
 689         for (my $s = 0;  $s < @regression_tests; $s++) {
 690
 691             my $r = 0;
 692
 693             while (defined $regression_tests[$s][$r]) {
 694
 695                 unless (cli_option_is_set('shuffle-tests')) {
 696                     die "Section id mismatch" if ($s != $regression_tests[$s][$r]{'section-id'});
 697                     die "Regression test id mismatch" if ($r != $regression_tests[$s][$r]{'regression-test-id'});
 698                 }
 699                 die "Internal error. Test executor missing."
 700                     unless defined $regression_tests[$s][$r]{executor};
 701
 702                 my $number = $regression_tests[$s][$r]{'number'};
 703                 my $skip_reason = get_skip_reason($regression_tests[$s][$r]);
 704
 705                 if (defined $skip_reason) {
 706
 707                     my $message = "Skipping test " . $number . ": " . $skip_reason . ".";
 708                     log_message($message) if (cli_option_is_set('show-skipped-tests'));
 709                     $skipped++;
 710
 711                 } else {
 712
 713                     my $result = $regression_tests[$s][$r]{executor}($regression_tests[$s][$r]);
 714
 715                     log_result($regression_tests[$s][$r], $result, $tests);
 716
 717                     $successes += $result;
 718                     $tests++;
 719                     sleep(get_cli_option('sleep-time')) if (cli_option_is_set('sleep-time'));
 720                 }
 721                 $r++;
 722             }
 723         }
 724         $failures = $tests - $successes;
 725
 726         log_message("Executed " . $tests . " regression tests. " .
 727             'Skipped ' . $skipped . '. ' .
 728             $successes . " successes, " . $failures . " failures.");
 729
 730         $all_tests     += $tests;
 731         $all_failures  += $failures;
 732         $all_successes += $successes;
 733     }
 734
 735     if (get_cli_option('loops') > 1) {
 736         log_message("Total: Executed " . $all_tests . " regression tests. " .
 737             $all_successes . " successes, " . $all_failures . " failures.");
 738     }
 739 }
 740
 741 sub get_skip_reason ($) {
 742     my $test = shift;
 743     my $skip_reason = undef;
 744
 745     if ($test->{'ignore'}) {
 746
 747         $skip_reason = "Ignore flag is set";
 748
 749     } elsif (cli_option_is_set('test-number') and
 750              get_cli_option('test-number') != $test->{'number'}) {
 751
 752         $skip_reason = "Only executing test " . get_cli_option('test-number');
 753
 754     } else {
 755
 756         $skip_reason = level_is_unacceptable($test->{'level'});
 757     }
 758
 759     return $skip_reason;
 760 }
 761
 762 sub level_is_unacceptable ($) {
 763     my $level = shift;
 764     my $min_level = get_cli_option('min-level');
 765     my $max_level = get_cli_option('max-level');
 766     my $required_level = cli_option_is_set('level') ?
 767         get_cli_option('level') : $level;
 768     my $reason = undef;
 769
 770     if ($required_level != $level) {
 771
 772         $reason = "Level doesn't match (" . $level .
 773                   " != " . $required_level . ")"
 774
 775     } elsif ($level < $min_level) {
 776
 777         $reason = "Level too low (" . $level . " < " . $min_level . ")";
 778
 779     } elsif ($level > $max_level) {
 780
 781         $reason = "Level too high (" . $level . " > " . $max_level . ")";
 782
 783     } else {
 784
 785         $reason = dependency_unsatisfied($level);
 786     }
 787
 788     return $reason;
 789 }
 790
 791 sub dependency_unsatisfied ($) {
 792
 793     my $level = shift;
 794     our %dependencies;
 795     our @privoxy_config;
 796     our %privoxy_features;
 797
 798     my $dependency_problem = undef;
 799
 800     if (defined ($dependencies{$level}{'config line'})) {
 801
 802         my $dependency = $dependencies{$level}{'config line'};
 803         $dependency_problem = "depends on config line matching: '" . $dependency . "'";
 804
 805         foreach (@privoxy_config) {
 806
 807             if (/$dependency/) {
 808                 $dependency_problem = undef;
 809                 last;
 810             }
 811         }
 812
 813     }
 814
 815     if (defined ($dependencies{$level}{'feature status'})
 816         and not defined $dependency_problem) {
 817
 818         my $dependency = $dependencies{$level}{'feature status'};
 819         my ($feature, $status) = $dependency =~ /([^\s]*)\s+(Yes|No)/;
 820
 821         unless (defined($privoxy_features{$feature})
 822                 and ($privoxy_features{$feature} eq $status))
 823         {
 824             $dependency_problem = "depends on '" . $feature .
 825                 "' being set to '" . $status . "'";
 826         }
 827     }
 828
 829     return $dependency_problem;
 830 }
 831
 832 sub register_dependency ($$) {
 833
 834     my $level = shift;
 835     my $dependency = shift;
 836     our %dependencies;
 837
 838     if ($dependency =~ /config line\s+(.*)/) {
 839
 840         $dependencies{$level}{'config line'} = $1;
 841
 842     } elsif ($dependency =~ /feature status\s+(.*)/) {
 843
 844         $dependencies{$level}{'feature status'} = $1;
 845
 846     } else {
 847
 848         log_and_die("Didn't recognize dependency: $dependency.");
 849     }
 850 }
 851
 852 sub execute_method_test ($) {
 853
 854     my $test = shift;
 855     my $buffer_ref;
 856     my $status_code;
 857     my $method = $test->{'data'};
 858
 859     my $curl_parameters = '';
 860     my $expected_status_code = $test->{'expected-status-code'};
 861
 862     $curl_parameters .= '--request ' . $method . ' ';
 863     # Don't complain about the 'missing' body
 864     $curl_parameters .= '--head ' if ($method =~ /^HEAD$/i);
 865
 866     $curl_parameters .= PRIVOXY_CGI_URL;
 867
 868     $buffer_ref = get_page_with_curl($curl_parameters);
 869     $status_code = get_status_code($buffer_ref);
 870
 871     return check_status_code_result($status_code, $expected_status_code);
 872 }
 873
 874 sub execute_redirect_test ($) {
 875
 876     my $test = shift;
 877     my $buffer_ref;
 878     my $status_code;
 879
 880     my $curl_parameters = '';
 881     my $url = $test->{'data'};
 882     my $redirect_destination;
 883     my $expected_redirect_destination = $test->{'redirect destination'};
 884
 885     # XXX: Check if a redirect actually applies before doing the request.
 886     #      otherwise the test may hit a real server in failure cases.
 887
 888     $curl_parameters .= '--head ';
 889
 890     $curl_parameters .= quote($url);
 891
 892     $buffer_ref = get_page_with_curl($curl_parameters);
 893     $status_code = get_status_code($buffer_ref);
 894
 895     if ($status_code ne "302") {
 896         l(LL_VERBOSE_FAILURE,
 897           "Ooops. Expected redirect to: '" . $expected_redirect_destination
 898           . "' but got a response with status code: " . $status_code);
 899         return 0;
 900     }
 901     foreach (@{$buffer_ref}) {
 902         if (/^Location: (.*)\r\n/) {
 903             $redirect_destination = $1;
 904             last;
 905         }
 906     }
 907
 908     my $success = ($redirect_destination eq $expected_redirect_destination);
 909
 910     unless ($success) {
 911         l(LL_VERBOSE_FAILURE,
 912           "Ooops. Expected redirect to: '" . $expected_redirect_destination
 913           . "' but the redirect leads to: '" . $redirect_destination. "'");
 914     }
 915
 916     return $success;
 917 }
 918
 919 sub execute_dumb_fetch_test ($) {
 920
 921     my $test = shift;
 922     my $buffer_ref;
 923     my $status_code;
 924
 925     my $curl_parameters = '';
 926     my $expected_status_code = $test->{'expected-status-code'};
 927
 928     if (defined $test->{method}) {
 929         $curl_parameters .= '--request ' . quote($test->{method}) . ' ';
 930     }
 931     if ($test->{type} == TRUSTED_CGI_REQUEST) {
 932         $curl_parameters .= '--referer ' . quote(PRIVOXY_CGI_URL) . ' ';
 933     }
 934
 935     $curl_parameters .= quote($test->{'data'});
 936
 937     $buffer_ref = get_page_with_curl($curl_parameters);
 938     $status_code = get_status_code($buffer_ref);
 939
 940     return check_status_code_result($status_code, $expected_status_code);
 941 }
 942
 943 sub execute_block_test ($) {
 944
 945     my $test = shift;
 946     my $url = $test->{'data'};
 947     my $final_results = get_final_results($url);
 948
 949     return defined $final_results->{'+block'};
 950 }
 951
 952 sub execute_sticky_actions_test ($) {
 953
 954     my $test = shift;
 955     my $url = $test->{'data'};
 956     my $verified_actions = 0;
 957     # XXX: splitting currently doesn't work for actions whose parameters contain spaces.
 958     my @sticky_actions = split(/\s+/, $test->{'sticky-actions'});
 959     my $final_results = get_final_results($url);
 960
 961     foreach my $sticky_action (@sticky_actions) {
 962
 963         if (defined $final_results->{$sticky_action}) {
 964             # Exact match
 965             $verified_actions++;
 966
 967         } elsif ($sticky_action =~ /-.*\{/) {
 968
 969             # Disabled multi actions aren't explicitly listed as
 970             # disabled and thus have to be checked by verifying
 971             # that they aren't enabled.
 972             $verified_actions++;
 973
 974         } else {
 975             l(LL_VERBOSE_FAILURE,
 976               "Ooops. '$sticky_action' is not among the final results.");
 977         }
 978     }
 979
 980     return $verified_actions == @sticky_actions;
 981 }
 982
 983 sub get_final_results ($) {
 984
 985     my $url = shift;
 986     my $curl_parameters = '';
 987     my %final_results = ();
 988     my $final_results_reached = 0;
 989
 990     die "Unacceptable characters in $url" if $url =~ m@[\\'"]@;
 991     # XXX: should be URL-encoded properly
 992     $url =~ s@%@%25@g;
 993     $url =~ s@\s@%20@g;
 994     $url =~ s@&@%26@g;
 995     $url =~ s@:@%3A@g;
 996     $url =~ s@/@%2F@g;
 997
 998     $curl_parameters .= quote(PRIVOXY_CGI_URL . 'show-url-info?url=' . $url);
 999
1000     foreach (@{get_cgi_page_or_else($curl_parameters)}) {
1001
1002         $final_results_reached = 1 if (m@<h2>Final results:</h2>@);
1003
1004         next unless ($final_results_reached);
1005         last if (m@</td>@);
1006
1007         # Privoxy versions before 3.0.16 add a space
1008         # between action name and parameters, therefore
1009         # the " ?".
1010         if (m@<br>([-+])<a.*>([^>]*)</a>(?: ?(\{.*\}))?@) {
1011             my $action = $1.$2;
1012             my $parameter = $3;
1013
1014             if (defined $parameter) {
1015                 # In case the caller needs to check
1016                 # the action and its parameter
1017                 $final_results{$action . $parameter} = 1;
1018             }
1019             # In case the action doesn't have parameters
1020             # or the caller doesn't care for the parameter.
1021             $final_results{$action} = 1;
1022         }
1023     }
1024
1025     return \%final_results;
1026 }
1027
1028 sub check_status_code_result ($$) {
1029
1030     my $status_code = shift;
1031     my $expected_status_code = shift;
1032     my $result = 0;
1033
1034     unless (defined $status_code) {
1035
1036         # XXX: should probably be caught earlier.
1037         l(LL_VERBOSE_FAILURE,
1038           "Ooops. We expected status code " . $expected_status_code . ", but didn't get any status code at all.");
1039
1040     } elsif ($expected_status_code == $status_code) {
1041
1042         $result = 1;
1043         l(LL_VERBOSE_SUCCESS,
1044           "Yay. We expected status code " . $expected_status_code . ", and received: " . $status_code . '.');
1045
1046     } elsif (cli_option_is_set('fuzzer-feeding') and $status_code == 123) {
1047
1048         l(LL_VERBOSE_FAILURE,
1049           "Oh well. Status code lost while fuzzing. Can't check if it was " . $expected_status_code . '.');
1050
1051     } else {
1052
1053         l(LL_VERBOSE_FAILURE,
1054           "Ooops. We expected status code " . $expected_status_code . ", but received: " . $status_code . '.');
1055     }
1056
1057     return $result;
1058 }
1059
1060 sub execute_client_header_regression_test ($) {
1061
1062     my $test = shift;
1063     my $buffer_ref;
1064     my $header;
1065
1066     $buffer_ref = get_show_request_with_curl($test);
1067
1068     $header = get_header($buffer_ref, $test);
1069
1070     return check_header_result($test, $header);
1071 }
1072
1073 sub execute_server_header_regression_test ($) {
1074
1075     my $test = shift;
1076     my $buffer_ref;
1077     my $header;
1078
1079     $buffer_ref = get_head_with_curl($test);
1080
1081     $header = get_server_header($buffer_ref, $test);
1082
1083     return check_header_result($test, $header);
1084 }
1085
1086 sub interpret_result ($) {
1087     my $success = shift;
1088     return $success ? "Success" : "Failure";
1089 }
1090
1091 sub check_header_result ($$) {
1092
1093     my $test = shift;
1094     my $header = shift;
1095
1096     my $expect_header = $test->{'expect-header'};
1097     my $success = 0;
1098
1099     if ($expect_header eq 'NO CHANGE') {
1100
1101         $success = (defined($header) and $header eq $test->{'data'});
1102
1103         unless ($success) {
1104             $header = "REMOVAL" unless defined $header;
1105             l(LL_VERBOSE_FAILURE,
1106               "Ooops. Got: '" . $header . "' while expecting: '" . $expect_header . "'");
1107         }
1108
1109     } elsif ($expect_header eq 'REMOVAL') {
1110
1111         # XXX: Use more reliable check here and make sure
1112         # the header has a different name.
1113         $success = not (defined($header) and $header eq $test->{'data'});
1114
1115         unless ($success) {
1116             l(LL_VERBOSE_FAILURE,
1117               "Ooops. Expected removal but: '" . $header . "' is still there.");
1118         }
1119
1120     } elsif ($expect_header eq 'SOME CHANGE') {
1121
1122         $success = (defined($header) and $header ne $test->{'data'});
1123
1124         unless  ($success) {
1125             $header = "REMOVAL" unless defined $header;
1126             l(LL_VERBOSE_FAILURE,
1127               "Ooops. Got: '" . $header . "' while expecting: SOME CHANGE");
1128         }
1129
1130     } else {
1131
1132         $success = (defined($header) and $header eq $expect_header);
1133
1134         unless ($success) {
1135             $header = "No matching header" unless defined $header; # XXX: No header detected to be precise
1136             l(LL_VERBOSE_FAILURE,
1137               "Ooops. Got: '" . $header . "' while expecting: '" . $expect_header . "'");
1138         }
1139     }
1140     return $success;
1141 }
1142
1143 sub get_header_name ($) {
1144
1145     my $header = shift;
1146
1147     $header =~ s@(.*?: ).*@$1@;
1148
1149     return $header;
1150 }
1151
1152 sub get_header ($$) {
1153
1154     our $filtered_request = '';
1155
1156     my $buffer_ref = shift;
1157     my $test = shift;
1158
1159     my @buffer = @{$buffer_ref};
1160
1161     my $expect_header = $test->{'expect-header'};
1162
1163     die "get_header called with no expect header" unless defined $expect_header;
1164
1165     my $line;
1166     my $processed_request_reached = 0;
1167     my $read_header = 0;
1168     my $processed_request = '';
1169     my $header;
1170     my $header_to_get;
1171
1172     if ($expect_header eq 'REMOVAL'
1173      or $expect_header eq 'NO CHANGE'
1174      or $expect_header eq 'SOME CHANGE') {
1175
1176         $expect_header = $test->{'data'};
1177     }
1178
1179     $header_to_get = get_header_name($expect_header);
1180
1181     foreach (@buffer) {
1182
1183         # Skip everything before the Processed request
1184         if (/Processed Request/) {
1185             $processed_request_reached = 1;
1186             next;
1187         }
1188         next unless $processed_request_reached;
1189
1190         # End loop after the Processed request
1191         last if (/<\/pre>/);
1192
1193         # Ditch tags and leading/trailing white space.
1194         s@^\s*<.*?>@@g;
1195         s@\s*$@@g;
1196
1197         # Decode characters we care about.
1198         s@&quot;@"@g;
1199
1200         $filtered_request .=  "\n" . $_;
1201
1202         if (/^$header_to_get/) {
1203             $read_header = 1;
1204             $header = $_;
1205             last;
1206         }
1207     }
1208
1209     return $header;
1210 }
1211
1212 sub get_server_header ($$) {
1213
1214     my $buffer_ref = shift;
1215     my $test = shift;
1216
1217     my @buffer = @{$buffer_ref};
1218
1219     my $expect_header = $test->{'expect-header'};
1220     my $header;
1221     my $header_to_get;
1222
1223     # XXX: Should be caught before starting to test.
1224     log_and_die("No expect header for test " . $test->{'number'})
1225         unless defined $expect_header;
1226
1227     if ($expect_header eq 'REMOVAL'
1228      or $expect_header eq 'NO CHANGE'
1229      or $expect_header eq 'SOME CHANGE') {
1230
1231         $expect_header = $test->{'data'};
1232     }
1233
1234     $header_to_get = get_header_name($expect_header);
1235
1236     foreach (@buffer) {
1237
1238         # XXX: should probably verify that the request
1239         # was actually answered by Fellatio.
1240         if (/^$header_to_get/) {
1241             $header = $_;
1242             $header =~ s@\s*$@@g;
1243             last;
1244         }
1245     }
1246
1247     return $header;
1248 }
1249
1250 sub get_status_code ($) {
1251
1252     my $buffer_ref = shift;
1253     my @buffer = @{$buffer_ref};
1254
1255     foreach (@buffer) {
1256
1257         if (/^HTTP\/\d\.\d (\d{3})/) {
1258
1259             return $1;
1260
1261         } else {
1262
1263             return '123' if cli_option_is_set('fuzzer-feeding');
1264             chomp;
1265             log_and_die('Unexpected buffer line: "' . $_ . '"');
1266         }
1267     }
1268 }
1269
1270 sub get_test_keys () {
1271     return ('tag', 'data', 'expect-header', 'ignore');
1272 }
1273
1274 # XXX: incomplete
1275 sub test_content_as_string ($) {
1276
1277     my $test = shift;
1278
1279     my $s = "\n\t";
1280
1281     foreach my $key (get_test_keys()) {
1282         $test->{$key} = 'Not set' unless (defined $test->{$key});
1283     }
1284
1285     $s .= 'Tag: ' . $test->{'tag'};
1286     $s .= "\n\t";
1287     $s .= 'Set header: ' . $test->{'data'}; # XXX: adjust for other test types
1288     $s .= "\n\t";
1289     $s .= 'Expected header: ' . $test->{'expect-header'};
1290     $s .= "\n\t";
1291     $s .= 'Ignore: ' . $test->{'ignore'};
1292
1293     return $s;
1294 }
1295
1296 sub fuzz_header($) {
1297     my $header = shift;
1298     my $white_space = int(rand(2)) - 1 ? " " : "\t";
1299
1300     $white_space = $white_space x (1 + int(rand(5)));
1301
1302     # Only fuzz white space before the first quoted token.
1303     # (Privoxy doesn't touch white space inside quoted tokens
1304     # and modifying it would cause the tests to fail).
1305     $header =~ s@(^[^"]*?)\s@$1$white_space@g;
1306
1307     return $header;
1308 }
1309
1310 ############################################################################
1311 #
1312 # HTTP fetch functions
1313 #
1314 ############################################################################
1315
1316 sub get_cgi_page_or_else ($) {
1317
1318     my $cgi_url = shift;
1319     my $content_ref = get_page_with_curl($cgi_url);
1320     my $status_code = get_status_code($content_ref);
1321
1322     if (200 != $status_code) {
1323
1324         my $log_message = "Failed to fetch Privoxy CGI Page. " .
1325                           "Received status code ". $status_code .
1326                           " while only 200 is acceptable.";
1327
1328         if (cli_option_is_set('fuzzer-feeding')) {
1329
1330             $log_message .= " Ignored due to fuzzer feeding.";
1331             l(LL_SOFT_ERROR, $log_message)
1332
1333         } else {
1334
1335             log_and_die($log_message);
1336         }
1337     }
1338
1339     return $content_ref;
1340 }
1341
1342 # XXX: misleading name
1343 sub get_show_request_with_curl ($) {
1344
1345     our $privoxy_cgi_url;
1346     my $test = shift;
1347
1348     my $curl_parameters = ' ';
1349     my $header = $test->{'data'};
1350
1351     if (cli_option_is_set('header-fuzzing')) {
1352         $header = fuzz_header($header);
1353     }
1354
1355     # Enable the action to test
1356     $curl_parameters .= '-H \'X-Privoxy-Control: ' . $test->{'tag'} . '\' ';
1357     # The header to filter
1358     $curl_parameters .= '-H \'' . $header . '\' ';
1359
1360     $curl_parameters .= ' ';
1361     $curl_parameters .= $privoxy_cgi_url;
1362     $curl_parameters .= 'show-request';
1363
1364     return get_cgi_page_or_else($curl_parameters);
1365 }
1366
1367 sub get_head_with_curl ($) {
1368
1369     our $fellatio_url = FELLATIO_URL;
1370     my $test = shift;
1371
1372     my $curl_parameters = ' ';
1373
1374     # Enable the action to test
1375     $curl_parameters .= '-H \'X-Privoxy-Control: ' . $test->{'tag'} . '\' ';
1376     # The header to filter
1377     $curl_parameters .= '-H \'X-Gimme-Head-With: ' . $test->{'data'} . '\' ';
1378     $curl_parameters .= '--head ';
1379
1380     $curl_parameters .= ' ';
1381     $curl_parameters .= $fellatio_url;
1382
1383     return get_page_with_curl($curl_parameters);
1384 }
1385
1386 sub get_page_with_curl ($) {
1387
1388     our $proxy;
1389
1390     my $parameters = shift;
1391     my @buffer;
1392     my $curl_line = CURL;
1393     my $retries_left = get_cli_option('retries') + 1;
1394     my $failure_reason;
1395
1396     if (defined $proxy) {
1397         $curl_line .= ' --proxy ' . quote($proxy);
1398     }
1399     # We want to see the HTTP status code
1400     $curl_line .= " --include ";
1401     # Let Privoxy emit two log messages less.
1402     $curl_line .= ' -H \'Proxy-Connection:\' ' unless $parameters =~ /Proxy-Connection:/;
1403     $curl_line .= ' -H \'Connection: close\' ' unless $parameters =~ /Connection:/;
1404     # We don't care about fetch statistic.
1405     $curl_line .= " -s ";
1406     # We do care about the failure reason if any.
1407     $curl_line .= " -S ";
1408     # We want to advertise ourselves
1409     $curl_line .= " --user-agent '" . PRT_VERSION . "' ";
1410     # We aren't too patient
1411     $curl_line .= " --max-time '" . get_cli_option('max-time') . "' ";
1412
1413     $curl_line .= $parameters;
1414     # XXX: still necessary?
1415     $curl_line .= ' 2>&1';
1416
1417     l(LL_PAGE_FETCHING, "Executing: " . $curl_line);
1418
1419     do {
1420         @buffer = `$curl_line`;
1421
1422         if ($?) {
1423             log_and_die("Executing '$curl_line' failed.") unless @buffer;
1424             $failure_reason = array_as_string(\@buffer);
1425             chomp $failure_reason;
1426             l(LL_SOFT_ERROR, "Fetch failure: '" . $failure_reason . $! ."'");
1427         }
1428     } while ($? && --$retries_left);
1429
1430     unless ($retries_left) {
1431         log_and_die("Running curl failed " . get_cli_option('retries') .
1432                     " times in a row. Last error: '" . $failure_reason . "'.");
1433     }
1434
1435     return \@buffer;
1436 }
1437
1438
1439 ############################################################################
1440 #
1441 # Log functions
1442 #
1443 ############################################################################
1444
1445 sub array_as_string ($) {
1446     my $array_ref = shift;
1447     my $string = '';
1448
1449     foreach (@{$array_ref}) {
1450         $string .= $_;
1451     }
1452
1453     return $string;
1454 }
1455
1456 sub show_test ($) {
1457     my $test = shift;
1458     log_message('Test is:' . test_content_as_string($test));
1459 }
1460
1461 # Conditional log
1462 sub l ($$) {
1463     our $log_level;
1464     my $this_level = shift;
1465     my $message = shift;
1466
1467     log_message($message) if ($log_level & $this_level);
1468 }
1469
1470 sub log_and_die ($) {
1471     my $message = shift;
1472
1473     log_message('Oh noes. ' . $message . ' Fatal error. Exiting.');
1474     exit;
1475 }
1476
1477 sub log_message ($) {
1478
1479     my $message = shift;
1480
1481     our $logfile;
1482     our $no_logging;
1483     our $leading_log_date;
1484     our $leading_log_time;
1485
1486     my $time_stamp = '';
1487     my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime time;
1488
1489     if ($leading_log_date || $leading_log_time) {
1490
1491         if ($leading_log_date) {
1492             $year += 1900;
1493             $mon  += 1;
1494             $time_stamp = sprintf("%i-%.2i-%.2i", $year, $mon, $mday);
1495         }
1496
1497         if ($leading_log_time) {
1498             $time_stamp .= ' ' if $leading_log_date;
1499             $time_stamp.= sprintf("%.2i:%.2i:%.2i", $hour, $min, $sec);
1500         }
1501
1502         $message = $time_stamp . ": " . $message;
1503     }
1504
1505     printf("%s\n", $message);
1506 }
1507
1508 sub log_result ($$) {
1509
1510     our $verbose_test_description;
1511     our $filtered_request;
1512
1513     my $test = shift;
1514     my $result = shift;
1515     my $number = shift;
1516
1517     my $message = '';
1518
1519     $message .= interpret_result($result);
1520     $message .= " for test ";
1521     $message .= $number;
1522     $message .= '/';
1523     $message .= $test->{'number'};
1524     $message .= '/';
1525     $message .= $test->{'section-id'};
1526     $message .= '/';
1527     $message .= $test->{'regression-test-id'};
1528     $message .= '.';
1529
1530     if ($verbose_test_description) {
1531
1532         if ($test->{'type'} == CLIENT_HEADER_TEST) {
1533
1534             $message .= ' Header ';
1535             $message .= quote($test->{'data'});
1536             $message .= ' and tag ';
1537             $message .= quote($test->{'tag'});
1538
1539         } elsif ($test->{'type'} == SERVER_HEADER_TEST) {
1540
1541             $message .= ' Request Header ';
1542             $message .= quote($test->{'data'});
1543             $message .= ' and tag ';
1544             $message .= quote($test->{'tag'});
1545
1546         } elsif ($test->{'type'} == DUMB_FETCH_TEST) {
1547
1548             $message .= ' URL ';
1549             $message .= quote($test->{'data'});
1550             $message .= ' and expected status code ';
1551             $message .= quote($test->{'expected-status-code'});
1552
1553         } elsif ($test->{'type'} == TRUSTED_CGI_REQUEST) {
1554
1555             $message .= ' CGI URL ';
1556             $message .= quote($test->{'data'});
1557             $message .= ' and expected status code ';
1558             $message .= quote($test->{'expected-status-code'});
1559
1560         } elsif ($test->{'type'} == METHOD_TEST) {
1561
1562             $message .= ' HTTP method ';
1563             $message .= quote($test->{'data'});
1564             $message .= ' and expected status code ';
1565             $message .= quote($test->{'expected-status-code'});
1566
1567         } elsif ($test->{'type'} == BLOCK_TEST) {
1568
1569             $message .= ' Supposedly-blocked URL: ';
1570             $message .= quote($test->{'data'});
1571
1572         } elsif ($test->{'type'} == STICKY_ACTIONS_TEST) {
1573
1574             $message .= ' Sticky Actions: ';
1575             $message .= quote($test->{'sticky-actions'});
1576             $message .= ' and URL: ';
1577             $message .= quote($test->{'data'});
1578
1579         } elsif ($test->{'type'} == REDIRECT_TEST) {
1580
1581             $message .= ' Redirected URL: ';
1582             $message .= quote($test->{'data'});
1583             $message .= ' and redirect destination: ';
1584             $message .= quote($test->{'redirect destination'});
1585
1586         } else {
1587
1588             die "Incomplete support for test type " . $test->{'type'} .  " detected.";
1589         }
1590     }
1591
1592     log_message($message) if (!$result or cli_option_is_set('verbose'));
1593 }
1594
1595 sub quote ($) {
1596     my $s = shift;
1597     return '\'' . $s . '\'';
1598 }
1599
1600 sub print_version () {
1601     printf PRT_VERSION . "\n" . 'Copyright (C) 2007-2011 Fabian Keil <fk@fabiankeil.de>' . "\n";
1602 }
1603
1604 sub list_test_types () {
1605     my %test_types = (
1606         'Client header test'  => CLIENT_HEADER_TEST,
1607         'Server header test'  =>  2,
1608         'Dumb fetch test'     =>  3,
1609         'Method test'         =>  4,
1610         'Sticky action test'  =>  5,
1611         'Trusted CGI test'    =>  6,
1612         'Block test'          =>  7,
1613         'Redirect test'       => 108,
1614     );
1615
1616     print "\nThe supported test types and their default levels are:\n";
1617     foreach my $test_type (sort { $test_types{$a} <=> $test_types{$b} } keys %test_types) {
1618         printf "     %-20s -> %3.d\n", $test_type, $test_types{$test_type};
1619     }
1620 }
1621
1622 sub help () {
1623
1624     our %cli_options;
1625
1626     print_version();
1627
1628     print << "    EOF"
1629
1630 Options and their default values if they have any:
1631     [--debug $cli_options{'debug'}]
1632     [--forks $cli_options{'forks'}]
1633     [--fuzzer-address]
1634     [--fuzzer-feeding]
1635     [--help]
1636     [--header-fuzzing]
1637     [--level]
1638     [--local-test-file]
1639     [--loops $cli_options{'loops'}]
1640     [--max-level $cli_options{'max-level'}]
1641     [--max-time $cli_options{'max-time'}]
1642     [--min-level $cli_options{'min-level'}]
1643     [--privoxy-address]
1644     [--retries $cli_options{'retries'}]
1645     [--show-skipped-tests]
1646     [--shuffle-tests]
1647     [--sleep-time $cli_options{'sleep-time'}]
1648     [--test-number]
1649     [--verbose]
1650     [--version]
1651     EOF
1652     ;
1653
1654     list_test_types();
1655
1656     print << "    EOF"
1657
1658 Try "perldoc $0" for more information
1659     EOF
1660     ;
1661
1662     exit(0);
1663 }
1664
1665 sub init_cli_options () {
1666
1667     our %cli_options;
1668     our $log_level;
1669
1670     $cli_options{'debug'}     = $log_level;
1671     $cli_options{'forks'}     = CLI_FORKS;
1672     $cli_options{'loops'}     = CLI_LOOPS;
1673     $cli_options{'max-level'} = CLI_MAX_LEVEL;
1674     $cli_options{'max-time'}  = CLI_MAX_TIME;
1675     $cli_options{'min-level'} = CLI_MIN_LEVEL;
1676     $cli_options{'sleep-time'}= CLI_SLEEP_TIME;
1677     $cli_options{'retries'}   = CLI_RETRIES;
1678 }
1679
1680 sub parse_cli_options () {
1681
1682     our %cli_options;
1683     our $log_level;
1684
1685     init_cli_options();
1686
1687     GetOptions (
1688         'debug=i'            => \$cli_options{'debug'},
1689         'forks=i'            => \$cli_options{'forks'},
1690         'fuzzer-address=s'   => \$cli_options{'fuzzer-address'},
1691         'fuzzer-feeding'     => \$cli_options{'fuzzer-feeding'},
1692         'header-fuzzing'     => \$cli_options{'header-fuzzing'},
1693         'help'               => \&help,
1694         'level=i'            => \$cli_options{'level'},
1695         'local-test-file=s'  => \$cli_options{'local-test-file'},
1696         'loops=i'            => \$cli_options{'loops'},
1697         'max-level=i'        => \$cli_options{'max-level'},
1698         'max-time=i'         => \$cli_options{'max-time'},
1699         'min-level=i'        => \$cli_options{'min-level'},
1700         'privoxy-address=s'  => \$cli_options{'privoxy-address'},
1701         'retries=i'          => \$cli_options{'retries'},
1702         'shuffle-tests'      => \$cli_options{'shuffle-tests'},
1703         'show-skipped-tests' => \$cli_options{'show-skipped-tests'},
1704         'sleep-time=i'       => \$cli_options{'sleep-time'},
1705         'test-number=i'      => \$cli_options{'test-number'},
1706         'verbose'            => \$cli_options{'verbose'},
1707         'version'            => sub {print_version && exit(0)}
1708     ) or exit(1);
1709     $log_level |= $cli_options{'debug'};
1710 }
1711
1712 sub cli_option_is_set ($) {
1713
1714     our %cli_options;
1715     my $cli_option = shift;
1716
1717     return defined $cli_options{$cli_option};
1718 }
1719
1720 sub get_cli_option ($) {
1721
1722     our %cli_options;
1723     my $cli_option = shift;
1724
1725     die "Unknown CLI option: $cli_option" unless defined $cli_options{$cli_option};
1726
1727     return $cli_options{$cli_option};
1728 }
1729
1730 sub init_proxy_settings($) {
1731
1732     my $choice = shift;
1733     our $proxy = undef;
1734
1735     if (($choice eq 'fuzz-proxy') and cli_option_is_set('fuzzer-address')) {
1736         $proxy = get_cli_option('fuzzer-address');
1737     }
1738
1739     if ((not defined $proxy) or ($choice eq 'vanilla-proxy')) {
1740
1741         if (cli_option_is_set('privoxy-address')) {
1742             $proxy .=  get_cli_option('privoxy-address');
1743         }
1744     }
1745 }
1746
1747 sub start_forks($) {
1748     my $forks = shift;
1749
1750     log_and_die("Invalid --fork value: " . $forks . ".") if ($forks < 0);
1751
1752     foreach my $fork (1 .. $forks) {
1753         log_message("Starting fork $fork");
1754         my $pid = fork();
1755         if (defined $pid && !$pid) {
1756             return;
1757         }
1758     }
1759 }
1760
1761 sub main () {
1762
1763     init_our_variables();
1764     parse_cli_options();
1765     init_proxy_settings('vanilla-proxy');
1766     load_regression_tests();
1767     init_proxy_settings('fuzz-proxy');
1768     start_forks(get_cli_option('forks')) if cli_option_is_set('forks');
1769     execute_regression_tests();
1770 }
1771
1772 main();
1773
1774 =head1 NAME
1775
1776 B<privoxy-regression-test> - A regression test "framework" for Privoxy.
1777
1778 =head1 SYNOPSIS
1779
1780 B<privoxy-regression-test> [B<--debug bitmask>] [B<--forks> forks]
1781 [B<--fuzzer-feeding>] [B<--fuzzer-feeding>] [B<--help>] [B<--level level>]
1782 [B<--local-test-file testfile>] [B<--loops count>] [B<--max-level max-level>]
1783 [B<--max-time max-time>] [B<--min-level min-level>] B<--privoxy-address proxy-address>
1784 [B<--retries retries>] [B<--test-number test-number>]
1785 [B<--show-skipped-tests>] [B<--sleep-time> seconds] [B<--verbose>]
1786 [B<--version>]
1787
1788 =head1 DESCRIPTION
1789
1790 Privoxy-Regression-Test is supposed to one day become
1791 a regression test suite for Privoxy. It's not quite there
1792 yet, however, and can currently only test header actions,
1793 check the returned status code for requests to arbitrary
1794 URLs and verify which actions are applied to them.
1795
1796 Client header actions are tested by requesting
1797 B<http://p.p/show-request> and checking whether
1798 or not Privoxy modified the original request as expected.
1799
1800 The original request contains both the header the action-to-be-tested
1801 acts upon and an additional tagger-triggering header that enables
1802 the action to test.
1803
1804 Applied actions are checked through B<http://p.p/show-url-info>.
1805
1806 =head1 CONFIGURATION FILE SYNTAX
1807
1808 Privoxy-Regression-Test's configuration is embedded in
1809 Privoxy action files and loaded through Privoxy's web interface.
1810
1811 It makes testing a Privoxy version running on a remote system easier
1812 and should prevent you from updating your tests without updating Privoxy's
1813 configuration accordingly.
1814
1815 A client-header-action test section looks like this:
1816
1817     # Set Header    = Referer: http://www.example.org.zwiebelsuppe.exit/
1818     # Expect Header = Referer: http://www.example.org/
1819     {+client-header-filter{hide-tor-exit-notation} -hide-referer}
1820     TAG:^client-header-filter\{hide-tor-exit-notation\}$
1821
1822 The example above causes Privoxy-Regression-Test to set
1823 the header B<Referer: http://www.example.org.zwiebelsuppe.exit/>
1824 and to expect it to be modified to
1825 B<Referer: http://www.example.org/>.
1826
1827 When testing this section, Privoxy-Regression-Test will set the header
1828 B<X-Privoxy-Control: client-header-filter{hide-tor-exit-notation}>
1829 causing the B<privoxy-control> tagger to create the tag
1830 B<client-header-filter{hide-tor-exit-notation}> which will finally
1831 cause Privoxy to enable the action section.
1832
1833 Note that the actions itself are only used by Privoxy,
1834 Privoxy-Regression-Test ignores them and will be happy
1835 as long as the expectations are satisfied.
1836
1837 A fetch test looks like this:
1838
1839     # Fetch Test = http://p.p/user-manual
1840     # Expect Status Code = 302
1841
1842 It tells Privoxy-Regression-Test to request B<http://p.p/user-manual>
1843 and to expect a response with the HTTP status code B<302>. Obviously that's
1844 not a very thorough test and mainly useful to get some code coverage
1845 for Valgrind or to verify that the templates are installed correctly.
1846
1847 If you want to test CGI pages that require a trusted
1848 referer, you can use:
1849
1850     # Trusted CGI Request = http://p.p/edit-actions
1851
1852 It works like ordinary fetch tests, but sets the referer
1853 header to a trusted value.
1854
1855 If no explicit status code expectation is set, B<200> is used.
1856
1857 To verify that a URL is blocked, use:
1858
1859     # Blocked URL = http://www.example.com/blocked
1860
1861 To verify that a specific set of actions is applied to an URL, use:
1862
1863     # Sticky Actions = +block{foo} +handle-as-empty-document -handle-as-image
1864     # URL = http://www.example.org/my-first-url
1865
1866 The sticky actions will be checked for all URLs below it
1867 until the next sticky actions directive.
1868
1869 To verify that requests for a URL get redirected, use:
1870
1871     # Redirected URL = http://www.example.com/redirect-me
1872     # Redirect Destination = http://www.example.org/redirected
1873
1874 =head1 TEST LEVELS
1875
1876 All tests have test levels to let the user
1877 control which ones to execute (see I<OPTIONS> below).
1878 Test levels are either set with the B<Level> directive,
1879 or implicitly through the test type.
1880
1881 Redirect tests default to level 108, block tests to level 7,
1882 fetch tests to level 6, "Sticky Actions" tests default to
1883 level 5, tests for trusted CGI requests to level 3 and
1884 client-header-action tests to level 1.
1885
1886 The current redirect test level is above the default
1887 max-level value as failed tests will result in outgoing
1888 connections. Use the B<--max-level> option to run them
1889 as well.
1890
1891 =head1 OPTIONS
1892
1893 B<--debug bitmask> Add the bitmask provided as integer
1894 to the debug settings.
1895
1896 B<--forks forks> Number of forks to start before executing
1897 the regression tests. This is mainly useful for stress-testing.
1898
1899 B<--fuzzer-address> Listening address used when executing
1900 the regression tests. Useful to make sure that the requests
1901 to load the regression tests don't fail due to fuzzing.
1902
1903 B<--fuzzer-feeding> Ignore some errors that would otherwise
1904 cause Privoxy-Regression-Test to abort the test because
1905 they shouldn't happen in normal operation. This option is
1906 intended to be used if Privoxy-Regression-Test is only
1907 used to feed a fuzzer in which case there's a high chance
1908 that Privoxy gets an invalid request and returns an error
1909 message.
1910
1911 B<--help> Shows available command line options.
1912
1913 B<--header-fuzzing> Modifies linear white space in
1914 headers in a way that should not affect the test result.
1915
1916 B<--level level> Only execute tests with the specified B<level>.
1917
1918 B<--local-test-file test-file> Do not get the tests
1919 through Privoxy's web interface, but use a single local
1920 file. Not recommended for testing Privoxy, but can be useful
1921 to "misappropriate" Privoxy-Regression-Test to test other
1922 stuff, like webserver configurations.
1923
1924 B<--loop count> Loop through the regression tests B<count> times.
1925 Useful to feed a fuzzer, or when doing stress tests with
1926 several Privoxy-Regression-Test instances running at the same
1927 time.
1928
1929 B<--max-level max-level> Only execute tests with a B<level>
1930 below or equal to the numerical B<max-level>.
1931
1932 B<--max-time max-time> Give Privoxy B<max-time> seconds
1933 to return data. Increasing the default may make sense when
1934 Privoxy is run through Valgrind, decreasing the default may
1935 make sense when Privoxy-Regression-Test is used to feed
1936 a fuzzer.
1937
1938 B<--min-level min-level> Only execute tests with a B<level>
1939 above or equal to the numerical B<min-level>.
1940
1941 B<--privoxy-address proxy-address> Privoxy's listening address.
1942 If it's not set, the value of the environment variable http_proxy
1943 will be used. B<proxy-address> has to be specified in http_proxy
1944 syntax.
1945
1946 B<--retries retries> Retry B<retries> times.
1947
1948 B<--test-number test-number> Only run the test with the specified
1949 number.
1950
1951 B<--show-skipped-tests> Log skipped tests even if verbose mode is off.
1952
1953 B<--shuffle-tests> Shuffle test sections and their tests before
1954 executing them. When combined with B<--forks>, this can increase
1955 the chances of detecting race conditions. Of course some problems
1956 are easier to detect without this option.
1957
1958 B<--sleep-time seconds> Wait B<seconds> between tests. Useful when
1959 debugging issues with systems that don't log with millisecond precision.
1960
1961 B<--verbose> Log successful tests as well. By default only
1962 the failures are logged.
1963
1964 B<--version> Print version and exit.
1965
1966 The second dash is optional, options can be shortened,
1967 as long as there are no ambiguities.
1968
1969 =head1 PRIVOXY CONFIGURATION
1970
1971 Privoxy-Regression-Test is shipped with B<regression-tests.action>
1972 which aims to test all official client-header modifying actions
1973 and can be used to verify that the templates and the user manual
1974 files are installed correctly.
1975
1976 To use it, it has to be copied in Privoxy's configuration
1977 directory, and afterwards referenced in Privoxy's configuration
1978 file with the line:
1979
1980     actionsfile regression-tests.action
1981
1982 In general, its tests are supposed to work without changing
1983 any other action files, unless you already added lots of
1984 taggers yourself. If you are using taggers that cause problems,
1985 you might have to temporary disable them for Privoxy's CGI pages.
1986
1987 Some of the regression tests rely on Privoxy features that
1988 may be disabled in your configuration. Tests with a level below
1989 7 are supposed to work with all Privoxy configurations (provided
1990 you didn't build with FEATURE_GRACEFUL_TERMINATION).
1991
1992 Tests with level 9 require Privoxy to deliver the User Manual,
1993 tests with level 12 require the CGI editor to be enabled.
1994
1995 =head1 CAVEATS
1996
1997 Expect the configuration file syntax to change with future releases.
1998
1999 =head1 LIMITATIONS
2000
2001 As Privoxy's B<show-request> page only shows client headers,
2002 Privoxy-Regression-Test can't use it to test Privoxy actions
2003 that modify server headers.
2004
2005 As Privoxy-Regression-Test relies on Privoxy's tag feature to
2006 control the actions to test, it currently only works with
2007 Privoxy 3.0.7 or later.
2008
2009 At the moment Privoxy-Regression-Test fetches Privoxy's
2010 configuration page through I<curl>(1), therefore you have to
2011 have I<curl> installed, otherwise you won't be able to run
2012 Privoxy-Regression-Test in a meaningful way.
2013
2014 =head1 SEE ALSO
2015
2016 privoxy(1) curl(1)
2017
2018 =head1 AUTHOR
2019
2020 Fabian Keil <fk@fabiankeil.de>
2021
2022 =cut