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