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