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