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