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