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.58 2009/10/29 16:46:42 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         # 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 help () {
1430
1431     our %cli_options;
1432
1433     print_version();
1434
1435     print << "    EOF"
1436
1437 Options and their default values if they have any:
1438     [--debug $cli_options{'debug'}]
1439     [--forks $cli_options{'forks'}]
1440     [--fuzzer-address]
1441     [--fuzzer-feeding]
1442     [--help]
1443     [--header-fuzzing]
1444     [--level]
1445     [--loops $cli_options{'loops'}]
1446     [--max-level $cli_options{'max-level'}]
1447     [--max-time $cli_options{'max-time'}]
1448     [--min-level $cli_options{'min-level'}]
1449     [--privoxy-address]
1450     [--retries $cli_options{'retries'}]
1451     [--show-skipped-tests]
1452     [--test-number]
1453     [--verbose]
1454     [--version]
1455 see "perldoc $0" for more information
1456     EOF
1457     ;
1458     exit(0);
1459 }
1460
1461 sub init_cli_options () {
1462
1463     our %cli_options;
1464     our $log_level;
1465
1466     $cli_options{'debug'}     = $log_level;
1467     $cli_options{'forks'}     = CLI_FORKS;
1468     $cli_options{'loops'}     = CLI_LOOPS;
1469     $cli_options{'max-level'} = CLI_MAX_LEVEL;
1470     $cli_options{'max-time'}  = CLI_MAX_TIME;
1471     $cli_options{'min-level'} = CLI_MIN_LEVEL;
1472     $cli_options{'retries'}   = CLI_RETRIES;
1473 }
1474
1475 sub parse_cli_options () {
1476
1477     our %cli_options;
1478     our $log_level;
1479
1480     init_cli_options();
1481
1482     GetOptions (
1483         'debug=s'            => \$cli_options{'debug'},
1484         'forks=s'            => \$cli_options{'forks'},
1485         'fuzzer-address=s'   => \$cli_options{'fuzzer-address'},
1486         'fuzzer-feeding'     => \$cli_options{'fuzzer-feeding'},
1487         'header-fuzzing'     => \$cli_options{'header-fuzzing'},
1488         'help'               => \&help,
1489         'level=s'            => \$cli_options{'level'},
1490         'loops=s'            => \$cli_options{'loops'},
1491         'max-level=s'        => \$cli_options{'max-level'},
1492         'max-time=s'         => \$cli_options{'max-time'},
1493         'min-level=s'        => \$cli_options{'min-level'},
1494         'privoxy-address=s'  => \$cli_options{'privoxy-address'},
1495         'retries=s'          => \$cli_options{'retries'},
1496         'show-skipped-tests' => \$cli_options{'show-skipped-tests'},
1497         'test-number=s'      => \$cli_options{'test-number'},
1498         'verbose'            => \$cli_options{'verbose'},
1499         'version'            => sub {print_version && exit(0)}
1500     );
1501     $log_level |= $cli_options{'debug'};
1502 }
1503
1504 sub cli_option_is_set ($) {
1505
1506     our %cli_options;
1507     my $cli_option = shift;
1508
1509     return defined $cli_options{$cli_option};
1510 }
1511
1512 sub get_cli_option ($) {
1513
1514     our %cli_options;
1515     my $cli_option = shift;
1516
1517     die "Unknown CLI option: $cli_option" unless defined $cli_options{$cli_option};
1518
1519     return $cli_options{$cli_option};
1520 }
1521
1522 sub init_proxy_settings($) {
1523
1524     my $choice = shift;
1525     our $proxy = undef;
1526
1527     if (($choice eq 'fuzz-proxy') and cli_option_is_set('fuzzer-address')) {
1528         $proxy = get_cli_option('fuzzer-address');
1529     }
1530
1531     if ((not defined $proxy) or ($choice eq 'vanilla-proxy')) {
1532
1533         if (cli_option_is_set('privoxy-address')) {
1534             $proxy .=  get_cli_option('privoxy-address');
1535         }
1536     }
1537 }
1538
1539 sub start_forks($) {
1540     my $forks = shift;
1541
1542     log_and_die("Invalid --fork value: " . $forks . ".") if ($forks < 0);
1543
1544     foreach my $fork (1 .. $forks) {
1545         log_message("Starting fork $fork");
1546         my $pid = fork();
1547         if (defined $pid && !$pid) {
1548             return;
1549         }
1550     }
1551 }
1552
1553 sub main () {
1554
1555     init_our_variables();
1556     parse_cli_options();
1557     init_proxy_settings('vanilla-proxy');
1558     load_regressions_tests();
1559     init_proxy_settings('fuzz-proxy');
1560     start_forks(get_cli_option('forks')) if cli_option_is_set('forks');
1561     execute_regression_tests();
1562 }
1563
1564 main();
1565
1566 =head1 NAME
1567
1568 B<privoxy-regression-test> - A regression test "framework" for Privoxy.
1569
1570 =head1 SYNOPSIS
1571
1572 B<privoxy-regression-test> [B<--debug bitmask>] [B<--forks> forks]
1573 [B<--fuzzer-feeding>] [B<--fuzzer-feeding>] [B<--help>] [B<--level level>]
1574 [B<--loops count>] [B<--max-level max-level>] [B<--max-time max-time>]
1575 [B<--min-level min-level>] B<--privoxy-address proxy-address>
1576 [B<--retries retries>] [B<--test-number test-number>]
1577 [B<--show-skipped-tests>] [B<--verbose>]
1578 [B<--version>]
1579
1580 =head1 DESCRIPTION
1581
1582 Privoxy-Regression-Test is supposed to one day become
1583 a regression test suite for Privoxy. It's not quite there
1584 yet, however, and can currently only test header actions,
1585 check the returned status code for requests to arbitrary
1586 URLs and verify which actions are applied to them.
1587
1588 Client header actions are tested by requesting
1589 B<http://p.p/show-request> and checking whether
1590 or not Privoxy modified the original request as expected.
1591
1592 The original request contains both the header the action-to-be-tested
1593 acts upon and an additional tagger-triggering header that enables
1594 the action to test.
1595
1596 Applied actions are checked through B<http://p.p/show-url-info>.
1597
1598 =head1 CONFIGURATION FILE SYNTAX
1599
1600 Privoxy-Regression-Test's configuration is embedded in
1601 Privoxy action files and loaded through Privoxy's web interface.
1602
1603 It makes testing a Privoxy version running on a remote system easier
1604 and should prevent you from updating your tests without updating Privoxy's
1605 configuration accordingly.
1606
1607 A client-header-action test section looks like this:
1608
1609     # Set Header    = Referer: http://www.example.org.zwiebelsuppe.exit/
1610     # Expect Header = Referer: http://www.example.org/
1611     {+client-header-filter{hide-tor-exit-notation} -hide-referer}
1612     TAG:^client-header-filter\{hide-tor-exit-notation\}$
1613
1614 The example above causes Privoxy-Regression-Test to set
1615 the header B<Referer: http://www.example.org.zwiebelsuppe.exit/>
1616 and to expect it to be modified to
1617 B<Referer: http://www.example.org/>.
1618
1619 When testing this section, Privoxy-Regression-Test will set the header
1620 B<X-Privoxy-Control: client-header-filter{hide-tor-exit-notation}>
1621 causing the B<privoxy-control> tagger to create the tag
1622 B<client-header-filter{hide-tor-exit-notation}> which will finally
1623 cause Privoxy to enable the action section.
1624
1625 Note that the actions itself are only used by Privoxy,
1626 Privoxy-Regression-Test ignores them and will be happy
1627 as long as the expectations are satisfied.
1628
1629 A fetch test looks like this:
1630
1631     # Fetch Test = http://p.p/user-manual
1632     # Expect Status Code = 302
1633
1634 It tells Privoxy-Regression-Test to request B<http://p.p/user-manual>
1635 and to expect a response with the HTTP status code B<302>. Obviously that's
1636 not a very thorough test and mainly useful to get some code coverage
1637 for Valgrind or to verify that the templates are installed correctly.
1638
1639 If you want to test CGI pages that require a trusted
1640 referer, you can use:
1641
1642     # Trusted CGI Request = http://p.p/edit-actions
1643
1644 It works like ordinary fetch tests, but sets the referer
1645 header to a trusted value.
1646
1647 If no explicit status code expectation is set, B<200> is used.
1648
1649 To verify that a URL is blocked, use:
1650
1651     # Blocked URL = http://www.example.com/blocked
1652
1653 To verify that a specific set of actions is applied to an URL, use:
1654
1655     # Sticky Actions = +block{foo} +handle-as-empty-document -handle-as-image
1656     # URL = http://www.example.org/my-first-url
1657
1658 The sticky actions will be checked for all URLs below it
1659 until the next sticky actions directive.
1660
1661 To verify that requests for a URL get redirected, use:
1662
1663     # Redirected URL = http://www.example.com/redirect-me
1664     # Redirect Destination = http://www.example.org/redirected
1665
1666 =head1 TEST LEVELS
1667
1668 All tests have test levels to let the user
1669 control which ones to execute (see I<OPTIONS> below).
1670 Test levels are either set with the B<Level> directive,
1671 or implicitly through the test type.
1672
1673 Redirect tests default to level 108, block tests to level 7,
1674 fetch tests to level 6, "Sticky Actions" tests default to
1675 level 5, tests for trusted CGI requests to level 3 and
1676 client-header-action tests to level 1.
1677
1678 The current redirect test level is above the default
1679 max-level value as failed tests will result in outgoing
1680 connections. Use the B<--max-level> option to run them
1681 as well.
1682
1683 =head1 OPTIONS
1684
1685 B<--debug bitmask> Add the bitmask provided as integer
1686 to the debug settings.
1687
1688 B<--forks forks> Number of forks to start before executing
1689 the regression tests. This is mainly useful for stress-testing.
1690
1691 B<--fuzzer-address> Listening address used when executing
1692 the regression tests. Useful to make sure that the requests
1693 to load the regression tests don't fail due to fuzzing.
1694
1695 B<--fuzzer-feeding> Ignore some errors that would otherwise
1696 cause Privoxy-Regression-Test to abort the test because
1697 they shouldn't happen in normal operation. This option is
1698 intended to be used if Privoxy-Regression-Test is only
1699 used to feed a fuzzer in which case there's a high chance
1700 that Privoxy gets an invalid request and returns an error
1701 message.
1702
1703 B<--help> Shows available command line options.
1704
1705 B<--header-fuzzing> Modifies linear white space in
1706 headers in a way that should not affect the test result.
1707
1708 B<--level level> Only execute tests with the specified B<level>.
1709
1710 B<--loop count> Loop through the regression tests B<count> times.
1711 Useful to feed a fuzzer, or when doing stress tests with
1712 several Privoxy-Regression-Test instances running at the same
1713 time.
1714
1715 B<--max-level max-level> Only execute tests with a B<level>
1716 below or equal to the numerical B<max-level>.
1717
1718 B<--max-time max-time> Give Privoxy B<max-time> seconds
1719 to return data. Increasing the default may make sense when
1720 Privoxy is run through Valgrind, decreasing the default may
1721 make sense when Privoxy-Regression-Test is used to feed
1722 a fuzzer.
1723
1724 B<--min-level min-level> Only execute tests with a B<level>
1725 above or equal to the numerical B<min-level>.
1726
1727 B<--privoxy-address proxy-address> Privoxy's listening address.
1728 If it's not set, the value of the environment variable http_proxy
1729 will be used. B<proxy-address> has to be specified in http_proxy
1730 syntax.
1731
1732 B<--retries retries> Retry B<retries> times.
1733
1734 B<--test-number test-number> Only run the test with the specified
1735 number.
1736
1737 B<--show-skipped-tests> Log skipped tests even if verbose mode is off.
1738
1739 B<--verbose> Log succesful tests as well. By default only
1740 the failures are logged.
1741
1742 B<--version> Print version and exit.
1743
1744 The second dash is optional, options can be shortened,
1745 as long as there are no ambiguities.
1746
1747 =head1 PRIVOXY CONFIGURATION
1748
1749 Privoxy-Regression-Test is shipped with B<regression-tests.action>
1750 which aims to test all official client-header modifying actions
1751 and can be used to verify that the templates and the user manual
1752 files are installed correctly.
1753
1754 To use it, it has to be copied in Privoxy's configuration
1755 directory, and afterwards referenced in Privoxy's configuration
1756 file with the line:
1757
1758     actionsfile regression-tests.action
1759
1760 In general, its tests are supposed to work without changing
1761 any other action files, unless you already added lots of
1762 taggers yourself. If you are using taggers that cause problems,
1763 you might have to temporary disable them for Privoxy's CGI pages.
1764
1765 Some of the regression tests rely on Privoxy features that
1766 may be disabled in your configuration. Tests with a level below
1767 7 are supposed to work with all Privoxy configurations (provided
1768 you didn't build with FEATURE_GRACEFUL_TERMINATION).
1769
1770 Tests with level 9 require Privoxy to deliver the User Manual,
1771 tests with level 12 require the CGI editor to be enabled.
1772
1773 =head1 CAVEATS
1774
1775 Expect the configuration file syntax to change with future releases.
1776
1777 =head1 LIMITATIONS
1778
1779 As Privoxy's B<show-request> page only shows client headers,
1780 Privoxy-Regression-Test can't use it to test Privoxy actions
1781 that modify server headers.
1782
1783 As Privoxy-Regression-Test relies on Privoxy's tag feature to
1784 control the actions to test, it currently only works with
1785 Privoxy 3.0.7 or later.
1786
1787 At the moment Privoxy-Regression-Test fetches Privoxy's
1788 configuration page through I<curl>(1), therefore you have to
1789 have I<curl> installed, otherwise you won't be able to run
1790 Privoxy-Regression-Test in a meaningful way.
1791
1792 =head1 SEE ALSO
1793
1794 privoxy(1) curl(1)
1795
1796 =head1 AUTHOR
1797
1798 Fabian Keil <fk@fabiankeil.de>
1799
1800 =cut