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