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