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