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