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