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