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.212 2011/07/17 13:49:52 fk 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 .= '--request ' . quote($test->{method}) . ' ';
 747     }
 748     if ($test->{type} == TRUSTED_CGI_REQUEST) {
 749         $curl_parameters .= '--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     if (defined $proxy) {
1214         $curl_line .= ' --proxy ' . quote($proxy);
1215     }
1216     # We want to see the HTTP status code
1217     $curl_line .= " --include ";
1218     # Let Privoxy emit two log messages less.
1219     $curl_line .= ' -H \'Proxy-Connection:\' ' unless $parameters =~ /Proxy-Connection:/;
1220     $curl_line .= ' -H \'Connection: close\' ' unless $parameters =~ /Connection:/;
1221     # We don't care about fetch statistic.
1222     $curl_line .= " -s ";
1223     # We do care about the failure reason if any.
1224     $curl_line .= " -S ";
1225     # We want to advertise ourselves
1226     $curl_line .= " --user-agent '" . PRT_VERSION . "' ";
1227     # We aren't too patient
1228     $curl_line .= " --max-time '" . get_cli_option('max-time') . "' ";
1229
1230     $curl_line .= $parameters;
1231     # XXX: still necessary?
1232     $curl_line .= ' 2>&1';
1233
1234     l(LL_PAGE_FETCHING, "Executing: " . $curl_line);
1235
1236     do {
1237         @buffer = `$curl_line`;
1238
1239         if ($?) {
1240             log_and_die("Executing '$curl_line' failed.") unless @buffer;
1241             $failure_reason = array_as_string(\@buffer);
1242             chomp $failure_reason;
1243             l(LL_SOFT_ERROR, "Fetch failure: '" . $failure_reason . $! ."'");
1244         }
1245     } while ($? && --$retries_left);
1246
1247     unless ($retries_left) {
1248         log_and_die("Running curl failed " . get_cli_option('retries') .
1249                     " times in a row. Last error: '" . $failure_reason . "'.");
1250     }
1251
1252     return \@buffer;
1253 }
1254
1255
1256 ############################################################################
1257 #
1258 # Log functions
1259 #
1260 ############################################################################
1261
1262 sub array_as_string ($) {
1263     my $array_ref = shift;
1264     my $string = '';
1265
1266     foreach (@{$array_ref}) {
1267         $string .= $_;
1268     }
1269
1270     return $string;
1271 }
1272
1273 sub show_test ($) {
1274     my $test = shift;
1275     log_message('Test is:' . test_content_as_string($test));
1276 }
1277
1278 # Conditional log
1279 sub l ($$) {
1280     our $log_level;
1281     my $this_level = shift;
1282     my $message = shift;
1283
1284     log_message($message) if ($log_level & $this_level);
1285 }
1286
1287 sub log_and_die ($) {
1288     my $message = shift;
1289
1290     log_message('Oh noes. ' . $message . ' Fatal error. Exiting.');
1291     exit;
1292 }
1293
1294 sub log_message ($) {
1295
1296     my $message = shift;
1297
1298     our $logfile;
1299     our $no_logging;
1300     our $leading_log_date;
1301     our $leading_log_time;
1302
1303     my $time_stamp = '';
1304     my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime time;
1305
1306     if ($leading_log_date || $leading_log_time) {
1307
1308         if ($leading_log_date) {
1309             $year += 1900;
1310             $mon  += 1;
1311             $time_stamp = sprintf("%i-%.2i-%.2i", $year, $mon, $mday);
1312         }
1313
1314         if ($leading_log_time) {
1315             $time_stamp .= ' ' if $leading_log_date;
1316             $time_stamp.= sprintf("%.2i:%.2i:%.2i", $hour, $min, $sec);
1317         }
1318
1319         $message = $time_stamp . ": " . $message;
1320     }
1321
1322     printf(STDERR "%s\n", $message);
1323 }
1324
1325 sub log_result ($$) {
1326
1327     our $verbose_test_description;
1328     our $filtered_request;
1329
1330     my $test = shift;
1331     my $result = shift;
1332     my $number = shift;
1333
1334     my $message = '';
1335
1336     $message .= interpret_result($result);
1337     $message .= " for test ";
1338     $message .= $number;
1339     $message .= '/';
1340     $message .= $test->{'number'};
1341     $message .= '/';
1342     $message .= $test->{'section-id'};
1343     $message .= '/';
1344     $message .= $test->{'regression-test-id'};
1345     $message .= '.';
1346
1347     if ($verbose_test_description) {
1348
1349         if ($test->{'type'} == CLIENT_HEADER_TEST) {
1350
1351             $message .= ' Header ';
1352             $message .= quote($test->{'data'});
1353             $message .= ' and tag ';
1354             $message .= quote($test->{'tag'});
1355
1356         } elsif ($test->{'type'} == SERVER_HEADER_TEST) {
1357
1358             $message .= ' Request Header ';
1359             $message .= quote($test->{'data'});
1360             $message .= ' and tag ';
1361             $message .= quote($test->{'tag'});
1362
1363         } elsif ($test->{'type'} == DUMB_FETCH_TEST) {
1364
1365             $message .= ' URL ';
1366             $message .= quote($test->{'data'});
1367             $message .= ' and expected status code ';
1368             $message .= quote($test->{'expected-status-code'});
1369
1370         } elsif ($test->{'type'} == TRUSTED_CGI_REQUEST) {
1371
1372             $message .= ' CGI URL ';
1373             $message .= quote($test->{'data'});
1374             $message .= ' and expected status code ';
1375             $message .= quote($test->{'expected-status-code'});
1376
1377         } elsif ($test->{'type'} == METHOD_TEST) {
1378
1379             $message .= ' HTTP method ';
1380             $message .= quote($test->{'data'});
1381             $message .= ' and expected status code ';
1382             $message .= quote($test->{'expected-status-code'});
1383
1384         } elsif ($test->{'type'} == BLOCK_TEST) {
1385
1386             $message .= ' Supposedly-blocked URL: ';
1387             $message .= quote($test->{'data'});
1388
1389         } elsif ($test->{'type'} == STICKY_ACTIONS_TEST) {
1390
1391             $message .= ' Sticky Actions: ';
1392             $message .= quote($test->{'sticky-actions'});
1393             $message .= ' and URL: ';
1394             $message .= quote($test->{'data'});
1395
1396         } elsif ($test->{'type'} == REDIRECT_TEST) {
1397
1398             $message .= ' Redirected URL: ';
1399             $message .= quote($test->{'data'});
1400             $message .= ' and redirect destination: ';
1401             $message .= quote($test->{'redirect destination'});
1402
1403         } else {
1404
1405             die "Incomplete support for test type " . $test->{'type'} .  " detected.";
1406         }
1407     }
1408
1409     log_message($message) if (!$result or cli_option_is_set('verbose'));
1410 }
1411
1412 sub quote ($) {
1413     my $s = shift;
1414     return '\'' . $s . '\'';
1415 }
1416
1417 sub print_version () {
1418     printf PRT_VERSION . "\n" . 'Copyright (C) 2007-2011 Fabian Keil <fk@fabiankeil.de>' . "\n";
1419 }
1420
1421 sub list_test_types () {
1422     my %test_types = (
1423         'Client header test'  => CLIENT_HEADER_TEST,
1424         'Server header test'  =>  2,
1425         'Dumb fetch test'     =>  3,
1426         'Method test'         =>  4,
1427         'Sticky action test'  =>  5,
1428         'Trusted CGI test'    =>  6,
1429         'Block test'          =>  7,
1430         'Redirect test'       => 108,
1431     );
1432
1433     print "\nThe supported test types and their default levels are:\n";
1434     foreach my $test_type (sort { $test_types{$a} <=> $test_types{$b} } keys %test_types) {
1435         printf "     %-20s -> %3.d\n", $test_type, $test_types{$test_type};
1436     }
1437 }
1438
1439 sub help () {
1440
1441     our %cli_options;
1442
1443     print_version();
1444
1445     print << "    EOF"
1446
1447 Options and their default values if they have any:
1448     [--debug $cli_options{'debug'}]
1449     [--forks $cli_options{'forks'}]
1450     [--fuzzer-address]
1451     [--fuzzer-feeding]
1452     [--help]
1453     [--header-fuzzing]
1454     [--level]
1455     [--loops $cli_options{'loops'}]
1456     [--max-level $cli_options{'max-level'}]
1457     [--max-time $cli_options{'max-time'}]
1458     [--min-level $cli_options{'min-level'}]
1459     [--privoxy-address]
1460     [--retries $cli_options{'retries'}]
1461     [--show-skipped-tests]
1462     [--sleep-time $cli_options{'sleep-time'}]
1463     [--test-number]
1464     [--verbose]
1465     [--version]
1466     EOF
1467     ;
1468
1469     list_test_types();
1470
1471     print << "    EOF"
1472
1473 Try "perldoc $0" for more information
1474     EOF
1475     ;
1476
1477     exit(0);
1478 }
1479
1480 sub init_cli_options () {
1481
1482     our %cli_options;
1483     our $log_level;
1484
1485     $cli_options{'debug'}     = $log_level;
1486     $cli_options{'forks'}     = CLI_FORKS;
1487     $cli_options{'loops'}     = CLI_LOOPS;
1488     $cli_options{'max-level'} = CLI_MAX_LEVEL;
1489     $cli_options{'max-time'}  = CLI_MAX_TIME;
1490     $cli_options{'min-level'} = CLI_MIN_LEVEL;
1491     $cli_options{'sleep-time'}= CLI_SLEEP_TIME;
1492     $cli_options{'retries'}   = CLI_RETRIES;
1493 }
1494
1495 sub parse_cli_options () {
1496
1497     our %cli_options;
1498     our $log_level;
1499
1500     init_cli_options();
1501
1502     GetOptions (
1503         'debug=i'            => \$cli_options{'debug'},
1504         'forks=i'            => \$cli_options{'forks'},
1505         'fuzzer-address=s'   => \$cli_options{'fuzzer-address'},
1506         'fuzzer-feeding'     => \$cli_options{'fuzzer-feeding'},
1507         'header-fuzzing'     => \$cli_options{'header-fuzzing'},
1508         'help'               => \&help,
1509         'level=i'            => \$cli_options{'level'},
1510         'loops=i'            => \$cli_options{'loops'},
1511         'max-level=i'        => \$cli_options{'max-level'},
1512         'max-time=i'         => \$cli_options{'max-time'},
1513         'min-level=i'        => \$cli_options{'min-level'},
1514         'privoxy-address=s'  => \$cli_options{'privoxy-address'},
1515         'retries=i'          => \$cli_options{'retries'},
1516         'show-skipped-tests' => \$cli_options{'show-skipped-tests'},
1517         'sleep-time=i'       => \$cli_options{'sleep-time'},
1518         'test-number=i'      => \$cli_options{'test-number'},
1519         'verbose'            => \$cli_options{'verbose'},
1520         'version'            => sub {print_version && exit(0)}
1521     ) or exit(1);
1522     $log_level |= $cli_options{'debug'};
1523 }
1524
1525 sub cli_option_is_set ($) {
1526
1527     our %cli_options;
1528     my $cli_option = shift;
1529
1530     return defined $cli_options{$cli_option};
1531 }
1532
1533 sub get_cli_option ($) {
1534
1535     our %cli_options;
1536     my $cli_option = shift;
1537
1538     die "Unknown CLI option: $cli_option" unless defined $cli_options{$cli_option};
1539
1540     return $cli_options{$cli_option};
1541 }
1542
1543 sub init_proxy_settings($) {
1544
1545     my $choice = shift;
1546     our $proxy = undef;
1547
1548     if (($choice eq 'fuzz-proxy') and cli_option_is_set('fuzzer-address')) {
1549         $proxy = get_cli_option('fuzzer-address');
1550     }
1551
1552     if ((not defined $proxy) or ($choice eq 'vanilla-proxy')) {
1553
1554         if (cli_option_is_set('privoxy-address')) {
1555             $proxy .=  get_cli_option('privoxy-address');
1556         }
1557     }
1558 }
1559
1560 sub start_forks($) {
1561     my $forks = shift;
1562
1563     log_and_die("Invalid --fork value: " . $forks . ".") if ($forks < 0);
1564
1565     foreach my $fork (1 .. $forks) {
1566         log_message("Starting fork $fork");
1567         my $pid = fork();
1568         if (defined $pid && !$pid) {
1569             return;
1570         }
1571     }
1572 }
1573
1574 sub main () {
1575
1576     init_our_variables();
1577     parse_cli_options();
1578     init_proxy_settings('vanilla-proxy');
1579     load_regressions_tests();
1580     init_proxy_settings('fuzz-proxy');
1581     start_forks(get_cli_option('forks')) if cli_option_is_set('forks');
1582     execute_regression_tests();
1583 }
1584
1585 main();
1586
1587 =head1 NAME
1588
1589 B<privoxy-regression-test> - A regression test "framework" for Privoxy.
1590
1591 =head1 SYNOPSIS
1592
1593 B<privoxy-regression-test> [B<--debug bitmask>] [B<--forks> forks]
1594 [B<--fuzzer-feeding>] [B<--fuzzer-feeding>] [B<--help>] [B<--level level>]
1595 [B<--loops count>] [B<--max-level max-level>] [B<--max-time max-time>]
1596 [B<--min-level min-level>] B<--privoxy-address proxy-address>
1597 [B<--retries retries>] [B<--test-number test-number>]
1598 [B<--show-skipped-tests>] [B<--sleep-time> seconds] [B<--verbose>]
1599 [B<--version>]
1600
1601 =head1 DESCRIPTION
1602
1603 Privoxy-Regression-Test is supposed to one day become
1604 a regression test suite for Privoxy. It's not quite there
1605 yet, however, and can currently only test header actions,
1606 check the returned status code for requests to arbitrary
1607 URLs and verify which actions are applied to them.
1608
1609 Client header actions are tested by requesting
1610 B<http://p.p/show-request> and checking whether
1611 or not Privoxy modified the original request as expected.
1612
1613 The original request contains both the header the action-to-be-tested
1614 acts upon and an additional tagger-triggering header that enables
1615 the action to test.
1616
1617 Applied actions are checked through B<http://p.p/show-url-info>.
1618
1619 =head1 CONFIGURATION FILE SYNTAX
1620
1621 Privoxy-Regression-Test's configuration is embedded in
1622 Privoxy action files and loaded through Privoxy's web interface.
1623
1624 It makes testing a Privoxy version running on a remote system easier
1625 and should prevent you from updating your tests without updating Privoxy's
1626 configuration accordingly.
1627
1628 A client-header-action test section looks like this:
1629
1630     # Set Header    = Referer: http://www.example.org.zwiebelsuppe.exit/
1631     # Expect Header = Referer: http://www.example.org/
1632     {+client-header-filter{hide-tor-exit-notation} -hide-referer}
1633     TAG:^client-header-filter\{hide-tor-exit-notation\}$
1634
1635 The example above causes Privoxy-Regression-Test to set
1636 the header B<Referer: http://www.example.org.zwiebelsuppe.exit/>
1637 and to expect it to be modified to
1638 B<Referer: http://www.example.org/>.
1639
1640 When testing this section, Privoxy-Regression-Test will set the header
1641 B<X-Privoxy-Control: client-header-filter{hide-tor-exit-notation}>
1642 causing the B<privoxy-control> tagger to create the tag
1643 B<client-header-filter{hide-tor-exit-notation}> which will finally
1644 cause Privoxy to enable the action section.
1645
1646 Note that the actions itself are only used by Privoxy,
1647 Privoxy-Regression-Test ignores them and will be happy
1648 as long as the expectations are satisfied.
1649
1650 A fetch test looks like this:
1651
1652     # Fetch Test = http://p.p/user-manual
1653     # Expect Status Code = 302
1654
1655 It tells Privoxy-Regression-Test to request B<http://p.p/user-manual>
1656 and to expect a response with the HTTP status code B<302>. Obviously that's
1657 not a very thorough test and mainly useful to get some code coverage
1658 for Valgrind or to verify that the templates are installed correctly.
1659
1660 If you want to test CGI pages that require a trusted
1661 referer, you can use:
1662
1663     # Trusted CGI Request = http://p.p/edit-actions
1664
1665 It works like ordinary fetch tests, but sets the referer
1666 header to a trusted value.
1667
1668 If no explicit status code expectation is set, B<200> is used.
1669
1670 To verify that a URL is blocked, use:
1671
1672     # Blocked URL = http://www.example.com/blocked
1673
1674 To verify that a specific set of actions is applied to an URL, use:
1675
1676     # Sticky Actions = +block{foo} +handle-as-empty-document -handle-as-image
1677     # URL = http://www.example.org/my-first-url
1678
1679 The sticky actions will be checked for all URLs below it
1680 until the next sticky actions directive.
1681
1682 To verify that requests for a URL get redirected, use:
1683
1684     # Redirected URL = http://www.example.com/redirect-me
1685     # Redirect Destination = http://www.example.org/redirected
1686
1687 =head1 TEST LEVELS
1688
1689 All tests have test levels to let the user
1690 control which ones to execute (see I<OPTIONS> below).
1691 Test levels are either set with the B<Level> directive,
1692 or implicitly through the test type.
1693
1694 Redirect tests default to level 108, block tests to level 7,
1695 fetch tests to level 6, "Sticky Actions" tests default to
1696 level 5, tests for trusted CGI requests to level 3 and
1697 client-header-action tests to level 1.
1698
1699 The current redirect test level is above the default
1700 max-level value as failed tests will result in outgoing
1701 connections. Use the B<--max-level> option to run them
1702 as well.
1703
1704 =head1 OPTIONS
1705
1706 B<--debug bitmask> Add the bitmask provided as integer
1707 to the debug settings.
1708
1709 B<--forks forks> Number of forks to start before executing
1710 the regression tests. This is mainly useful for stress-testing.
1711
1712 B<--fuzzer-address> Listening address used when executing
1713 the regression tests. Useful to make sure that the requests
1714 to load the regression tests don't fail due to fuzzing.
1715
1716 B<--fuzzer-feeding> Ignore some errors that would otherwise
1717 cause Privoxy-Regression-Test to abort the test because
1718 they shouldn't happen in normal operation. This option is
1719 intended to be used if Privoxy-Regression-Test is only
1720 used to feed a fuzzer in which case there's a high chance
1721 that Privoxy gets an invalid request and returns an error
1722 message.
1723
1724 B<--help> Shows available command line options.
1725
1726 B<--header-fuzzing> Modifies linear white space in
1727 headers in a way that should not affect the test result.
1728
1729 B<--level level> Only execute tests with the specified B<level>.
1730
1731 B<--loop count> Loop through the regression tests B<count> times.
1732 Useful to feed a fuzzer, or when doing stress tests with
1733 several Privoxy-Regression-Test instances running at the same
1734 time.
1735
1736 B<--max-level max-level> Only execute tests with a B<level>
1737 below or equal to the numerical B<max-level>.
1738
1739 B<--max-time max-time> Give Privoxy B<max-time> seconds
1740 to return data. Increasing the default may make sense when
1741 Privoxy is run through Valgrind, decreasing the default may
1742 make sense when Privoxy-Regression-Test is used to feed
1743 a fuzzer.
1744
1745 B<--min-level min-level> Only execute tests with a B<level>
1746 above or equal to the numerical B<min-level>.
1747
1748 B<--privoxy-address proxy-address> Privoxy's listening address.
1749 If it's not set, the value of the environment variable http_proxy
1750 will be used. B<proxy-address> has to be specified in http_proxy
1751 syntax.
1752
1753 B<--retries retries> Retry B<retries> times.
1754
1755 B<--test-number test-number> Only run the test with the specified
1756 number.
1757
1758 B<--show-skipped-tests> Log skipped tests even if verbose mode is off.
1759
1760 B<--sleep-time seconds> Wait B<seconds> between tests. Useful when
1761 debugging issues with systems that don't log with millisecond precision.
1762
1763 B<--verbose> Log successful tests as well. By default only
1764 the failures are logged.
1765
1766 B<--version> Print version and exit.
1767
1768 The second dash is optional, options can be shortened,
1769 as long as there are no ambiguities.
1770
1771 =head1 PRIVOXY CONFIGURATION
1772
1773 Privoxy-Regression-Test is shipped with B<regression-tests.action>
1774 which aims to test all official client-header modifying actions
1775 and can be used to verify that the templates and the user manual
1776 files are installed correctly.
1777
1778 To use it, it has to be copied in Privoxy's configuration
1779 directory, and afterwards referenced in Privoxy's configuration
1780 file with the line:
1781
1782     actionsfile regression-tests.action
1783
1784 In general, its tests are supposed to work without changing
1785 any other action files, unless you already added lots of
1786 taggers yourself. If you are using taggers that cause problems,
1787 you might have to temporary disable them for Privoxy's CGI pages.
1788
1789 Some of the regression tests rely on Privoxy features that
1790 may be disabled in your configuration. Tests with a level below
1791 7 are supposed to work with all Privoxy configurations (provided
1792 you didn't build with FEATURE_GRACEFUL_TERMINATION).
1793
1794 Tests with level 9 require Privoxy to deliver the User Manual,
1795 tests with level 12 require the CGI editor to be enabled.
1796
1797 =head1 CAVEATS
1798
1799 Expect the configuration file syntax to change with future releases.
1800
1801 =head1 LIMITATIONS
1802
1803 As Privoxy's B<show-request> page only shows client headers,
1804 Privoxy-Regression-Test can't use it to test Privoxy actions
1805 that modify server headers.
1806
1807 As Privoxy-Regression-Test relies on Privoxy's tag feature to
1808 control the actions to test, it currently only works with
1809 Privoxy 3.0.7 or later.
1810
1811 At the moment Privoxy-Regression-Test fetches Privoxy's
1812 configuration page through I<curl>(1), therefore you have to
1813 have I<curl> installed, otherwise you won't be able to run
1814 Privoxy-Regression-Test in a meaningful way.
1815
1816 =head1 SEE ALSO
1817
1818 privoxy(1) curl(1)
1819
1820 =head1 AUTHOR
1821
1822 Fabian Keil <fk@fabiankeil.de>
1823
1824 =cut