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