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