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