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