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.66 2011/05/08 13:27:10 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 incomplete.
 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: Necessary?
 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 too low (" . $level . " < " . $min_level . ")";
 597
 598     } elsif ($level > $max_level) {
 599
 600         $reason = "Level too 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 actually 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         $success = (defined($header) and $header eq $test->{'data'});
 921
 922         unless ($success) {
 923             $header = "REMOVAL" unless defined $header;
 924             l(LL_VERBOSE_FAILURE,
 925               "Ooops. Got: '" . $header . "' while expecting: '" . $expect_header . "'");
 926         }
 927
 928     } elsif ($expect_header eq 'REMOVAL') {
 929
 930         # XXX: Use more reliable check here and make sure
 931         # the header has a different name.
 932         $success = not (defined($header) and $header eq $test->{'data'});
 933
 934         unless ($success) {
 935             l(LL_VERBOSE_FAILURE,
 936               "Ooops. Expected removal but: '" . $header . "' is still there.");
 937         }
 938
 939     } elsif ($expect_header eq 'SOME CHANGE') {
 940
 941         $success = (defined($header) and $header ne $test->{'data'});
 942
 943         unless  ($success) {
 944             $header = "REMOVAL" unless defined $header;
 945             l(LL_VERBOSE_FAILURE,
 946               "Ooops. Got: '" . $header . "' while expecting: SOME CHANGE");
 947         }
 948
 949     } else {
 950
 951         $success = (defined($header) and $header eq $expect_header);
 952
 953         unless ($success) {
 954             $header = "No matching header" unless defined $header; # XXX: No header detected to be precise
 955             l(LL_VERBOSE_FAILURE,
 956               "Ooops. Got: '" . $header . "' while expecting: '" . $expect_header . "'");
 957         }
 958     }
 959     return $success;
 960 }
 961
 962 sub get_header_name ($) {
 963
 964     my $header = shift;
 965
 966     $header =~ s@(.*?: ).*@$1@;
 967
 968     return $header;
 969 }
 970
 971 sub get_header ($$) {
 972
 973     our $filtered_request = '';
 974
 975     my $buffer_ref = shift;
 976     my $test = shift;
 977
 978     my @buffer = @{$buffer_ref};
 979
 980     my $expect_header = $test->{'expect-header'};
 981
 982     die "get_header called with no expect header" unless defined $expect_header;
 983
 984     my $line;
 985     my $processed_request_reached = 0;
 986     my $read_header = 0;
 987     my $processed_request = '';
 988     my $header;
 989     my $header_to_get;
 990
 991     if ($expect_header eq 'REMOVAL'
 992      or $expect_header eq 'NO CHANGE'
 993      or  $expect_header eq 'SOME CHANGE') {
 994
 995         $expect_header = $test->{'data'};
 996     }
 997
 998     $header_to_get = get_header_name($expect_header);
 999
1000     foreach (@buffer) {
1001
1002         # Skip everything before the Processed request
1003         if (/Processed Request/) {
1004             $processed_request_reached = 1;
1005             next;
1006         }
1007         next unless $processed_request_reached;
1008
1009         # End loop after the Processed request
1010         last if (/<\/pre>/);
1011
1012         # Ditch tags and leading/trailing white space.
1013         s@^\s*<.*?>@@g;
1014         s@\s*$@@g;
1015
1016         # Decode characters we care about.
1017         s@&quot;@"@g;
1018
1019         $filtered_request .=  "\n" . $_;
1020
1021         if (/^$header_to_get/) {
1022             $read_header = 1;
1023             $header = $_;
1024             last;
1025         }
1026     }
1027
1028     return $header;
1029 }
1030
1031 sub get_server_header ($$) {
1032
1033     my $buffer_ref = shift;
1034     my $test = shift;
1035
1036     my @buffer = @{$buffer_ref};
1037
1038     my $expect_header = $test->{'expect-header'};
1039     my $header;
1040     my $header_to_get;
1041
1042     # XXX: Should be caught before starting to test.
1043     log_and_die("No expect header for test " . $test->{'number'})
1044         unless defined $expect_header;
1045
1046     if ($expect_header eq 'REMOVAL'
1047      or $expect_header eq 'NO CHANGE'
1048      or $expect_header eq 'SOME CHANGE') {
1049
1050         $expect_header = $test->{'data'};
1051     }
1052
1053     $header_to_get = get_header_name($expect_header);
1054
1055     foreach (@buffer) {
1056
1057         # XXX: should probably verify that the request
1058         # was actually answered by Fellatio.
1059         if (/^$header_to_get/) {
1060             $header = $_;
1061             $header =~ s@\s*$@@g;
1062             last;
1063         }
1064     }
1065
1066     return $header;
1067 }
1068
1069 sub get_status_code ($) {
1070
1071     my $buffer_ref = shift;
1072     my @buffer = @{$buffer_ref};
1073
1074     foreach (@buffer) {
1075
1076         if (/^HTTP\/\d\.\d (\d{3})/) {
1077
1078             return $1;
1079
1080         } else {
1081
1082             return '123' if cli_option_is_set('fuzzer-feeding');
1083             chomp;
1084             log_and_die('Unexpected buffer line: "' . $_ . '"');
1085         }
1086     }
1087 }
1088
1089 sub get_test_keys () {
1090     return ('tag', 'data', 'expect-header', 'ignore');
1091 }
1092
1093 # XXX: incomplete
1094 sub test_content_as_string ($) {
1095
1096     my $test = shift;
1097
1098     my $s = "\n\t";
1099
1100     foreach my $key (get_test_keys()) {
1101         $test->{$key} = 'Not set' unless (defined $test->{$key});
1102     }
1103
1104     $s .= 'Tag: ' . $test->{'tag'};
1105     $s .= "\n\t";
1106     $s .= 'Set header: ' . $test->{'data'}; # XXX: adjust for other test types
1107     $s .= "\n\t";
1108     $s .= 'Expected header: ' . $test->{'expect-header'};
1109     $s .= "\n\t";
1110     $s .= 'Ignore: ' . $test->{'ignore'};
1111
1112     return $s;
1113 }
1114
1115 sub fuzz_header($) {
1116     my $header = shift;
1117     my $white_space = int(rand(2)) - 1 ? " " : "\t";
1118
1119     $white_space = $white_space x (1 + int(rand(5)));
1120
1121     # Only fuzz white space before the first quoted token.
1122     # (Privoxy doesn't touch white space inside quoted tokens
1123     # and modifying it would cause the tests to fail).
1124     $header =~ s@(^[^"]*?)\s@$1$white_space@g;
1125
1126     return $header;
1127 }
1128
1129 ############################################################################
1130 #
1131 # HTTP fetch functions
1132 #
1133 ############################################################################
1134
1135 sub get_cgi_page_or_else ($) {
1136
1137     my $cgi_url = shift;
1138     my $content_ref = get_page_with_curl($cgi_url);
1139     my $status_code = get_status_code($content_ref);
1140
1141     if (200 != $status_code) {
1142
1143         my $log_message = "Failed to fetch Privoxy CGI Page. " .
1144                           "Received status code ". $status_code .
1145                           " while only 200 is acceptable.";
1146
1147         if (cli_option_is_set('fuzzer-feeding')) {
1148
1149             $log_message .= " Ignored due to fuzzer feeding.";
1150             l(LL_SOFT_ERROR, $log_message)
1151
1152         } else {
1153
1154             log_and_die($log_message);
1155         }
1156     }
1157
1158     return $content_ref;
1159 }
1160
1161 # XXX: misleading name
1162 sub get_show_request_with_curl ($) {
1163
1164     our $privoxy_cgi_url;
1165     my $test = shift;
1166
1167     my $curl_parameters = ' ';
1168     my $header = $test->{'data'};
1169
1170     if (cli_option_is_set('header-fuzzing')) {
1171         $header = fuzz_header($header);
1172     }
1173
1174     # Enable the action to test
1175     $curl_parameters .= '-H \'X-Privoxy-Control: ' . $test->{'tag'} . '\' ';
1176     # The header to filter
1177     $curl_parameters .= '-H \'' . $header . '\' ';
1178
1179     $curl_parameters .= ' ';
1180     $curl_parameters .= $privoxy_cgi_url;
1181     $curl_parameters .= 'show-request';
1182
1183     return get_cgi_page_or_else($curl_parameters);
1184 }
1185
1186 sub get_head_with_curl ($) {
1187
1188     our $fellatio_url = FELLATIO_URL;
1189     my $test = shift;
1190
1191     my $curl_parameters = ' ';
1192
1193     # Enable the action to test
1194     $curl_parameters .= '-H \'X-Privoxy-Control: ' . $test->{'tag'} . '\' ';
1195     # The header to filter
1196     $curl_parameters .= '-H \'X-Gimme-Head-With: ' . $test->{'data'} . '\' ';
1197     $curl_parameters .= '--head ';
1198
1199     $curl_parameters .= ' ';
1200     $curl_parameters .= $fellatio_url;
1201
1202     return get_page_with_curl($curl_parameters);
1203 }
1204
1205 sub get_page_with_curl ($) {
1206
1207     our $proxy;
1208
1209     my $parameters = shift;
1210     my @buffer;
1211     my $curl_line = CURL;
1212     my $retries_left = get_cli_option('retries') + 1;
1213     my $failure_reason;
1214
1215     $curl_line .= ' --proxy ' . $proxy if (defined $proxy);
1216
1217     # We want to see the HTTP status code
1218     $curl_line .= " --include ";
1219     # Let Privoxy emit two log messages less.
1220     $curl_line .= ' -H \'Proxy-Connection:\' ' unless $parameters =~ /Proxy-Connection:/;
1221     $curl_line .= ' -H \'Connection: close\' ' unless $parameters =~ /Connection:/;
1222     # We don't care about fetch statistic.
1223     $curl_line .= " -s ";
1224     # We do care about the failure reason if any.
1225     $curl_line .= " -S ";
1226     # We want to advertise ourselves
1227     $curl_line .= " --user-agent '" . PRT_VERSION . "' ";
1228     # We aren't too patient
1229     $curl_line .= " --max-time '" . get_cli_option('max-time') . "' ";
1230
1231     $curl_line .= $parameters;
1232     # XXX: still necessary?
1233     $curl_line .= ' 2>&1';
1234
1235     l(LL_PAGE_FETCHING, "Executing: " . $curl_line);
1236
1237     do {
1238         @buffer = `$curl_line`;
1239
1240         if ($?) {
1241             log_and_die("Executing '$curl_line' failed.") unless @buffer;
1242             $failure_reason = array_as_string(\@buffer);
1243             chomp $failure_reason;
1244             l(LL_SOFT_ERROR, "Fetch failure: '" . $failure_reason . $! ."'");
1245         }
1246     } while ($? && --$retries_left);
1247
1248     unless ($retries_left) {
1249         log_and_die("Running curl failed " . get_cli_option('retries') .
1250                     " times in a row. Last error: '" . $failure_reason . "'.");
1251     }
1252
1253     return \@buffer;
1254 }
1255
1256
1257 ############################################################################
1258 #
1259 # Log functions
1260 #
1261 ############################################################################
1262
1263 sub array_as_string ($) {
1264     my $array_ref = shift;
1265     my $string = '';
1266
1267     foreach (@{$array_ref}) {
1268         $string .= $_;
1269     }
1270
1271     return $string;
1272 }
1273
1274 sub show_test ($) {
1275     my $test = shift;
1276     log_message('Test is:' . test_content_as_string($test));
1277 }
1278
1279 # Conditional log
1280 sub l ($$) {
1281     our $log_level;
1282     my $this_level = shift;
1283     my $message = shift;
1284
1285     log_message($message) if ($log_level & $this_level);
1286 }
1287
1288 sub log_and_die ($) {
1289     my $message = shift;
1290
1291     log_message('Oh noes. ' . $message . ' Fatal error. Exiting.');
1292     exit;
1293 }
1294
1295 sub log_message ($) {
1296
1297     my $message = shift;
1298
1299     our $logfile;
1300     our $no_logging;
1301     our $leading_log_date;
1302     our $leading_log_time;
1303
1304     my $time_stamp = '';
1305     my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime time;
1306
1307     if ($leading_log_date || $leading_log_time) {
1308
1309         if ($leading_log_date) {
1310             $year += 1900;
1311             $mon  += 1;
1312             $time_stamp = sprintf("%i/%.2i/%.2i", $year, $mon, $mday);
1313         }
1314
1315         if ($leading_log_time) {
1316             $time_stamp .= ' ' if $leading_log_date;
1317             $time_stamp.= sprintf("%.2i:%.2i:%.2i", $hour, $min, $sec);
1318         }
1319
1320         $message = $time_stamp . ": " . $message;
1321     }
1322
1323     printf(STDERR "%s\n", $message);
1324 }
1325
1326 sub log_result ($$) {
1327
1328     our $verbose_test_description;
1329     our $filtered_request;
1330
1331     my $test = shift;
1332     my $result = shift;
1333     my $number = shift;
1334
1335     my $message = '';
1336
1337     $message .= interpret_result($result);
1338     $message .= " for test ";
1339     $message .= $number;
1340     $message .= '/';
1341     $message .= $test->{'number'};
1342     $message .= '/';
1343     $message .= $test->{'section-id'};
1344     $message .= '/';
1345     $message .= $test->{'regression-test-id'};
1346     $message .= '.';
1347
1348     if ($verbose_test_description) {
1349
1350         if ($test->{'type'} == CLIENT_HEADER_TEST) {
1351
1352             $message .= ' Header ';
1353             $message .= quote($test->{'data'});
1354             $message .= ' and tag ';
1355             $message .= quote($test->{'tag'});
1356
1357         } elsif ($test->{'type'} == SERVER_HEADER_TEST) {
1358
1359             $message .= ' Request Header ';
1360             $message .= quote($test->{'data'});
1361             $message .= ' and tag ';
1362             $message .= quote($test->{'tag'});
1363
1364         } elsif ($test->{'type'} == DUMB_FETCH_TEST) {
1365
1366             $message .= ' URL ';
1367             $message .= quote($test->{'data'});
1368             $message .= ' and expected status code ';
1369             $message .= quote($test->{'expected-status-code'});
1370
1371         } elsif ($test->{'type'} == TRUSTED_CGI_REQUEST) {
1372
1373             $message .= ' CGI URL ';
1374             $message .= quote($test->{'data'});
1375             $message .= ' and expected status code ';
1376             $message .= quote($test->{'expected-status-code'});
1377
1378         } elsif ($test->{'type'} == METHOD_TEST) {
1379
1380             $message .= ' HTTP method ';
1381             $message .= quote($test->{'data'});
1382             $message .= ' and expected status code ';
1383             $message .= quote($test->{'expected-status-code'});
1384
1385         } elsif ($test->{'type'} == BLOCK_TEST) {
1386
1387             $message .= ' Supposedly-blocked URL: ';
1388             $message .= quote($test->{'data'});
1389
1390         } elsif ($test->{'type'} == STICKY_ACTIONS_TEST) {
1391
1392             $message .= ' Sticky Actions: ';
1393             $message .= quote($test->{'sticky-actions'});
1394             $message .= ' and URL: ';
1395             $message .= quote($test->{'data'});
1396
1397         } elsif ($test->{'type'} == REDIRECT_TEST) {
1398
1399             $message .= ' Redirected URL: ';
1400             $message .= quote($test->{'data'});
1401             $message .= ' and redirect destination: ';
1402             $message .= quote($test->{'redirect destination'});
1403
1404         } else {
1405
1406             die "Incomplete support for test type " . $test->{'type'} .  " detected.";
1407         }
1408     }
1409
1410     log_message($message) if (!$result or cli_option_is_set('verbose'));
1411 }
1412
1413 sub quote ($) {
1414     my $s = shift;
1415     return '\'' . $s . '\'';
1416 }
1417
1418 sub print_version () {
1419     printf PRT_VERSION . "\n" . 'Copyright (C) 2007-2011 Fabian Keil <fk@fabiankeil.de>' . "\n";
1420 }
1421
1422 sub list_test_types () {
1423     my %test_types = (
1424         'Client header test'  => CLIENT_HEADER_TEST,
1425         'Server header test'  =>  2,
1426         'Dumb fetch test'     =>  3,
1427         'Method test'         =>  4,
1428         'Sticky action test'  =>  5,
1429         'Trusted CGI test'    =>  6,
1430         'Block test'          =>  7,
1431         'Redirect test'       => 108,
1432     );
1433
1434     print "\nThe supported test types and their default levels are:\n";
1435     foreach my $test_type (sort { $test_types{$a} <=> $test_types{$b} } keys %test_types) {
1436         printf "     %-20s -> %3.d\n", $test_type, $test_types{$test_type};
1437     }
1438 }
1439
1440 sub help () {
1441
1442     our %cli_options;
1443
1444     print_version();
1445
1446     print << "    EOF"
1447
1448 Options and their default values if they have any:
1449     [--debug $cli_options{'debug'}]
1450     [--forks $cli_options{'forks'}]
1451     [--fuzzer-address]
1452     [--fuzzer-feeding]
1453     [--help]
1454     [--header-fuzzing]
1455     [--level]
1456     [--loops $cli_options{'loops'}]
1457     [--max-level $cli_options{'max-level'}]
1458     [--max-time $cli_options{'max-time'}]
1459     [--min-level $cli_options{'min-level'}]
1460     [--privoxy-address]
1461     [--retries $cli_options{'retries'}]
1462     [--show-skipped-tests]
1463     [--test-number]
1464     [--verbose]
1465     [--version]
1466     EOF
1467     ;
1468
1469     list_test_types();
1470
1471     print << "    EOF"
1472
1473 Try "perldoc $0" for more information
1474     EOF
1475     ;
1476
1477     exit(0);
1478 }
1479
1480 sub init_cli_options () {
1481
1482     our %cli_options;
1483     our $log_level;
1484
1485     $cli_options{'debug'}     = $log_level;
1486     $cli_options{'forks'}     = CLI_FORKS;
1487     $cli_options{'loops'}     = CLI_LOOPS;
1488     $cli_options{'max-level'} = CLI_MAX_LEVEL;
1489     $cli_options{'max-time'}  = CLI_MAX_TIME;
1490     $cli_options{'min-level'} = CLI_MIN_LEVEL;
1491     $cli_options{'retries'}   = CLI_RETRIES;
1492 }
1493
1494 sub parse_cli_options () {
1495
1496     our %cli_options;
1497     our $log_level;
1498
1499     init_cli_options();
1500
1501     GetOptions (
1502         'debug=s'            => \$cli_options{'debug'},
1503         'forks=s'            => \$cli_options{'forks'},
1504         'fuzzer-address=s'   => \$cli_options{'fuzzer-address'},
1505         'fuzzer-feeding'     => \$cli_options{'fuzzer-feeding'},
1506         'header-fuzzing'     => \$cli_options{'header-fuzzing'},
1507         'help'               => \&help,
1508         'level=s'            => \$cli_options{'level'},
1509         'loops=s'            => \$cli_options{'loops'},
1510         'max-level=s'        => \$cli_options{'max-level'},
1511         'max-time=s'         => \$cli_options{'max-time'},
1512         'min-level=s'        => \$cli_options{'min-level'},
1513         'privoxy-address=s'  => \$cli_options{'privoxy-address'},
1514         'retries=s'          => \$cli_options{'retries'},
1515         'show-skipped-tests' => \$cli_options{'show-skipped-tests'},
1516         'test-number=s'      => \$cli_options{'test-number'},
1517         'verbose'            => \$cli_options{'verbose'},
1518         'version'            => sub {print_version && exit(0)}
1519     ) or exit(1);
1520     $log_level |= $cli_options{'debug'};
1521 }
1522
1523 sub cli_option_is_set ($) {
1524
1525     our %cli_options;
1526     my $cli_option = shift;
1527
1528     return defined $cli_options{$cli_option};
1529 }
1530
1531 sub get_cli_option ($) {
1532
1533     our %cli_options;
1534     my $cli_option = shift;
1535
1536     die "Unknown CLI option: $cli_option" unless defined $cli_options{$cli_option};
1537
1538     return $cli_options{$cli_option};
1539 }
1540
1541 sub init_proxy_settings($) {
1542
1543     my $choice = shift;
1544     our $proxy = undef;
1545
1546     if (($choice eq 'fuzz-proxy') and cli_option_is_set('fuzzer-address')) {
1547         $proxy = get_cli_option('fuzzer-address');
1548     }
1549
1550     if ((not defined $proxy) or ($choice eq 'vanilla-proxy')) {
1551
1552         if (cli_option_is_set('privoxy-address')) {
1553             $proxy .=  get_cli_option('privoxy-address');
1554         }
1555     }
1556 }
1557
1558 sub start_forks($) {
1559     my $forks = shift;
1560
1561     log_and_die("Invalid --fork value: " . $forks . ".") if ($forks < 0);
1562
1563     foreach my $fork (1 .. $forks) {
1564         log_message("Starting fork $fork");
1565         my $pid = fork();
1566         if (defined $pid && !$pid) {
1567             return;
1568         }
1569     }
1570 }
1571
1572 sub main () {
1573
1574     init_our_variables();
1575     parse_cli_options();
1576     init_proxy_settings('vanilla-proxy');
1577     load_regressions_tests();
1578     init_proxy_settings('fuzz-proxy');
1579     start_forks(get_cli_option('forks')) if cli_option_is_set('forks');
1580     execute_regression_tests();
1581 }
1582
1583 main();
1584
1585 =head1 NAME
1586
1587 B<privoxy-regression-test> - A regression test "framework" for Privoxy.
1588
1589 =head1 SYNOPSIS
1590
1591 B<privoxy-regression-test> [B<--debug bitmask>] [B<--forks> forks]
1592 [B<--fuzzer-feeding>] [B<--fuzzer-feeding>] [B<--help>] [B<--level level>]
1593 [B<--loops count>] [B<--max-level max-level>] [B<--max-time max-time>]
1594 [B<--min-level min-level>] B<--privoxy-address proxy-address>
1595 [B<--retries retries>] [B<--test-number test-number>]
1596 [B<--show-skipped-tests>] [B<--verbose>]
1597 [B<--version>]
1598
1599 =head1 DESCRIPTION
1600
1601 Privoxy-Regression-Test is supposed to one day become
1602 a regression test suite for Privoxy. It's not quite there
1603 yet, however, and can currently only test header actions,
1604 check the returned status code for requests to arbitrary
1605 URLs and verify which actions are applied to them.
1606
1607 Client header actions are tested by requesting
1608 B<http://p.p/show-request> and checking whether
1609 or not Privoxy modified the original request as expected.
1610
1611 The original request contains both the header the action-to-be-tested
1612 acts upon and an additional tagger-triggering header that enables
1613 the action to test.
1614
1615 Applied actions are checked through B<http://p.p/show-url-info>.
1616
1617 =head1 CONFIGURATION FILE SYNTAX
1618
1619 Privoxy-Regression-Test's configuration is embedded in
1620 Privoxy action files and loaded through Privoxy's web interface.
1621
1622 It makes testing a Privoxy version running on a remote system easier
1623 and should prevent you from updating your tests without updating Privoxy's
1624 configuration accordingly.
1625
1626 A client-header-action test section looks like this:
1627
1628     # Set Header    = Referer: http://www.example.org.zwiebelsuppe.exit/
1629     # Expect Header = Referer: http://www.example.org/
1630     {+client-header-filter{hide-tor-exit-notation} -hide-referer}
1631     TAG:^client-header-filter\{hide-tor-exit-notation\}$
1632
1633 The example above causes Privoxy-Regression-Test to set
1634 the header B<Referer: http://www.example.org.zwiebelsuppe.exit/>
1635 and to expect it to be modified to
1636 B<Referer: http://www.example.org/>.
1637
1638 When testing this section, Privoxy-Regression-Test will set the header
1639 B<X-Privoxy-Control: client-header-filter{hide-tor-exit-notation}>
1640 causing the B<privoxy-control> tagger to create the tag
1641 B<client-header-filter{hide-tor-exit-notation}> which will finally
1642 cause Privoxy to enable the action section.
1643
1644 Note that the actions itself are only used by Privoxy,
1645 Privoxy-Regression-Test ignores them and will be happy
1646 as long as the expectations are satisfied.
1647
1648 A fetch test looks like this:
1649
1650     # Fetch Test = http://p.p/user-manual
1651     # Expect Status Code = 302
1652
1653 It tells Privoxy-Regression-Test to request B<http://p.p/user-manual>
1654 and to expect a response with the HTTP status code B<302>. Obviously that's
1655 not a very thorough test and mainly useful to get some code coverage
1656 for Valgrind or to verify that the templates are installed correctly.
1657
1658 If you want to test CGI pages that require a trusted
1659 referer, you can use:
1660
1661     # Trusted CGI Request = http://p.p/edit-actions
1662
1663 It works like ordinary fetch tests, but sets the referer
1664 header to a trusted value.
1665
1666 If no explicit status code expectation is set, B<200> is used.
1667
1668 To verify that a URL is blocked, use:
1669
1670     # Blocked URL = http://www.example.com/blocked
1671
1672 To verify that a specific set of actions is applied to an URL, use:
1673
1674     # Sticky Actions = +block{foo} +handle-as-empty-document -handle-as-image
1675     # URL = http://www.example.org/my-first-url
1676
1677 The sticky actions will be checked for all URLs below it
1678 until the next sticky actions directive.
1679
1680 To verify that requests for a URL get redirected, use:
1681
1682     # Redirected URL = http://www.example.com/redirect-me
1683     # Redirect Destination = http://www.example.org/redirected
1684
1685 =head1 TEST LEVELS
1686
1687 All tests have test levels to let the user
1688 control which ones to execute (see I<OPTIONS> below).
1689 Test levels are either set with the B<Level> directive,
1690 or implicitly through the test type.
1691
1692 Redirect tests default to level 108, block tests to level 7,
1693 fetch tests to level 6, "Sticky Actions" tests default to
1694 level 5, tests for trusted CGI requests to level 3 and
1695 client-header-action tests to level 1.
1696
1697 The current redirect test level is above the default
1698 max-level value as failed tests will result in outgoing
1699 connections. Use the B<--max-level> option to run them
1700 as well.
1701
1702 =head1 OPTIONS
1703
1704 B<--debug bitmask> Add the bitmask provided as integer
1705 to the debug settings.
1706
1707 B<--forks forks> Number of forks to start before executing
1708 the regression tests. This is mainly useful for stress-testing.
1709
1710 B<--fuzzer-address> Listening address used when executing
1711 the regression tests. Useful to make sure that the requests
1712 to load the regression tests don't fail due to fuzzing.
1713
1714 B<--fuzzer-feeding> Ignore some errors that would otherwise
1715 cause Privoxy-Regression-Test to abort the test because
1716 they shouldn't happen in normal operation. This option is
1717 intended to be used if Privoxy-Regression-Test is only
1718 used to feed a fuzzer in which case there's a high chance
1719 that Privoxy gets an invalid request and returns an error
1720 message.
1721
1722 B<--help> Shows available command line options.
1723
1724 B<--header-fuzzing> Modifies linear white space in
1725 headers in a way that should not affect the test result.
1726
1727 B<--level level> Only execute tests with the specified B<level>.
1728
1729 B<--loop count> Loop through the regression tests B<count> times.
1730 Useful to feed a fuzzer, or when doing stress tests with
1731 several Privoxy-Regression-Test instances running at the same
1732 time.
1733
1734 B<--max-level max-level> Only execute tests with a B<level>
1735 below or equal to the numerical B<max-level>.
1736
1737 B<--max-time max-time> Give Privoxy B<max-time> seconds
1738 to return data. Increasing the default may make sense when
1739 Privoxy is run through Valgrind, decreasing the default may
1740 make sense when Privoxy-Regression-Test is used to feed
1741 a fuzzer.
1742
1743 B<--min-level min-level> Only execute tests with a B<level>
1744 above or equal to the numerical B<min-level>.
1745
1746 B<--privoxy-address proxy-address> Privoxy's listening address.
1747 If it's not set, the value of the environment variable http_proxy
1748 will be used. B<proxy-address> has to be specified in http_proxy
1749 syntax.
1750
1751 B<--retries retries> Retry B<retries> times.
1752
1753 B<--test-number test-number> Only run the test with the specified
1754 number.
1755
1756 B<--show-skipped-tests> Log skipped tests even if verbose mode is off.
1757
1758 B<--verbose> Log successful tests as well. By default only
1759 the failures are logged.
1760
1761 B<--version> Print version and exit.
1762
1763 The second dash is optional, options can be shortened,
1764 as long as there are no ambiguities.
1765
1766 =head1 PRIVOXY CONFIGURATION
1767
1768 Privoxy-Regression-Test is shipped with B<regression-tests.action>
1769 which aims to test all official client-header modifying actions
1770 and can be used to verify that the templates and the user manual
1771 files are installed correctly.
1772
1773 To use it, it has to be copied in Privoxy's configuration
1774 directory, and afterwards referenced in Privoxy's configuration
1775 file with the line:
1776
1777     actionsfile regression-tests.action
1778
1779 In general, its tests are supposed to work without changing
1780 any other action files, unless you already added lots of
1781 taggers yourself. If you are using taggers that cause problems,
1782 you might have to temporary disable them for Privoxy's CGI pages.
1783
1784 Some of the regression tests rely on Privoxy features that
1785 may be disabled in your configuration. Tests with a level below
1786 7 are supposed to work with all Privoxy configurations (provided
1787 you didn't build with FEATURE_GRACEFUL_TERMINATION).
1788
1789 Tests with level 9 require Privoxy to deliver the User Manual,
1790 tests with level 12 require the CGI editor to be enabled.
1791
1792 =head1 CAVEATS
1793
1794 Expect the configuration file syntax to change with future releases.
1795
1796 =head1 LIMITATIONS
1797
1798 As Privoxy's B<show-request> page only shows client headers,
1799 Privoxy-Regression-Test can't use it to test Privoxy actions
1800 that modify server headers.
1801
1802 As Privoxy-Regression-Test relies on Privoxy's tag feature to
1803 control the actions to test, it currently only works with
1804 Privoxy 3.0.7 or later.
1805
1806 At the moment Privoxy-Regression-Test fetches Privoxy's
1807 configuration page through I<curl>(1), therefore you have to
1808 have I<curl> installed, otherwise you won't be able to run
1809 Privoxy-Regression-Test in a meaningful way.
1810
1811 =head1 SEE ALSO
1812
1813 privoxy(1) curl(1)
1814
1815 =head1 AUTHOR
1816
1817 Fabian Keil <fk@fabiankeil.de>
1818
1819 =cut