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