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