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