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