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