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