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.78 2011/10/30 16:20:35 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.4',
  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 sub execute_regression_tests () {
 643
 644     our @regression_tests;
 645     my $loops = get_cli_option('loops');
 646     my $all_tests    = 0;
 647     my $all_failures = 0;
 648     my $all_successes = 0;
 649
 650     unless (@regression_tests) {
 651
 652         l(LL_STATUS, "No regression tests found.");
 653         return;
 654     }
 655
 656     l(LL_STATUS, "Executing regression tests ...");
 657
 658     while ($loops-- > 0) {
 659
 660         my $successes = 0;
 661         my $tests = 0;
 662         my $failures;
 663         my $skipped = 0;
 664
 665         for (my $s = 0;  $s < @regression_tests; $s++) {
 666
 667             my $r = 0;
 668
 669             while (defined $regression_tests[$s][$r]) {
 670
 671                 die "Section id mismatch" if ($s != $regression_tests[$s][$r]{'section-id'});
 672                 die "Regression test id mismatch" if ($r != $regression_tests[$s][$r]{'regression-test-id'});
 673                 die "Internal error. Test executor missing."
 674                     unless defined $regression_tests[$s][$r]{executor};
 675
 676                 my $number = $regression_tests[$s][$r]{'number'};
 677                 my $skip_reason = get_skip_reason($regression_tests[$s][$r]);
 678
 679                 if (defined $skip_reason) {
 680
 681                     my $message = "Skipping test " . $number . ": " . $skip_reason . ".";
 682                     log_message($message) if (cli_option_is_set('show-skipped-tests'));
 683                     $skipped++;
 684
 685                 } else {
 686
 687                     my $result = $regression_tests[$s][$r]{executor}($regression_tests[$s][$r]);
 688
 689                     log_result($regression_tests[$s][$r], $result, $tests);
 690
 691                     $successes += $result;
 692                     $tests++;
 693                     sleep(get_cli_option('sleep-time')) if (cli_option_is_set('sleep-time'));
 694                 }
 695                 $r++;
 696             }
 697         }
 698         $failures = $tests - $successes;
 699
 700         log_message("Executed " . $tests . " regression tests. " .
 701             'Skipped ' . $skipped . '. ' .
 702             $successes . " successes, " . $failures . " failures.");
 703
 704         $all_tests     += $tests;
 705         $all_failures  += $failures;
 706         $all_successes += $successes;
 707     }
 708
 709     if (get_cli_option('loops') > 1) {
 710         log_message("Total: Executed " . $all_tests . " regression tests. " .
 711             $all_successes . " successes, " . $all_failures . " failures.");
 712     }
 713 }
 714
 715 sub get_skip_reason ($) {
 716     my $test = shift;
 717     my $skip_reason = undef;
 718
 719     if ($test->{'ignore'}) {
 720
 721         $skip_reason = "Ignore flag is set";
 722
 723     } elsif (cli_option_is_set('test-number') and
 724              get_cli_option('test-number') != $test->{'number'}) {
 725
 726         $skip_reason = "Only executing test " . get_cli_option('test-number');
 727
 728     } else {
 729
 730         $skip_reason = level_is_unacceptable($test->{'level'});
 731     }
 732
 733     return $skip_reason;
 734 }
 735
 736 sub level_is_unacceptable ($) {
 737     my $level = shift;
 738     my $min_level = get_cli_option('min-level');
 739     my $max_level = get_cli_option('max-level');
 740     my $required_level = cli_option_is_set('level') ?
 741         get_cli_option('level') : $level;
 742     my $reason = undef;
 743
 744     if ($required_level != $level) {
 745
 746         $reason = "Level doesn't match (" . $level .
 747                   " != " . $required_level . ")"
 748
 749     } elsif ($level < $min_level) {
 750
 751         $reason = "Level too low (" . $level . " < " . $min_level . ")";
 752
 753     } elsif ($level > $max_level) {
 754
 755         $reason = "Level too high (" . $level . " > " . $max_level . ")";
 756
 757     } else {
 758
 759         $reason = dependency_unsatisfied($level);
 760     }
 761
 762     return $reason;
 763 }
 764
 765 sub dependency_unsatisfied ($) {
 766
 767     my $level = shift;
 768     our %dependencies;
 769     our @privoxy_config;
 770     our %privoxy_features;
 771
 772     my $dependency_problem = undef;
 773
 774     if (defined ($dependencies{$level}{'config line'})) {
 775
 776         my $dependency = $dependencies{$level}{'config line'};
 777         $dependency_problem = "depends on config line matching: '" . $dependency . "'";
 778
 779         foreach (@privoxy_config) {
 780
 781             if (/$dependency/) {
 782                 $dependency_problem = undef;
 783                 last;
 784             }
 785         }
 786
 787     }
 788
 789     if (defined ($dependencies{$level}{'feature status'})
 790         and not defined $dependency_problem) {
 791
 792         my $dependency = $dependencies{$level}{'feature status'};
 793         my ($feature, $status) = $dependency =~ /([^\s]*)\s+(Yes|No)/;
 794
 795         unless (defined($privoxy_features{$feature})
 796                 and ($privoxy_features{$feature} eq $status))
 797         {
 798             $dependency_problem = "depends on '" . $feature .
 799                 "' being set to '" . $status . "'";
 800         }
 801     }
 802
 803     return $dependency_problem;
 804 }
 805
 806 sub register_dependency ($$) {
 807
 808     my $level = shift;
 809     my $dependency = shift;
 810     our %dependencies;
 811
 812     if ($dependency =~ /config line\s+(.*)/) {
 813
 814         $dependencies{$level}{'config line'} = $1;
 815
 816     } elsif ($dependency =~ /feature status\s+(.*)/) {
 817
 818         $dependencies{$level}{'feature status'} = $1;
 819
 820     } else {
 821
 822         log_and_die("Didn't recognize dependency: $dependency.");
 823     }
 824 }
 825
 826 sub execute_method_test ($) {
 827
 828     my $test = shift;
 829     my $buffer_ref;
 830     my $status_code;
 831     my $method = $test->{'data'};
 832
 833     my $curl_parameters = '';
 834     my $expected_status_code = $test->{'expected-status-code'};
 835
 836     $curl_parameters .= '--request ' . $method . ' ';
 837     # Don't complain about the 'missing' body
 838     $curl_parameters .= '--head ' if ($method =~ /^HEAD$/i);
 839
 840     $curl_parameters .= PRIVOXY_CGI_URL;
 841
 842     $buffer_ref = get_page_with_curl($curl_parameters);
 843     $status_code = get_status_code($buffer_ref);
 844
 845     return check_status_code_result($status_code, $expected_status_code);
 846 }
 847
 848 sub execute_redirect_test ($) {
 849
 850     my $test = shift;
 851     my $buffer_ref;
 852     my $status_code;
 853
 854     my $curl_parameters = '';
 855     my $url = $test->{'data'};
 856     my $redirect_destination;
 857     my $expected_redirect_destination = $test->{'redirect destination'};
 858
 859     # XXX: Check if a redirect actually applies before doing the request.
 860     #      otherwise the test may hit a real server in failure cases.
 861
 862     $curl_parameters .= '--head ';
 863
 864     $curl_parameters .= quote($url);
 865
 866     $buffer_ref = get_page_with_curl($curl_parameters);
 867     $status_code = get_status_code($buffer_ref);
 868
 869     if ($status_code ne "302") {
 870         l(LL_VERBOSE_FAILURE,
 871           "Ooops. Expected redirect to: '" . $expected_redirect_destination
 872           . "' but got a response with status code: " . $status_code);
 873         return 0;
 874     }
 875     foreach (@{$buffer_ref}) {
 876         if (/^Location: (.*)\r\n/) {
 877             $redirect_destination = $1;
 878             last;
 879         }
 880     }
 881
 882     my $success = ($redirect_destination eq $expected_redirect_destination);
 883
 884     unless ($success) {
 885         l(LL_VERBOSE_FAILURE,
 886           "Ooops. Expected redirect to: '" . $expected_redirect_destination
 887           . "' but the redirect leads to: '" . $redirect_destination. "'");
 888     }
 889
 890     return $success;
 891 }
 892
 893 sub execute_dumb_fetch_test ($) {
 894
 895     my $test = shift;
 896     my $buffer_ref;
 897     my $status_code;
 898
 899     my $curl_parameters = '';
 900     my $expected_status_code = $test->{'expected-status-code'};
 901
 902     if (defined $test->{method}) {
 903         $curl_parameters .= '--request ' . quote($test->{method}) . ' ';
 904     }
 905     if ($test->{type} == TRUSTED_CGI_REQUEST) {
 906         $curl_parameters .= '--referer ' . quote(PRIVOXY_CGI_URL) . ' ';
 907     }
 908
 909     $curl_parameters .= quote($test->{'data'});
 910
 911     $buffer_ref = get_page_with_curl($curl_parameters);
 912     $status_code = get_status_code($buffer_ref);
 913
 914     return check_status_code_result($status_code, $expected_status_code);
 915 }
 916
 917 sub execute_block_test ($) {
 918
 919     my $test = shift;
 920     my $url = $test->{'data'};
 921     my $final_results = get_final_results($url);
 922
 923     return defined $final_results->{'+block'};
 924 }
 925
 926 sub execute_sticky_actions_test ($) {
 927
 928     my $test = shift;
 929     my $url = $test->{'data'};
 930     my $verified_actions = 0;
 931     # XXX: splitting currently doesn't work for actions whose parameters contain spaces.
 932     my @sticky_actions = split(/\s+/, $test->{'sticky-actions'});
 933     my $final_results = get_final_results($url);
 934
 935     foreach my $sticky_action (@sticky_actions) {
 936
 937         if (defined $final_results->{$sticky_action}) {
 938             # Exact match
 939             $verified_actions++;
 940
 941         } elsif ($sticky_action =~ /-.*\{/) {
 942
 943             # Disabled multi actions aren't explicitly listed as
 944             # disabled and thus have to be checked by verifying
 945             # that they aren't enabled.
 946             $verified_actions++;
 947
 948         } else {
 949             l(LL_VERBOSE_FAILURE,
 950               "Ooops. '$sticky_action' is not among the final results.");
 951         }
 952     }
 953
 954     return $verified_actions == @sticky_actions;
 955 }
 956
 957 sub get_final_results ($) {
 958
 959     my $url = shift;
 960     my $curl_parameters = '';
 961     my %final_results = ();
 962     my $final_results_reached = 0;
 963
 964     die "Unacceptable characters in $url" if $url =~ m@[\\'"]@;
 965     # XXX: should be URL-encoded properly
 966     $url =~ s@%@%25@g;
 967     $url =~ s@\s@%20@g;
 968     $url =~ s@&@%26@g;
 969     $url =~ s@:@%3A@g;
 970     $url =~ s@/@%2F@g;
 971
 972     $curl_parameters .= quote(PRIVOXY_CGI_URL . 'show-url-info?url=' . $url);
 973
 974     foreach (@{get_cgi_page_or_else($curl_parameters)}) {
 975
 976         $final_results_reached = 1 if (m@<h2>Final results:</h2>@);
 977
 978         next unless ($final_results_reached);
 979         last if (m@</td>@);
 980
 981         # Privoxy versions before 3.0.16 add a space
 982         # between action name and parameters, therefore
 983         # the " ?".
 984         if (m@<br>([-+])<a.*>([^>]*)</a>(?: ?(\{.*\}))?@) {
 985             my $action = $1.$2;
 986             my $parameter = $3;
 987
 988             if (defined $parameter) {
 989                 # In case the caller needs to check
 990                 # the action and its parameter
 991                 $final_results{$action . $parameter} = 1;
 992             }
 993             # In case the action doesn't have parameters
 994             # or the caller doesn't care for the parameter.
 995             $final_results{$action} = 1;
 996         }
 997     }
 998
 999     return \%final_results;
1000 }
1001
1002 sub check_status_code_result ($$) {
1003
1004     my $status_code = shift;
1005     my $expected_status_code = shift;
1006     my $result = 0;
1007
1008     unless (defined $status_code) {
1009
1010         # XXX: should probably be caught earlier.
1011         l(LL_VERBOSE_FAILURE,
1012           "Ooops. We expected status code " . $expected_status_code . ", but didn't get any status code at all.");
1013
1014     } elsif ($expected_status_code == $status_code) {
1015
1016         $result = 1;
1017         l(LL_VERBOSE_SUCCESS,
1018           "Yay. We expected status code " . $expected_status_code . ", and received: " . $status_code . '.');
1019
1020     } elsif (cli_option_is_set('fuzzer-feeding') and $status_code == 123) {
1021
1022         l(LL_VERBOSE_FAILURE,
1023           "Oh well. Status code lost while fuzzing. Can't check if it was " . $expected_status_code . '.');
1024
1025     } else {
1026
1027         l(LL_VERBOSE_FAILURE,
1028           "Ooops. We expected status code " . $expected_status_code . ", but received: " . $status_code . '.');
1029     }
1030
1031     return $result;
1032 }
1033
1034 sub execute_client_header_regression_test ($) {
1035
1036     my $test = shift;
1037     my $buffer_ref;
1038     my $header;
1039
1040     $buffer_ref = get_show_request_with_curl($test);
1041
1042     $header = get_header($buffer_ref, $test);
1043
1044     return check_header_result($test, $header);
1045 }
1046
1047 sub execute_server_header_regression_test ($) {
1048
1049     my $test = shift;
1050     my $buffer_ref;
1051     my $header;
1052
1053     $buffer_ref = get_head_with_curl($test);
1054
1055     $header = get_server_header($buffer_ref, $test);
1056
1057     return check_header_result($test, $header);
1058 }
1059
1060 sub interpret_result ($) {
1061     my $success = shift;
1062     return $success ? "Success" : "Failure";
1063 }
1064
1065 sub check_header_result ($$) {
1066
1067     my $test = shift;
1068     my $header = shift;
1069
1070     my $expect_header = $test->{'expect-header'};
1071     my $success = 0;
1072
1073     if ($expect_header eq 'NO CHANGE') {
1074
1075         $success = (defined($header) and $header eq $test->{'data'});
1076
1077         unless ($success) {
1078             $header = "REMOVAL" unless defined $header;
1079             l(LL_VERBOSE_FAILURE,
1080               "Ooops. Got: '" . $header . "' while expecting: '" . $expect_header . "'");
1081         }
1082
1083     } elsif ($expect_header eq 'REMOVAL') {
1084
1085         # XXX: Use more reliable check here and make sure
1086         # the header has a different name.
1087         $success = not (defined($header) and $header eq $test->{'data'});
1088
1089         unless ($success) {
1090             l(LL_VERBOSE_FAILURE,
1091               "Ooops. Expected removal but: '" . $header . "' is still there.");
1092         }
1093
1094     } elsif ($expect_header eq 'SOME CHANGE') {
1095
1096         $success = (defined($header) and $header ne $test->{'data'});
1097
1098         unless  ($success) {
1099             $header = "REMOVAL" unless defined $header;
1100             l(LL_VERBOSE_FAILURE,
1101               "Ooops. Got: '" . $header . "' while expecting: SOME CHANGE");
1102         }
1103
1104     } else {
1105
1106         $success = (defined($header) and $header eq $expect_header);
1107
1108         unless ($success) {
1109             $header = "No matching header" unless defined $header; # XXX: No header detected to be precise
1110             l(LL_VERBOSE_FAILURE,
1111               "Ooops. Got: '" . $header . "' while expecting: '" . $expect_header . "'");
1112         }
1113     }
1114     return $success;
1115 }
1116
1117 sub get_header_name ($) {
1118
1119     my $header = shift;
1120
1121     $header =~ s@(.*?: ).*@$1@;
1122
1123     return $header;
1124 }
1125
1126 sub get_header ($$) {
1127
1128     our $filtered_request = '';
1129
1130     my $buffer_ref = shift;
1131     my $test = shift;
1132
1133     my @buffer = @{$buffer_ref};
1134
1135     my $expect_header = $test->{'expect-header'};
1136
1137     die "get_header called with no expect header" unless defined $expect_header;
1138
1139     my $line;
1140     my $processed_request_reached = 0;
1141     my $read_header = 0;
1142     my $processed_request = '';
1143     my $header;
1144     my $header_to_get;
1145
1146     if ($expect_header eq 'REMOVAL'
1147      or $expect_header eq 'NO CHANGE'
1148      or $expect_header eq 'SOME CHANGE') {
1149
1150         $expect_header = $test->{'data'};
1151     }
1152
1153     $header_to_get = get_header_name($expect_header);
1154
1155     foreach (@buffer) {
1156
1157         # Skip everything before the Processed request
1158         if (/Processed Request/) {
1159             $processed_request_reached = 1;
1160             next;
1161         }
1162         next unless $processed_request_reached;
1163
1164         # End loop after the Processed request
1165         last if (/<\/pre>/);
1166
1167         # Ditch tags and leading/trailing white space.
1168         s@^\s*<.*?>@@g;
1169         s@\s*$@@g;
1170
1171         # Decode characters we care about.
1172         s@&quot;@"@g;
1173
1174         $filtered_request .=  "\n" . $_;
1175
1176         if (/^$header_to_get/) {
1177             $read_header = 1;
1178             $header = $_;
1179             last;
1180         }
1181     }
1182
1183     return $header;
1184 }
1185
1186 sub get_server_header ($$) {
1187
1188     my $buffer_ref = shift;
1189     my $test = shift;
1190
1191     my @buffer = @{$buffer_ref};
1192
1193     my $expect_header = $test->{'expect-header'};
1194     my $header;
1195     my $header_to_get;
1196
1197     # XXX: Should be caught before starting to test.
1198     log_and_die("No expect header for test " . $test->{'number'})
1199         unless defined $expect_header;
1200
1201     if ($expect_header eq 'REMOVAL'
1202      or $expect_header eq 'NO CHANGE'
1203      or $expect_header eq 'SOME CHANGE') {
1204
1205         $expect_header = $test->{'data'};
1206     }
1207
1208     $header_to_get = get_header_name($expect_header);
1209
1210     foreach (@buffer) {
1211
1212         # XXX: should probably verify that the request
1213         # was actually answered by Fellatio.
1214         if (/^$header_to_get/) {
1215             $header = $_;
1216             $header =~ s@\s*$@@g;
1217             last;
1218         }
1219     }
1220
1221     return $header;
1222 }
1223
1224 sub get_status_code ($) {
1225
1226     my $buffer_ref = shift;
1227     my @buffer = @{$buffer_ref};
1228
1229     foreach (@buffer) {
1230
1231         if (/^HTTP\/\d\.\d (\d{3})/) {
1232
1233             return $1;
1234
1235         } else {
1236
1237             return '123' if cli_option_is_set('fuzzer-feeding');
1238             chomp;
1239             log_and_die('Unexpected buffer line: "' . $_ . '"');
1240         }
1241     }
1242 }
1243
1244 sub get_test_keys () {
1245     return ('tag', 'data', 'expect-header', 'ignore');
1246 }
1247
1248 # XXX: incomplete
1249 sub test_content_as_string ($) {
1250
1251     my $test = shift;
1252
1253     my $s = "\n\t";
1254
1255     foreach my $key (get_test_keys()) {
1256         $test->{$key} = 'Not set' unless (defined $test->{$key});
1257     }
1258
1259     $s .= 'Tag: ' . $test->{'tag'};
1260     $s .= "\n\t";
1261     $s .= 'Set header: ' . $test->{'data'}; # XXX: adjust for other test types
1262     $s .= "\n\t";
1263     $s .= 'Expected header: ' . $test->{'expect-header'};
1264     $s .= "\n\t";
1265     $s .= 'Ignore: ' . $test->{'ignore'};
1266
1267     return $s;
1268 }
1269
1270 sub fuzz_header($) {
1271     my $header = shift;
1272     my $white_space = int(rand(2)) - 1 ? " " : "\t";
1273
1274     $white_space = $white_space x (1 + int(rand(5)));
1275
1276     # Only fuzz white space before the first quoted token.
1277     # (Privoxy doesn't touch white space inside quoted tokens
1278     # and modifying it would cause the tests to fail).
1279     $header =~ s@(^[^"]*?)\s@$1$white_space@g;
1280
1281     return $header;
1282 }
1283
1284 ############################################################################
1285 #
1286 # HTTP fetch functions
1287 #
1288 ############################################################################
1289
1290 sub get_cgi_page_or_else ($) {
1291
1292     my $cgi_url = shift;
1293     my $content_ref = get_page_with_curl($cgi_url);
1294     my $status_code = get_status_code($content_ref);
1295
1296     if (200 != $status_code) {
1297
1298         my $log_message = "Failed to fetch Privoxy CGI Page. " .
1299                           "Received status code ". $status_code .
1300                           " while only 200 is acceptable.";
1301
1302         if (cli_option_is_set('fuzzer-feeding')) {
1303
1304             $log_message .= " Ignored due to fuzzer feeding.";
1305             l(LL_SOFT_ERROR, $log_message)
1306
1307         } else {
1308
1309             log_and_die($log_message);
1310         }
1311     }
1312
1313     return $content_ref;
1314 }
1315
1316 # XXX: misleading name
1317 sub get_show_request_with_curl ($) {
1318
1319     our $privoxy_cgi_url;
1320     my $test = shift;
1321
1322     my $curl_parameters = ' ';
1323     my $header = $test->{'data'};
1324
1325     if (cli_option_is_set('header-fuzzing')) {
1326         $header = fuzz_header($header);
1327     }
1328
1329     # Enable the action to test
1330     $curl_parameters .= '-H \'X-Privoxy-Control: ' . $test->{'tag'} . '\' ';
1331     # The header to filter
1332     $curl_parameters .= '-H \'' . $header . '\' ';
1333
1334     $curl_parameters .= ' ';
1335     $curl_parameters .= $privoxy_cgi_url;
1336     $curl_parameters .= 'show-request';
1337
1338     return get_cgi_page_or_else($curl_parameters);
1339 }
1340
1341 sub get_head_with_curl ($) {
1342
1343     our $fellatio_url = FELLATIO_URL;
1344     my $test = shift;
1345
1346     my $curl_parameters = ' ';
1347
1348     # Enable the action to test
1349     $curl_parameters .= '-H \'X-Privoxy-Control: ' . $test->{'tag'} . '\' ';
1350     # The header to filter
1351     $curl_parameters .= '-H \'X-Gimme-Head-With: ' . $test->{'data'} . '\' ';
1352     $curl_parameters .= '--head ';
1353
1354     $curl_parameters .= ' ';
1355     $curl_parameters .= $fellatio_url;
1356
1357     return get_page_with_curl($curl_parameters);
1358 }
1359
1360 sub get_page_with_curl ($) {
1361
1362     our $proxy;
1363
1364     my $parameters = shift;
1365     my @buffer;
1366     my $curl_line = CURL;
1367     my $retries_left = get_cli_option('retries') + 1;
1368     my $failure_reason;
1369
1370     if (defined $proxy) {
1371         $curl_line .= ' --proxy ' . quote($proxy);
1372     }
1373     # We want to see the HTTP status code
1374     $curl_line .= " --include ";
1375     # Let Privoxy emit two log messages less.
1376     $curl_line .= ' -H \'Proxy-Connection:\' ' unless $parameters =~ /Proxy-Connection:/;
1377     $curl_line .= ' -H \'Connection: close\' ' unless $parameters =~ /Connection:/;
1378     # We don't care about fetch statistic.
1379     $curl_line .= " -s ";
1380     # We do care about the failure reason if any.
1381     $curl_line .= " -S ";
1382     # We want to advertise ourselves
1383     $curl_line .= " --user-agent '" . PRT_VERSION . "' ";
1384     # We aren't too patient
1385     $curl_line .= " --max-time '" . get_cli_option('max-time') . "' ";
1386
1387     $curl_line .= $parameters;
1388     # XXX: still necessary?
1389     $curl_line .= ' 2>&1';
1390
1391     l(LL_PAGE_FETCHING, "Executing: " . $curl_line);
1392
1393     do {
1394         @buffer = `$curl_line`;
1395
1396         if ($?) {
1397             log_and_die("Executing '$curl_line' failed.") unless @buffer;
1398             $failure_reason = array_as_string(\@buffer);
1399             chomp $failure_reason;
1400             l(LL_SOFT_ERROR, "Fetch failure: '" . $failure_reason . $! ."'");
1401         }
1402     } while ($? && --$retries_left);
1403
1404     unless ($retries_left) {
1405         log_and_die("Running curl failed " . get_cli_option('retries') .
1406                     " times in a row. Last error: '" . $failure_reason . "'.");
1407     }
1408
1409     return \@buffer;
1410 }
1411
1412
1413 ############################################################################
1414 #
1415 # Log functions
1416 #
1417 ############################################################################
1418
1419 sub array_as_string ($) {
1420     my $array_ref = shift;
1421     my $string = '';
1422
1423     foreach (@{$array_ref}) {
1424         $string .= $_;
1425     }
1426
1427     return $string;
1428 }
1429
1430 sub show_test ($) {
1431     my $test = shift;
1432     log_message('Test is:' . test_content_as_string($test));
1433 }
1434
1435 # Conditional log
1436 sub l ($$) {
1437     our $log_level;
1438     my $this_level = shift;
1439     my $message = shift;
1440
1441     log_message($message) if ($log_level & $this_level);
1442 }
1443
1444 sub log_and_die ($) {
1445     my $message = shift;
1446
1447     log_message('Oh noes. ' . $message . ' Fatal error. Exiting.');
1448     exit;
1449 }
1450
1451 sub log_message ($) {
1452
1453     my $message = shift;
1454
1455     our $logfile;
1456     our $no_logging;
1457     our $leading_log_date;
1458     our $leading_log_time;
1459
1460     my $time_stamp = '';
1461     my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime time;
1462
1463     if ($leading_log_date || $leading_log_time) {
1464
1465         if ($leading_log_date) {
1466             $year += 1900;
1467             $mon  += 1;
1468             $time_stamp = sprintf("%i-%.2i-%.2i", $year, $mon, $mday);
1469         }
1470
1471         if ($leading_log_time) {
1472             $time_stamp .= ' ' if $leading_log_date;
1473             $time_stamp.= sprintf("%.2i:%.2i:%.2i", $hour, $min, $sec);
1474         }
1475
1476         $message = $time_stamp . ": " . $message;
1477     }
1478
1479     printf(STDERR "%s\n", $message);
1480 }
1481
1482 sub log_result ($$) {
1483
1484     our $verbose_test_description;
1485     our $filtered_request;
1486
1487     my $test = shift;
1488     my $result = shift;
1489     my $number = shift;
1490
1491     my $message = '';
1492
1493     $message .= interpret_result($result);
1494     $message .= " for test ";
1495     $message .= $number;
1496     $message .= '/';
1497     $message .= $test->{'number'};
1498     $message .= '/';
1499     $message .= $test->{'section-id'};
1500     $message .= '/';
1501     $message .= $test->{'regression-test-id'};
1502     $message .= '.';
1503
1504     if ($verbose_test_description) {
1505
1506         if ($test->{'type'} == CLIENT_HEADER_TEST) {
1507
1508             $message .= ' Header ';
1509             $message .= quote($test->{'data'});
1510             $message .= ' and tag ';
1511             $message .= quote($test->{'tag'});
1512
1513         } elsif ($test->{'type'} == SERVER_HEADER_TEST) {
1514
1515             $message .= ' Request Header ';
1516             $message .= quote($test->{'data'});
1517             $message .= ' and tag ';
1518             $message .= quote($test->{'tag'});
1519
1520         } elsif ($test->{'type'} == DUMB_FETCH_TEST) {
1521
1522             $message .= ' URL ';
1523             $message .= quote($test->{'data'});
1524             $message .= ' and expected status code ';
1525             $message .= quote($test->{'expected-status-code'});
1526
1527         } elsif ($test->{'type'} == TRUSTED_CGI_REQUEST) {
1528
1529             $message .= ' CGI URL ';
1530             $message .= quote($test->{'data'});
1531             $message .= ' and expected status code ';
1532             $message .= quote($test->{'expected-status-code'});
1533
1534         } elsif ($test->{'type'} == METHOD_TEST) {
1535
1536             $message .= ' HTTP method ';
1537             $message .= quote($test->{'data'});
1538             $message .= ' and expected status code ';
1539             $message .= quote($test->{'expected-status-code'});
1540
1541         } elsif ($test->{'type'} == BLOCK_TEST) {
1542
1543             $message .= ' Supposedly-blocked URL: ';
1544             $message .= quote($test->{'data'});
1545
1546         } elsif ($test->{'type'} == STICKY_ACTIONS_TEST) {
1547
1548             $message .= ' Sticky Actions: ';
1549             $message .= quote($test->{'sticky-actions'});
1550             $message .= ' and URL: ';
1551             $message .= quote($test->{'data'});
1552
1553         } elsif ($test->{'type'} == REDIRECT_TEST) {
1554
1555             $message .= ' Redirected URL: ';
1556             $message .= quote($test->{'data'});
1557             $message .= ' and redirect destination: ';
1558             $message .= quote($test->{'redirect destination'});
1559
1560         } else {
1561
1562             die "Incomplete support for test type " . $test->{'type'} .  " detected.";
1563         }
1564     }
1565
1566     log_message($message) if (!$result or cli_option_is_set('verbose'));
1567 }
1568
1569 sub quote ($) {
1570     my $s = shift;
1571     return '\'' . $s . '\'';
1572 }
1573
1574 sub print_version () {
1575     printf PRT_VERSION . "\n" . 'Copyright (C) 2007-2011 Fabian Keil <fk@fabiankeil.de>' . "\n";
1576 }
1577
1578 sub list_test_types () {
1579     my %test_types = (
1580         'Client header test'  => CLIENT_HEADER_TEST,
1581         'Server header test'  =>  2,
1582         'Dumb fetch test'     =>  3,
1583         'Method test'         =>  4,
1584         'Sticky action test'  =>  5,
1585         'Trusted CGI test'    =>  6,
1586         'Block test'          =>  7,
1587         'Redirect test'       => 108,
1588     );
1589
1590     print "\nThe supported test types and their default levels are:\n";
1591     foreach my $test_type (sort { $test_types{$a} <=> $test_types{$b} } keys %test_types) {
1592         printf "     %-20s -> %3.d\n", $test_type, $test_types{$test_type};
1593     }
1594 }
1595
1596 sub help () {
1597
1598     our %cli_options;
1599
1600     print_version();
1601
1602     print << "    EOF"
1603
1604 Options and their default values if they have any:
1605     [--debug $cli_options{'debug'}]
1606     [--forks $cli_options{'forks'}]
1607     [--fuzzer-address]
1608     [--fuzzer-feeding]
1609     [--help]
1610     [--header-fuzzing]
1611     [--level]
1612     [--local-test-file]
1613     [--loops $cli_options{'loops'}]
1614     [--max-level $cli_options{'max-level'}]
1615     [--max-time $cli_options{'max-time'}]
1616     [--min-level $cli_options{'min-level'}]
1617     [--privoxy-address]
1618     [--retries $cli_options{'retries'}]
1619     [--show-skipped-tests]
1620     [--sleep-time $cli_options{'sleep-time'}]
1621     [--test-number]
1622     [--verbose]
1623     [--version]
1624     EOF
1625     ;
1626
1627     list_test_types();
1628
1629     print << "    EOF"
1630
1631 Try "perldoc $0" for more information
1632     EOF
1633     ;
1634
1635     exit(0);
1636 }
1637
1638 sub init_cli_options () {
1639
1640     our %cli_options;
1641     our $log_level;
1642
1643     $cli_options{'debug'}     = $log_level;
1644     $cli_options{'forks'}     = CLI_FORKS;
1645     $cli_options{'loops'}     = CLI_LOOPS;
1646     $cli_options{'max-level'} = CLI_MAX_LEVEL;
1647     $cli_options{'max-time'}  = CLI_MAX_TIME;
1648     $cli_options{'min-level'} = CLI_MIN_LEVEL;
1649     $cli_options{'sleep-time'}= CLI_SLEEP_TIME;
1650     $cli_options{'retries'}   = CLI_RETRIES;
1651 }
1652
1653 sub parse_cli_options () {
1654
1655     our %cli_options;
1656     our $log_level;
1657
1658     init_cli_options();
1659
1660     GetOptions (
1661         'debug=i'            => \$cli_options{'debug'},
1662         'forks=i'            => \$cli_options{'forks'},
1663         'fuzzer-address=s'   => \$cli_options{'fuzzer-address'},
1664         'fuzzer-feeding'     => \$cli_options{'fuzzer-feeding'},
1665         'header-fuzzing'     => \$cli_options{'header-fuzzing'},
1666         'help'               => \&help,
1667         'level=i'            => \$cli_options{'level'},
1668         'local-test-file=s'  => \$cli_options{'local-test-file'},
1669         'loops=i'            => \$cli_options{'loops'},
1670         'max-level=i'        => \$cli_options{'max-level'},
1671         'max-time=i'         => \$cli_options{'max-time'},
1672         'min-level=i'        => \$cli_options{'min-level'},
1673         'privoxy-address=s'  => \$cli_options{'privoxy-address'},
1674         'retries=i'          => \$cli_options{'retries'},
1675         'show-skipped-tests' => \$cli_options{'show-skipped-tests'},
1676         'sleep-time=i'       => \$cli_options{'sleep-time'},
1677         'test-number=i'      => \$cli_options{'test-number'},
1678         'verbose'            => \$cli_options{'verbose'},
1679         'version'            => sub {print_version && exit(0)}
1680     ) or exit(1);
1681     $log_level |= $cli_options{'debug'};
1682 }
1683
1684 sub cli_option_is_set ($) {
1685
1686     our %cli_options;
1687     my $cli_option = shift;
1688
1689     return defined $cli_options{$cli_option};
1690 }
1691
1692 sub get_cli_option ($) {
1693
1694     our %cli_options;
1695     my $cli_option = shift;
1696
1697     die "Unknown CLI option: $cli_option" unless defined $cli_options{$cli_option};
1698
1699     return $cli_options{$cli_option};
1700 }
1701
1702 sub init_proxy_settings($) {
1703
1704     my $choice = shift;
1705     our $proxy = undef;
1706
1707     if (($choice eq 'fuzz-proxy') and cli_option_is_set('fuzzer-address')) {
1708         $proxy = get_cli_option('fuzzer-address');
1709     }
1710
1711     if ((not defined $proxy) or ($choice eq 'vanilla-proxy')) {
1712
1713         if (cli_option_is_set('privoxy-address')) {
1714             $proxy .=  get_cli_option('privoxy-address');
1715         }
1716     }
1717 }
1718
1719 sub start_forks($) {
1720     my $forks = shift;
1721
1722     log_and_die("Invalid --fork value: " . $forks . ".") if ($forks < 0);
1723
1724     foreach my $fork (1 .. $forks) {
1725         log_message("Starting fork $fork");
1726         my $pid = fork();
1727         if (defined $pid && !$pid) {
1728             return;
1729         }
1730     }
1731 }
1732
1733 sub main () {
1734
1735     init_our_variables();
1736     parse_cli_options();
1737     init_proxy_settings('vanilla-proxy');
1738     load_regression_tests();
1739     init_proxy_settings('fuzz-proxy');
1740     start_forks(get_cli_option('forks')) if cli_option_is_set('forks');
1741     execute_regression_tests();
1742 }
1743
1744 main();
1745
1746 =head1 NAME
1747
1748 B<privoxy-regression-test> - A regression test "framework" for Privoxy.
1749
1750 =head1 SYNOPSIS
1751
1752 B<privoxy-regression-test> [B<--debug bitmask>] [B<--forks> forks]
1753 [B<--fuzzer-feeding>] [B<--fuzzer-feeding>] [B<--help>] [B<--level level>]
1754 [B<--local-test-file testfile>] [B<--loops count>] [B<--max-level max-level>]
1755 [B<--max-time max-time>] [B<--min-level min-level>] B<--privoxy-address proxy-address>
1756 [B<--retries retries>] [B<--test-number test-number>]
1757 [B<--show-skipped-tests>] [B<--sleep-time> seconds] [B<--verbose>]
1758 [B<--version>]
1759
1760 =head1 DESCRIPTION
1761
1762 Privoxy-Regression-Test is supposed to one day become
1763 a regression test suite for Privoxy. It's not quite there
1764 yet, however, and can currently only test header actions,
1765 check the returned status code for requests to arbitrary
1766 URLs and verify which actions are applied to them.
1767
1768 Client header actions are tested by requesting
1769 B<http://p.p/show-request> and checking whether
1770 or not Privoxy modified the original request as expected.
1771
1772 The original request contains both the header the action-to-be-tested
1773 acts upon and an additional tagger-triggering header that enables
1774 the action to test.
1775
1776 Applied actions are checked through B<http://p.p/show-url-info>.
1777
1778 =head1 CONFIGURATION FILE SYNTAX
1779
1780 Privoxy-Regression-Test's configuration is embedded in
1781 Privoxy action files and loaded through Privoxy's web interface.
1782
1783 It makes testing a Privoxy version running on a remote system easier
1784 and should prevent you from updating your tests without updating Privoxy's
1785 configuration accordingly.
1786
1787 A client-header-action test section looks like this:
1788
1789     # Set Header    = Referer: http://www.example.org.zwiebelsuppe.exit/
1790     # Expect Header = Referer: http://www.example.org/
1791     {+client-header-filter{hide-tor-exit-notation} -hide-referer}
1792     TAG:^client-header-filter\{hide-tor-exit-notation\}$
1793
1794 The example above causes Privoxy-Regression-Test to set
1795 the header B<Referer: http://www.example.org.zwiebelsuppe.exit/>
1796 and to expect it to be modified to
1797 B<Referer: http://www.example.org/>.
1798
1799 When testing this section, Privoxy-Regression-Test will set the header
1800 B<X-Privoxy-Control: client-header-filter{hide-tor-exit-notation}>
1801 causing the B<privoxy-control> tagger to create the tag
1802 B<client-header-filter{hide-tor-exit-notation}> which will finally
1803 cause Privoxy to enable the action section.
1804
1805 Note that the actions itself are only used by Privoxy,
1806 Privoxy-Regression-Test ignores them and will be happy
1807 as long as the expectations are satisfied.
1808
1809 A fetch test looks like this:
1810
1811     # Fetch Test = http://p.p/user-manual
1812     # Expect Status Code = 302
1813
1814 It tells Privoxy-Regression-Test to request B<http://p.p/user-manual>
1815 and to expect a response with the HTTP status code B<302>. Obviously that's
1816 not a very thorough test and mainly useful to get some code coverage
1817 for Valgrind or to verify that the templates are installed correctly.
1818
1819 If you want to test CGI pages that require a trusted
1820 referer, you can use:
1821
1822     # Trusted CGI Request = http://p.p/edit-actions
1823
1824 It works like ordinary fetch tests, but sets the referer
1825 header to a trusted value.
1826
1827 If no explicit status code expectation is set, B<200> is used.
1828
1829 To verify that a URL is blocked, use:
1830
1831     # Blocked URL = http://www.example.com/blocked
1832
1833 To verify that a specific set of actions is applied to an URL, use:
1834
1835     # Sticky Actions = +block{foo} +handle-as-empty-document -handle-as-image
1836     # URL = http://www.example.org/my-first-url
1837
1838 The sticky actions will be checked for all URLs below it
1839 until the next sticky actions directive.
1840
1841 To verify that requests for a URL get redirected, use:
1842
1843     # Redirected URL = http://www.example.com/redirect-me
1844     # Redirect Destination = http://www.example.org/redirected
1845
1846 =head1 TEST LEVELS
1847
1848 All tests have test levels to let the user
1849 control which ones to execute (see I<OPTIONS> below).
1850 Test levels are either set with the B<Level> directive,
1851 or implicitly through the test type.
1852
1853 Redirect tests default to level 108, block tests to level 7,
1854 fetch tests to level 6, "Sticky Actions" tests default to
1855 level 5, tests for trusted CGI requests to level 3 and
1856 client-header-action tests to level 1.
1857
1858 The current redirect test level is above the default
1859 max-level value as failed tests will result in outgoing
1860 connections. Use the B<--max-level> option to run them
1861 as well.
1862
1863 =head1 OPTIONS
1864
1865 B<--debug bitmask> Add the bitmask provided as integer
1866 to the debug settings.
1867
1868 B<--forks forks> Number of forks to start before executing
1869 the regression tests. This is mainly useful for stress-testing.
1870
1871 B<--fuzzer-address> Listening address used when executing
1872 the regression tests. Useful to make sure that the requests
1873 to load the regression tests don't fail due to fuzzing.
1874
1875 B<--fuzzer-feeding> Ignore some errors that would otherwise
1876 cause Privoxy-Regression-Test to abort the test because
1877 they shouldn't happen in normal operation. This option is
1878 intended to be used if Privoxy-Regression-Test is only
1879 used to feed a fuzzer in which case there's a high chance
1880 that Privoxy gets an invalid request and returns an error
1881 message.
1882
1883 B<--help> Shows available command line options.
1884
1885 B<--header-fuzzing> Modifies linear white space in
1886 headers in a way that should not affect the test result.
1887
1888 B<--level level> Only execute tests with the specified B<level>.
1889
1890 B<--local-test-file test-file> Do not get the tests
1891 through Privoxy's web interface, but use a single local
1892 file. Not recommended for testing Privoxy, but can be useful
1893 to "misappropriate" Privoxy-Regression-Test to test other
1894 stuff, like webserver configurations.
1895
1896 B<--loop count> Loop through the regression tests B<count> times.
1897 Useful to feed a fuzzer, or when doing stress tests with
1898 several Privoxy-Regression-Test instances running at the same
1899 time.
1900
1901 B<--max-level max-level> Only execute tests with a B<level>
1902 below or equal to the numerical B<max-level>.
1903
1904 B<--max-time max-time> Give Privoxy B<max-time> seconds
1905 to return data. Increasing the default may make sense when
1906 Privoxy is run through Valgrind, decreasing the default may
1907 make sense when Privoxy-Regression-Test is used to feed
1908 a fuzzer.
1909
1910 B<--min-level min-level> Only execute tests with a B<level>
1911 above or equal to the numerical B<min-level>.
1912
1913 B<--privoxy-address proxy-address> Privoxy's listening address.
1914 If it's not set, the value of the environment variable http_proxy
1915 will be used. B<proxy-address> has to be specified in http_proxy
1916 syntax.
1917
1918 B<--retries retries> Retry B<retries> times.
1919
1920 B<--test-number test-number> Only run the test with the specified
1921 number.
1922
1923 B<--show-skipped-tests> Log skipped tests even if verbose mode is off.
1924
1925 B<--sleep-time seconds> Wait B<seconds> between tests. Useful when
1926 debugging issues with systems that don't log with millisecond precision.
1927
1928 B<--verbose> Log successful tests as well. By default only
1929 the failures are logged.
1930
1931 B<--version> Print version and exit.
1932
1933 The second dash is optional, options can be shortened,
1934 as long as there are no ambiguities.
1935
1936 =head1 PRIVOXY CONFIGURATION
1937
1938 Privoxy-Regression-Test is shipped with B<regression-tests.action>
1939 which aims to test all official client-header modifying actions
1940 and can be used to verify that the templates and the user manual
1941 files are installed correctly.
1942
1943 To use it, it has to be copied in Privoxy's configuration
1944 directory, and afterwards referenced in Privoxy's configuration
1945 file with the line:
1946
1947     actionsfile regression-tests.action
1948
1949 In general, its tests are supposed to work without changing
1950 any other action files, unless you already added lots of
1951 taggers yourself. If you are using taggers that cause problems,
1952 you might have to temporary disable them for Privoxy's CGI pages.
1953
1954 Some of the regression tests rely on Privoxy features that
1955 may be disabled in your configuration. Tests with a level below
1956 7 are supposed to work with all Privoxy configurations (provided
1957 you didn't build with FEATURE_GRACEFUL_TERMINATION).
1958
1959 Tests with level 9 require Privoxy to deliver the User Manual,
1960 tests with level 12 require the CGI editor to be enabled.
1961
1962 =head1 CAVEATS
1963
1964 Expect the configuration file syntax to change with future releases.
1965
1966 =head1 LIMITATIONS
1967
1968 As Privoxy's B<show-request> page only shows client headers,
1969 Privoxy-Regression-Test can't use it to test Privoxy actions
1970 that modify server headers.
1971
1972 As Privoxy-Regression-Test relies on Privoxy's tag feature to
1973 control the actions to test, it currently only works with
1974 Privoxy 3.0.7 or later.
1975
1976 At the moment Privoxy-Regression-Test fetches Privoxy's
1977 configuration page through I<curl>(1), therefore you have to
1978 have I<curl> installed, otherwise you won't be able to run
1979 Privoxy-Regression-Test in a meaningful way.
1980
1981 =head1 SEE ALSO
1982
1983 privoxy(1) curl(1)
1984
1985 =head1 AUTHOR
1986
1987 Fabian Keil <fk@fabiankeil.de>
1988
1989 =cut