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