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.104 2008/01/21 18:23:49 fk Exp $
  11 #
  12 # Wish list:
  13 #
  14 # - Update documentation
  15 # - Validate HTTP times.
  16 # - Understand default.action.master comment syntax
  17 #   and verify that we actually block and unblock what
  18 #   the comments claim we do.
  19 # - Implement a HTTP_VERSION directive or allow to
  20 #   specify whole request lines.
  21 # - Support filter regression tests.
  22 # - Add option to fork regression tests and run them in parallel,
  23 #   possibly optional forever.
  24 # - Document magic Expect Header values
  25 # - Internal fuzz support?
  26 #
  27 # Copyright (c) 2007-2008 Fabian Keil <fk@fabiankeil.de>
  28 #
  29 # Permission to use, copy, modify, and distribute this software for any
  30 # purpose with or without fee is hereby granted, provided that the above
  31 # copyright notice and this permission notice appear in all copies.
  32 #
  33 # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  34 # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  35 # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  36 # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  37 # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  38 # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  39 # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  40 #
  41 ############################################################################
  42
  43 use warnings;
  44 use strict;
  45 use Getopt::Long;
  46
  47 use constant {
  48                PRT_VERSION                => 'Privoxy-Regression-Test 0.2',
  49
  50                CURL                       => 'curl',
  51
  52                # CLI option defaults
  53                CLI_RETRIES  => 1,
  54                CLI_LOOPS    => 1,
  55                CLI_MAX_TIME => 5,
  56                CLI_MIN_LEVEL => 0,
  57                CLI_MAX_LEVEL => 25,
  58
  59                PRIVOXY_CGI_URL => 'http://p.p/',
  60                FELLATIO_URL    => 'http://10.0.0.1:8080/',
  61                LEADING_LOG_DATE => 1,
  62                LEADING_LOG_TIME => 1,
  63
  64                DEBUG_LEVEL_FILE_LOADING    => 0,
  65                DEBUG_LEVEL_PAGE_FETCHING   => 0,
  66
  67                VERBOSE_TEST_DESCRIPTION    => 1,
  68
  69                DEBUG_LEVEL_VERBOSE_FAILURE => 1,
  70                # XXX: Only partly implemented and mostly useless.
  71                DEBUG_LEVEL_VERBOSE_SUCCESS => 0,
  72                DEBUG_LEVEL_STATUS          => 1,
  73
  74                # Internal use, don't modify
  75                # Available debug bits:
  76                LL_ERROR                   =>  1,
  77                LL_VERBOSE_FAILURE         =>  2,
  78                LL_PAGE_FETCHING           =>  4,
  79                LL_FILE_LOADING            =>  8,
  80                LL_VERBOSE_SUCCESS         => 16,
  81                LL_STATUS                  => 32,
  82                LL_SOFT_ERROR              => 64,
  83
  84                CLIENT_HEADER_TEST         =>  1,
  85                SERVER_HEADER_TEST         =>  2,
  86                DUMB_FETCH_TEST            =>  3,
  87                METHOD_TEST                =>  4,
  88                TRUSTED_CGI_REQUEST        =>  6,
  89 };
  90
  91 sub init_our_variables () {
  92
  93     our $leading_log_time = LEADING_LOG_TIME;
  94     our $leading_log_date = LEADING_LOG_DATE;
  95
  96     our $privoxy_cgi_url  = PRIVOXY_CGI_URL;
  97
  98     our $verbose_test_description = VERBOSE_TEST_DESCRIPTION;
  99
 100     our $log_level = get_default_log_level();
 101
 102 }
 103
 104 sub get_default_log_level () {
 105
 106     my $log_level = 0;
 107
 108     $log_level |= LL_FILE_LOADING    if DEBUG_LEVEL_FILE_LOADING;
 109     $log_level |= LL_PAGE_FETCHING   if DEBUG_LEVEL_PAGE_FETCHING;
 110     $log_level |= LL_VERBOSE_FAILURE if DEBUG_LEVEL_VERBOSE_FAILURE;
 111     $log_level |= LL_VERBOSE_SUCCESS if DEBUG_LEVEL_VERBOSE_SUCCESS;
 112     $log_level |= LL_STATUS          if DEBUG_LEVEL_STATUS;
 113
 114     # These are intended to be always on.
 115     $log_level |= LL_SOFT_ERROR;
 116     $log_level |= LL_ERROR;
 117
 118     return $log_level;
 119 }
 120
 121 ############################################################################
 122 #
 123 # File loading functions
 124 #
 125 ############################################################################
 126
 127 sub parse_tag ($) {
 128
 129     my $tag = shift;
 130
 131     # Remove anchors
 132     $tag =~ s@[\$\^]@@g;
 133     # Unescape brackets and dots
 134     $tag =~ s@\\(?=[{}().+])@@g;
 135
 136     # log_message("Parsed tag: " . $tag);
 137
 138     check_for_forbidden_characters($tag);
 139
 140     return $tag;
 141 }
 142
 143 sub check_for_forbidden_characters ($) {
 144
 145     my $tag = shift; # XXX: also used to check values though.
 146     my $allowed = '[-=\dA-Za-z{}:.\/();\s,+@"_%\?&]';
 147
 148     unless ($tag =~ m/^$allowed*$/) {
 149         my $forbidden = $tag;
 150         $forbidden =~ s@^$allowed*(.).*@$1@;
 151
 152         l(LL_ERROR, "'" . $tag . "' contains character '" . $forbidden. "' which is unacceptable.");
 153     }
 154 }
 155
 156 sub load_regressions_tests () {
 157
 158     our $privoxy_cgi_url;
 159     my @actionfiles;
 160     my $curl_url        = '';
 161     my $file_number = 0;
 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     foreach (@{get_cgi_page_or_else($curl_url)}) {
 169
 170         if (/<td>(.*?)<\/td><td class=\"buttons\"><a href=\"\/show-status\?file=actions&amp;index=(\d+)\">/) {
 171
 172             my $url = $privoxy_cgi_url . 'show-status?file=actions&index=' . $2;
 173             $actionfiles[$file_number++] = $url;
 174         }
 175     }
 176
 177     l(LL_FILE_LOADING, "Recognized " . @actionfiles . " actions files");
 178
 179     load_action_files(\@actionfiles);
 180 }
 181
 182 sub token_starts_new_test ($) {
 183
 184     my $token = shift;
 185     my @new_test_directives =
 186         ('set header', 'fetch test', 'trusted cgi request', 'request header', 'method test');
 187
 188     foreach my $new_test_directive (@new_test_directives) {
 189         return 1 if $new_test_directive eq $token;
 190     }
 191     return 0;
 192
 193 }
 194
 195 sub tokenize ($) {
 196
 197     my ($token, $value) = (undef, undef);
 198
 199     # Remove leading and trailing white space.
 200     s@^\s*@@;
 201     s@\s*$@@;
 202
 203     # Reverse HTML-encoding
 204     # XXX: Seriously imcomplete.
 205     s@&quot;@"@g;
 206
 207     # Tokenize
 208     if (/^\#\s*([^=]*?)\s*[=]\s*(.*?)\s*$/) {
 209
 210         $token = $1;
 211         $token =~ tr/[A-Z]/[a-z]/;
 212         $value = $2;
 213
 214     } elsif (/^TAG\s*:(.*)$/) {
 215
 216         $token = 'tag';
 217         $value = $1;
 218
 219     }
 220
 221     return ($token, $value);
 222 }
 223
 224 sub enlist_new_test ($$$$$$) {
 225
 226     my ($regression_tests, $token, $value, $si, $ri, $number) = @_;
 227
 228     if ($token eq 'set header') {
 229
 230         l(LL_FILE_LOADING, "Header to set: " . $value);
 231         ${$regression_tests}[$si][$ri]{'type'} = CLIENT_HEADER_TEST;
 232         # Implicit default
 233         $$regression_tests[$si][$ri]{'level'} = CLIENT_HEADER_TEST;
 234
 235     } elsif ($token eq 'request header') {
 236
 237         l(LL_FILE_LOADING, "Header to request: " . $value);
 238         $$regression_tests[$si][$ri]{'type'} = SERVER_HEADER_TEST;
 239         # Implicit default
 240         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 241         $$regression_tests[$si][$ri]{'level'} = SERVER_HEADER_TEST;
 242
 243     } elsif ($token eq 'trusted cgi request') {
 244
 245         l(LL_FILE_LOADING, "CGI URL to test in a dumb way: " . $value);
 246         $$regression_tests[$si][$ri]{'type'} = TRUSTED_CGI_REQUEST;
 247         # Implicit default
 248         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 249         $$regression_tests[$si][$ri]{'level'} = TRUSTED_CGI_REQUEST;
 250
 251     } elsif ($token eq 'fetch test') {
 252
 253         l(LL_FILE_LOADING, "URL to test in a dumb way: " . $value);
 254         $$regression_tests[$si][$ri]{'type'} = DUMB_FETCH_TEST;
 255         # Implicit default
 256         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 257         $$regression_tests[$si][$ri]{'level'} = DUMB_FETCH_TEST;
 258
 259     } elsif ($token eq 'method test') {
 260
 261         l(LL_FILE_LOADING, "Method to test: " . $value);
 262         $$regression_tests[$si][$ri]{'type'} = METHOD_TEST;
 263         # Implicit default
 264         $$regression_tests[$si][$ri]{'expected-status-code'} = 200;
 265         $$regression_tests[$si][$ri]{'level'} = METHOD_TEST;
 266
 267     } else {
 268
 269         die "Incomplete '" . $token . "' support detected.";
 270
 271     }
 272
 273     check_for_forbidden_characters($value);
 274
 275     $$regression_tests[$si][$ri]{'data'} = $value;
 276
 277     # For function that only get passed single tests
 278     $$regression_tests[$si][$ri]{'section-id'} = $si;
 279     $$regression_tests[$si][$ri]{'regression-test-id'} = $ri;
 280     $$regression_tests[$si][$ri]{'number'} = $number - 1;
 281     l(LL_FILE_LOADING,
 282       "Regression test " . $number . " (section:" . $si . "):");
 283 }
 284
 285 sub load_action_files ($) {
 286
 287     # initialized here
 288     our %actions;
 289     our @regression_tests;
 290
 291     my $actionfiles_ref = shift;
 292     my @actionfiles = @{$actionfiles_ref};
 293
 294     my $si = 0;  # Section index
 295     my $ri = -1; # Regression test index
 296     my $count = 0;
 297
 298     my $ignored = 0;
 299
 300     l(LL_STATUS, "Loading regression tests from action file(s) delivered by Privoxy.");
 301
 302     for my $file_number (0 .. @actionfiles - 1) {
 303
 304         my $curl_url = ' "' . $actionfiles[$file_number] . '"';
 305         my $actionfile = undef;
 306
 307         foreach (@{get_cgi_page_or_else($curl_url)}) {
 308
 309             my $no_checks = 0;
 310             chomp;
 311
 312             if (/<h2>Contents of Actions File (.*?)</) {
 313                 $actionfile = $1;
 314                 next;
 315             }
 316             next unless defined $actionfile;
 317
 318             last if (/<\/pre>/);
 319
 320             my ($token, $value) = tokenize($_);
 321
 322             next unless defined $token;
 323
 324             # Load regression tests
 325
 326             if (token_starts_new_test($token)) {
 327
 328                 # Beginning of new regression test.
 329                 $ri++;
 330                 $count++;
 331                 enlist_new_test(\@regression_tests, $token, $value, $si, $ri, $count);
 332             }
 333
 334             if ($si == -1 || $ri == -1) {
 335                 # No beginning of a test detected yet,
 336                 # so we don't care about any other test
 337                 # attributes.
 338                 next;
 339             }
 340
 341             if ($token eq 'expect header') {
 342
 343                 l(LL_FILE_LOADING, "Detected expectation: " . $value);
 344                 $regression_tests[$si][$ri]{'expect-header'} = $value;
 345
 346             } elsif ($token eq 'tag') {
 347
 348                 next if ($ri == -1);
 349
 350                 my $tag = parse_tag($value);
 351
 352                 # We already checked in parse_tag() after filtering
 353                 $no_checks = 1;
 354
 355                 l(LL_FILE_LOADING, "Detected TAG: " . $tag);
 356
 357                 # Save tag for all tests in this section
 358                 do {
 359                     $regression_tests[$si][$ri]{'tag'} = $tag;
 360                 } while ($ri-- > 0);
 361
 362                 $si++;
 363                 $ri = -1;
 364
 365             } elsif ($token eq 'ignore' && $value =~ /Yes/i) {
 366
 367                 l(LL_FILE_LOADING, "Ignoring section: " . test_content_as_string($regression_tests[$si][$ri]));
 368                 $regression_tests[$si][$ri]{'ignore'} = 1;
 369                 $ignored++;
 370
 371             } elsif ($token eq 'expect status code') {
 372
 373                 l(LL_FILE_LOADING, "Expecting status code: " . $value);
 374                 $regression_tests[$si][$ri]{'expected-status-code'} = $value;
 375
 376             } elsif ($token eq 'level') { # XXX: stupid name
 377
 378                 $value =~ s@(\d+).*@$1@;
 379                 l(LL_FILE_LOADING, "Level: " . $value);
 380                 $regression_tests[$si][$ri]{'level'} = $value;
 381
 382             } elsif ($token eq 'method') {
 383
 384                 l(LL_FILE_LOADING, "Method: " . $value);
 385                 $regression_tests[$si][$ri]{'method'} = $value;
 386             } else {
 387                 # We don't use it, so we don't need
 388                 $no_checks = 1;
 389             }
 390             # XXX: Neccessary?
 391             check_for_forbidden_characters($value) unless $no_checks;
 392             check_for_forbidden_characters($token);
 393         }
 394     }
 395
 396     l(LL_FILE_LOADING, "Done loading " . $count . " regression tests."
 397       . " Of which " . $ignored. " will be ignored)\n");
 398 }
 399
 400 ############################################################################
 401 #
 402 # Regression test executing functions
 403 #
 404 ############################################################################
 405
 406 sub execute_regression_tests () {
 407
 408     our @regression_tests;
 409     my $loops = get_cli_option('loops');
 410     my $all_tests    = 0;
 411     my $all_failures = 0;
 412     my $all_successes = 0;
 413
 414     unless (@regression_tests) {
 415
 416         l(LL_STATUS, "No regression tests found.");
 417         return;
 418     }
 419
 420     l(LL_STATUS, "Executing regression tests ...");
 421
 422     while ($loops-- > 0) {
 423
 424         my $successes = 0;
 425         my $tests = 0;
 426         my $failures;
 427         my $skipped = 0;
 428
 429         for my $s (0 .. @regression_tests - 1) {
 430
 431             my $r = 0;
 432
 433             while (defined $regression_tests[$s][$r]) {
 434
 435                 die "Section id mismatch" if ($s != $regression_tests[$s][$r]{'section-id'});
 436                 die "Regression test id mismatch" if ($r != $regression_tests[$s][$r]{'regression-test-id'});
 437
 438                 my $number = $regression_tests[$s][$r]{'number'};
 439
 440                 if ($regression_tests[$s][$r]{'ignore'}
 441                     or level_is_unacceptable($regression_tests[$s][$r]{'level'})
 442                     or test_number_is_unacceptable($number)) {
 443
 444                     $skipped++;
 445
 446                 } else {
 447
 448                     my $result = execute_regression_test($regression_tests[$s][$r]);
 449
 450                     log_result($regression_tests[$s][$r], $result, $tests);
 451
 452                     $successes += $result;
 453                     $tests++;
 454                 }
 455                 $r++;
 456             }
 457         }
 458         $failures = $tests - $successes;
 459
 460         log_message("Executed " . $tests . " regression tests. " .
 461             'Skipped ' . $skipped . '. ' .
 462             $successes . " successes, " . $failures . " failures.");
 463
 464         $all_tests    += $tests;
 465         $all_failures += $failures;
 466         $all_successes += $successes;
 467
 468     }
 469
 470
 471     if (get_cli_option('loops') > 1) {
 472         log_message("Total: Executed " . $all_tests . " regression tests. " .
 473             $all_successes . " successes, " . $all_failures . " failures.");
 474     }
 475 }
 476
 477 sub level_is_unacceptable ($) {
 478     my $level = shift;
 479     return ((cli_option_is_set('level') and get_cli_option('level') != $level)
 480             or ($level < get_cli_option('min-level'))
 481             or ($level > get_cli_option('max-level'))
 482             );
 483 }
 484
 485 sub test_number_is_unacceptable ($) {
 486     my $test_number = shift;
 487     return (cli_option_is_set('test-number')
 488             and get_cli_option('test-number') != $test_number)
 489 }
 490
 491
 492 # XXX: somewhat misleading name
 493 sub execute_regression_test ($) {
 494
 495     my $test_ref = shift;
 496     my %test = %{$test_ref};
 497     my $result = 0;
 498
 499     if ($test{'type'} == CLIENT_HEADER_TEST) {
 500
 501         $result = execute_client_header_regression_test($test_ref);
 502
 503     } elsif ($test{'type'} == SERVER_HEADER_TEST) {
 504
 505         $result = execute_server_header_regression_test($test_ref);
 506
 507     } elsif ($test{'type'} == DUMB_FETCH_TEST
 508           or $test{'type'} == TRUSTED_CGI_REQUEST) {
 509
 510         $result = execute_dumb_fetch_test($test_ref);
 511
 512     } elsif ($test{'type'} == METHOD_TEST) {
 513
 514         $result = execute_method_test($test_ref);
 515
 516     } else {
 517
 518         die "Unsuported test type detected: " . $test{'type'};
 519
 520     }
 521
 522
 523     return $result;
 524 }
 525
 526 sub execute_method_test ($) {
 527
 528     my $test_ref = shift;
 529     my %test = %{$test_ref};
 530     my $buffer_ref;
 531     my $result = 0;
 532     my $status_code;
 533     my $method = $test{'data'};
 534
 535     my $curl_parameters = '';
 536     my $expected_status_code = $test{'expected-status-code'};
 537
 538     if ($method =~ /HEAD/i) {
 539
 540         $curl_parameters .= '--head ';
 541
 542     } else {
 543
 544         $curl_parameters .= '-X ' . $method . ' ';
 545     }
 546
 547     $curl_parameters .= PRIVOXY_CGI_URL;
 548
 549     $buffer_ref = get_page_with_curl($curl_parameters);
 550     $status_code = get_status_code($buffer_ref);
 551
 552     $result = check_status_code_result($status_code, $expected_status_code);
 553
 554     return $result;
 555 }
 556
 557
 558 sub execute_dumb_fetch_test ($) {
 559
 560     my $test_ref = shift;
 561     my %test = %{$test_ref};
 562     my $buffer_ref;
 563     my $result = 0;
 564     my $status_code;
 565
 566     my $curl_parameters = '';
 567     my $expected_status_code = $test{'expected-status-code'};
 568
 569     if (defined $test{method}) {
 570         $curl_parameters .= '-X ' . $test{method} . ' ';
 571     }
 572     if ($test{type} == TRUSTED_CGI_REQUEST) {
 573         $curl_parameters .= '--referer ' . PRIVOXY_CGI_URL . ' ';
 574     }
 575
 576     $curl_parameters .= $test{'data'};
 577
 578     $buffer_ref = get_page_with_curl($curl_parameters);
 579     $status_code = get_status_code($buffer_ref);
 580
 581     $result = check_status_code_result($status_code, $expected_status_code);
 582
 583     return $result;
 584 }
 585
 586 sub check_status_code_result ($$) {
 587
 588     my $status_code = shift;
 589     my $expected_status_code = shift;
 590     my $result = 0;
 591
 592     if ($expected_status_code == $status_code) {
 593
 594         $result = 1;
 595         l(LL_VERBOSE_SUCCESS,
 596           "Yay. We expected status code " . $expected_status_code . ", and received: " . $status_code . '.');
 597
 598     } elsif (cli_option_is_set('fuzzer-feeding') and $status_code == 123) {
 599
 600         l(LL_VERBOSE_FAILURE,
 601           "Oh well. Status code lost while fuzzing. Can't check if it was " . $expected_status_code . '.');
 602
 603     } else {
 604
 605         l(LL_VERBOSE_FAILURE,
 606           "Ooops. We expected status code " . $expected_status_code . ", but received: " . $status_code . '.');
 607
 608     }
 609
 610     return $result;
 611 }
 612
 613 sub execute_client_header_regression_test ($) {
 614
 615     my $test_ref = shift;
 616     my $buffer_ref;
 617     my $header;
 618     my $result = 0;
 619
 620     $buffer_ref = get_show_request_with_curl($test_ref);
 621
 622     $header = get_header($buffer_ref, $test_ref);
 623     $result = check_header_result($test_ref, $header);
 624
 625     return $result;
 626 }
 627
 628 sub execute_server_header_regression_test ($) {
 629
 630     my $test_ref = shift;
 631     my $buffer_ref;
 632     my $header;
 633     my $result = 0;
 634
 635     $buffer_ref = get_head_with_curl($test_ref);
 636
 637     $header = get_server_header($buffer_ref, $test_ref);
 638     $result = check_header_result($test_ref, $header);
 639
 640     return $result;
 641 }
 642
 643
 644 sub interpret_result ($) {
 645     my $success = shift;
 646     return $success ? "Success" : "Failure";
 647 }
 648
 649 sub check_header_result ($$) {
 650
 651     my $test_ref = shift;
 652     my $header = shift;
 653
 654     my %test = %{$test_ref};
 655     my $expect_header = $test{'expect-header'};
 656     my $success = 0;
 657
 658     $header =~ s@   @ @g if defined($header);
 659
 660     if ($expect_header eq 'NO CHANGE') {
 661
 662         if (defined($header) and $header eq $test{'data'}) {
 663
 664             $success = 1;
 665
 666         } else {
 667
 668             $header //= "REMOVAL";
 669             l(LL_VERBOSE_FAILURE,
 670               "Ooops. Got: " . $header . " while expecting: " . $expect_header);
 671         }
 672
 673     } elsif ($expect_header eq 'REMOVAL') {
 674
 675         if (defined($header) and $header eq $test{'data'}) {
 676
 677             l(LL_VERBOSE_FAILURE,
 678               "Ooops. Expected removal but: " . $header . " is still there.");
 679
 680         } else {
 681
 682             # XXX: Use more reliable check here and make sure
 683             # the header has a different name.
 684             $success = 1;
 685
 686         }
 687
 688     } elsif ($expect_header eq 'SOME CHANGE') {
 689
 690         if (defined($header) and not $header eq $test{'data'}) {
 691
 692             $success = 1;
 693
 694         } else {
 695
 696             $header //= "REMOVAL";
 697             l(LL_VERBOSE_FAILURE,
 698               "Ooops. Got: " . $header . " while expecting: SOME CHANGE");
 699         }
 700
 701
 702     } else {
 703
 704         if (defined($header) and $header eq $expect_header) {
 705
 706             $success = 1;
 707
 708         } else {
 709
 710             $header //= "'No matching header'"; # XXX: No header detected to be precise
 711             l(LL_VERBOSE_FAILURE,
 712               "Ooops. Got: " . $header . " while expecting: " . $expect_header);
 713         }
 714     }
 715     return $success;
 716 }
 717
 718
 719 sub get_header_name ($) {
 720
 721     my $header = shift;
 722
 723     $header =~ s@(.*?: ).*@$1@;
 724
 725     return $header;
 726 }
 727
 728 sub get_header ($$) {
 729
 730     our $filtered_request = '';
 731
 732     my $buffer_ref = shift;
 733     my $test_ref = shift;
 734
 735     my %test = %{$test_ref};
 736     my @buffer = @{$buffer_ref};
 737
 738     my $expect_header = $test{'expect-header'};
 739
 740     my $line;
 741     my $processed_request_reached = 0;
 742     my $read_header = 0;
 743     my $processed_request = '';
 744     my $header;
 745     my $header_to_get;
 746
 747     if ($expect_header eq 'REMOVAL'
 748      or $expect_header eq 'NO CHANGE'
 749      or  $expect_header eq 'SOME CHANGE') {
 750
 751         $expect_header = $test{'data'};
 752
 753     }
 754
 755     $header_to_get = get_header_name($expect_header);
 756
 757     foreach (@buffer) {
 758
 759         # Skip everything before the Processed request
 760         if (/Processed Request/) {
 761             $processed_request_reached = 1;
 762             next;
 763         }
 764         next unless $processed_request_reached;
 765
 766         # End loop after the Processed request
 767         last if (/<\/pre>/);
 768
 769         # Ditch tags and leading/trailing white space.
 770         s@^\s*<.*?>@@g;
 771         s@\s*$@@g;
 772
 773         $filtered_request .=  "\n" . $_;
 774
 775         if (/^$header_to_get/) {
 776             $read_header = 1;
 777             $header = $_;
 778             last;
 779         }
 780     }
 781
 782     return $header;
 783 }
 784
 785 sub get_server_header ($$) {
 786
 787     my $buffer_ref = shift;
 788     my $test_ref = shift;
 789
 790     my %test = %{$test_ref};
 791     my @buffer = @{$buffer_ref};
 792
 793     my $expect_header = $test{'expect-header'};
 794     my $header;
 795     my $header_to_get;
 796
 797     if ($expect_header eq 'REMOVAL'
 798      or $expect_header eq 'NO CHANGE'
 799      or  $expect_header eq 'SOME CHANGE') {
 800
 801         $expect_header = $test{'data'};
 802
 803     }
 804
 805     $header_to_get = get_header_name($expect_header);
 806
 807     foreach (@buffer) {
 808
 809         # XXX: shoul probably verify that the request
 810         # was actually answered by Fellatio.
 811         if (/^$header_to_get/) {
 812             $header = $_;
 813             $header =~ s@\s*$@@g;
 814             last;
 815         }
 816     }
 817
 818     return $header;
 819 }
 820
 821 sub get_header_to_check ($) {
 822
 823     # No longer in use but not removed yet.
 824
 825     my $buffer_ref = shift;
 826     my $header;
 827     my @buffer = @{$buffer_ref};
 828     my $line;
 829     my $processed_request_reached = 0;
 830     my $read_header = 0;
 831     my $processed_request = '';
 832
 833     l(LL_ERROR, "You are not supposed to use get_header_to_()!");
 834
 835     foreach (@buffer) {
 836
 837         # Skip everything before the Processed request
 838         if (/Processed Request/) {
 839             $processed_request_reached = 1;
 840             next;
 841         }
 842         next unless $processed_request_reached;
 843
 844         # End loop after the Processed request
 845         last if (/<\/pre>/);
 846
 847         # Ditch tags and leading/trailing white space.
 848         s@^\s*<.*?>@@g;
 849         s@\s*$@@g;
 850
 851         $processed_request .= $_;
 852
 853         if (/^X-Privoxy-Regression-Test/) {
 854             $read_header = 1;
 855             next;
 856         }
 857
 858         if ($read_header) {
 859             $header = $_;
 860             $read_header = 0;
 861         }
 862
 863     }
 864
 865     return $header;
 866 }
 867
 868 sub get_status_code ($) {
 869
 870     my $buffer_ref = shift;
 871     my @buffer = @{$buffer_ref};
 872
 873     foreach (@buffer) {
 874
 875         if (/^HTTP\/\d\.\d (\d{3})/) {
 876
 877             return $1;
 878
 879         } else {
 880
 881             return '123' if cli_option_is_set('fuzzer-feeding');
 882             chomp;
 883             l(LL_ERROR, 'Unexpected buffer line: "' . $_ . '"');
 884         }
 885     }
 886 }
 887
 888 sub get_test_keys () {
 889     return ('tag', 'data', 'expect-header', 'ignore');
 890 }
 891
 892 # XXX: incomplete
 893 sub test_content_as_string ($) {
 894
 895     my $test_ref = shift;
 896     my %test = %{$test_ref};
 897
 898     my $s = "\n\t";
 899
 900     foreach my $key (get_test_keys()) {
 901         #$test{$key} = $test{$key} // 'undefined';
 902         $test{$key} = 'Not set' unless (defined $test{$key});
 903     }
 904
 905     $s .= 'Tag: ' . $test{'tag'};
 906     $s .= "\n\t";
 907     $s .= 'Set header: ' . $test{'data'}; # XXX: adjust for other test types
 908     $s .= "\n\t";
 909     $s .= 'Expected header: ' . $test{'expect-header'};
 910     $s .= "\n\t";
 911     $s .= 'Ignore: ' . $test{'ignore'};
 912
 913     return $s;
 914 }
 915
 916 ############################################################################
 917 #
 918 # HTTP fetch functions
 919 #
 920 ############################################################################
 921
 922 sub check_for_curl () {
 923     my $curl = CURL;
 924     l(LL_ERROR, "No curl found.") unless (`which $curl`);
 925 }
 926
 927 sub get_cgi_page_or_else ($) {
 928
 929     my $cgi_url = shift;
 930     my $content_ref = get_page_with_curl($cgi_url);
 931     my $status_code = get_status_code($content_ref);
 932
 933     if (200 != $status_code) {
 934
 935         my $log_message = "Failed to fetch Privoxy CGI Page. " .
 936                           "Received status code ". $status_code .
 937                           " while only 200 is acceptable.";
 938
 939         if (cli_option_is_set('fuzzer-feeding')) {
 940
 941             $log_message .= " Ignored due to fuzzer feeding.";
 942             l(LL_SOFT_ERROR, $log_message)
 943
 944         } else {
 945
 946             l(LL_ERROR, $log_message);
 947
 948         }
 949     }
 950
 951     return $content_ref;
 952 }
 953
 954 sub get_show_request_with_curl ($) {
 955
 956     our $privoxy_cgi_url;
 957     my $test_ref = shift;
 958     my %test = %{$test_ref};
 959
 960     my $curl_parameters = ' ';
 961
 962     # Enable the action to test
 963     $curl_parameters .= '-H \'X-Privoxy-Control: ' . $test{'tag'} . '\' ';
 964     # The header to filter
 965     $curl_parameters .= '-H \'' . $test{'data'} . '\' ';
 966
 967     $curl_parameters .= ' ';
 968     $curl_parameters .= $privoxy_cgi_url;
 969     $curl_parameters .= 'show-request';
 970
 971     return get_cgi_page_or_else($curl_parameters);
 972 }
 973
 974
 975 sub get_head_with_curl ($) {
 976
 977     our $fellatio_url = FELLATIO_URL;
 978     my $test_ref = shift;
 979     my %test = %{$test_ref};
 980
 981     my $curl_parameters = ' ';
 982
 983     # Enable the action to test
 984     $curl_parameters .= '-H \'X-Privoxy-Control: ' . $test{'tag'} . '\' ';
 985     # The header to filter
 986     $curl_parameters .= '-H \'X-Gimme-Head-With: ' . $test{'data'} . '\' ';
 987     $curl_parameters .= '--head ';
 988
 989     $curl_parameters .= ' ';
 990     $curl_parameters .= $fellatio_url;
 991
 992     return get_page_with_curl($curl_parameters);
 993 }
 994
 995
 996 sub get_page_with_curl ($) {
 997
 998     my $parameters = shift;
 999     my @buffer;
1000     my $curl_line = CURL;
1001     my $retries_left = get_cli_option('retries') + 1;
1002     my $failure_reason;
1003
1004     if (cli_option_is_set('privoxy-address')) {
1005         $curl_line .= ' --proxy ' . get_cli_option('privoxy-address');
1006     }
1007
1008     # Let Privoxy emit two log messages less.
1009     $curl_line .= ' -H \'Proxy-Connection:\' ' unless $parameters =~ /Proxy-Connection:/;
1010     $curl_line .= ' -H \'Connection: close\' ' unless $parameters =~ /Connection:/;
1011     # We don't care about fetch statistic.
1012     $curl_line .= " -s ";
1013     # We do care about the failure reason if any.
1014     $curl_line .= " -S ";
1015     # We want to see the HTTP status code
1016     $curl_line .= " --include ";
1017     # We want to advertise ourselves
1018     $curl_line .= " --user-agent '" . PRT_VERSION . "' ";
1019     # We aren't too patient
1020     $curl_line .= " --max-time '" . get_cli_option('max-time') . "' ";
1021
1022     $curl_line .= $parameters;
1023     # XXX: still necessary?
1024     $curl_line .= ' 2>&1';
1025
1026     l(LL_PAGE_FETCHING, "Executing: " . $curl_line);
1027
1028     do {
1029         @buffer = `$curl_line`;
1030
1031         if ($?) {
1032             $failure_reason = array_as_string(\@buffer);
1033             chomp $failure_reason;
1034             l(LL_SOFT_ERROR, "Fetch failure: '" . $failure_reason . $! ."'");
1035         }
1036     } while ($? && --$retries_left);
1037
1038     unless ($retries_left) {
1039         l(LL_ERROR,
1040           "Running curl failed " . get_cli_option('retries') .
1041           " times in a row. Last error: '" . $failure_reason . "'.");
1042     }
1043
1044     return \@buffer;
1045 }
1046
1047
1048 ############################################################################
1049 #
1050 # Log functions
1051 #
1052 ############################################################################
1053
1054 sub array_as_string ($) {
1055     my $array_ref = shift;
1056     my $string = '';
1057
1058     foreach (@{$array_ref}) {
1059         $string .= $_;
1060     }
1061
1062     return $string;
1063 }
1064
1065
1066 sub show_test ($) {
1067     my $test_ref = shift;
1068     log_message('Test is:' . test_content_as_string($test_ref));
1069 }
1070
1071 # Conditional log
1072 sub l ($$) {
1073     our $log_level;
1074     my $this_level = shift;
1075     my $message = shift;
1076
1077     return unless ($log_level & $this_level);
1078
1079     if (LL_ERROR & $this_level) {
1080         $message = 'Oh noes. ' . $message . ' Fatal error. Exiting.';
1081     }
1082
1083     log_message($message);
1084
1085     if (LL_ERROR & $this_level) {
1086         exit;
1087     }
1088 }
1089
1090 sub log_message ($) {
1091
1092     my $message = shift;
1093
1094     our $logfile;
1095     our $no_logging;
1096     our $leading_log_date;
1097     our $leading_log_time;
1098
1099     my $time_stamp = '';
1100     my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime time;
1101
1102     if ($leading_log_date || $leading_log_time) {
1103
1104         if ($leading_log_date) {
1105             $year += 1900;
1106             $mon  += 1;
1107             $time_stamp = sprintf("%i/%.2i/%.2i", $year, $mon, $mday);
1108         }
1109
1110         if ($leading_log_time) {
1111             $time_stamp .= ' ' if $leading_log_date;
1112             $time_stamp.= sprintf("%.2i:%.2i:%.2i", $hour, $min, $sec);
1113         }
1114
1115         $message = $time_stamp . ": " . $message;
1116     }
1117
1118
1119     printf(STDERR "%s\n", $message);
1120
1121 }
1122
1123 sub log_result ($$) {
1124
1125     our $verbose_test_description;
1126     our $filtered_request;
1127
1128     my $test_ref = shift;
1129     my $result = shift;
1130     my $number = shift;
1131
1132     my %test = %{$test_ref};
1133     my $message = '';
1134
1135     $message .= interpret_result($result);
1136     $message .= " for test ";
1137     $message .= $number;
1138     $message .= '/';
1139     $message .= $test{'number'};
1140     $message .= '/';
1141     $message .= $test{'section-id'};
1142     $message .= '/';
1143     $message .= $test{'regression-test-id'};
1144     $message .= '.';
1145
1146     if ($verbose_test_description) {
1147
1148         if ($test{'type'} == CLIENT_HEADER_TEST) {
1149
1150             $message .= ' Header ';
1151             $message .= quote($test{'data'});
1152             $message .= ' and tag ';
1153             $message .= quote($test{'tag'});
1154
1155         } elsif ($test{'type'} == SERVER_HEADER_TEST) {
1156
1157             $message .= ' Request Header ';
1158             $message .= quote($test{'data'});
1159             $message .= ' and tag ';
1160             $message .= quote($test{'tag'});
1161
1162         } elsif ($test{'type'} == DUMB_FETCH_TEST) {
1163
1164             $message .= ' URL ';
1165             $message .= quote($test{'data'});
1166             $message .= ' and expected status code ';
1167             $message .= quote($test{'expected-status-code'});
1168
1169         } elsif ($test{'type'} == TRUSTED_CGI_REQUEST) {
1170
1171             $message .= ' CGI URL ';
1172             $message .= quote($test{'data'});
1173             $message .= ' and expected status code ';
1174             $message .= quote($test{'expected-status-code'});
1175
1176         } elsif ($test{'type'} == METHOD_TEST) {
1177
1178             $message .= ' HTTP method ';
1179             $message .= quote($test{'data'});
1180             $message .= ' and expected status code ';
1181             $message .= quote($test{'expected-status-code'});
1182
1183         } else {
1184
1185             die "Incomplete support for test type " . $test{'type'} .  " detected.";
1186
1187         }
1188     }
1189
1190     log_message($message) unless ($result && cli_option_is_set('silent'));
1191 }
1192
1193 sub quote ($) {
1194     my $s = shift;
1195     return '\'' . $s . '\'';
1196 }
1197
1198 sub print_version () {
1199     printf PRT_VERSION . "\n" . 'Copyright (C) 2007-2008 Fabian Keil <fk@fabiankeil.de>' . "\n";
1200 }
1201
1202 sub help () {
1203
1204     our %cli_options;
1205
1206     print_version();
1207
1208     print << "    EOF"
1209
1210 Options and their default values if they have any:
1211     [--debug $cli_options{'debug'}]
1212     [--fuzzer-feeding]
1213     [--help]
1214     [--level]
1215     [--loops $cli_options{'loops'}]
1216     [--max-level $cli_options{'max-level'}]
1217     [--max-time $cli_options{'max-time'}]
1218     [--min-level $cli_options{'min-level'}]
1219     [--privoxy-address]
1220     [--retries $cli_options{'retries'}]
1221     [--silent]
1222     [--version]
1223 see "perldoc $0" for more information
1224     EOF
1225     ;
1226     exit(0);
1227 }
1228
1229 sub init_cli_options () {
1230
1231     our %cli_options;
1232     our $log_level;
1233
1234     $cli_options{'min-level'} = CLI_MIN_LEVEL;
1235     $cli_options{'max-level'} = CLI_MAX_LEVEL;
1236     $cli_options{'debug'}  = $log_level;
1237     $cli_options{'loops'}  = CLI_LOOPS;
1238     $cli_options{'max-time'}  = CLI_MAX_TIME;
1239     $cli_options{'retries'}  = CLI_RETRIES;
1240 }
1241
1242 sub parse_cli_options () {
1243
1244     our %cli_options;
1245     our $log_level;
1246
1247     init_cli_options();
1248
1249     GetOptions (
1250                 'debug=s' => \$cli_options{'debug'},
1251                 'help'     => sub { help },
1252                 'silent' => \$cli_options{'silent'},
1253                 'min-level=s' => \$cli_options{'min-level'},
1254                 'max-level=s' => \$cli_options{'max-level'},
1255                 'privoxy-address=s' => \$cli_options{'privoxy-address'},
1256                 'level=s' => \$cli_options{'level'},
1257                 'loops=s' => \$cli_options{'loops'},
1258                 'test-number=s' => \$cli_options{'test-number'},
1259                 'fuzzer-feeding' => \$cli_options{'fuzzer-feeding'},
1260                 'retries=s' => \$cli_options{'retries'},
1261                 'max-time=s' => \$cli_options{'max-time'},
1262                 'version'  => sub { print_version && exit(0) }
1263     );
1264     $log_level |= $cli_options{'debug'};
1265 }
1266
1267 sub cli_option_is_set ($) {
1268
1269     our %cli_options;
1270     my $cli_option = shift;
1271
1272     return defined $cli_options{$cli_option};
1273 }
1274
1275
1276 sub get_cli_option ($) {
1277
1278     our %cli_options;
1279     my $cli_option = shift;
1280
1281     die "Unknown CLI option: $cli_option" unless defined $cli_options{$cli_option};
1282
1283     return $cli_options{$cli_option};
1284 }
1285
1286
1287 sub main () {
1288
1289     init_our_variables();
1290     parse_cli_options();
1291     check_for_curl();
1292     load_regressions_tests();
1293     execute_regression_tests();
1294 }
1295
1296 main();
1297
1298 =head1 NAME
1299
1300 B<privoxy-regression-test> - A regression test "framework" for Privoxy.
1301
1302 =head1 SYNOPSIS
1303
1304 B<privoxy-regression-test> [B<--debug bitmask>] [B<--fuzzer-feeding>] [B<--help>]
1305 [B<--level level>] [B<--loops count>] [B<--max-level max-level>]
1306 [B<--max-time max-time>] [B<--min-level min-level>] B<--privoxy-address proxy-address>
1307 [B<--retries retries>] [B<--silent>] [B<--version>]
1308
1309 =head1 DESCRIPTION
1310
1311 Privoxy-Regression-Test is supposed to one day become
1312 a regression test suite for Privoxy. It's not quite there
1313 yet, however, and can currently only test client header
1314 actions and check the returned status code for requests
1315 to arbitrary URLs.
1316
1317 Client header actions are tested by requesting
1318 B<http://config.privoxy.org/show-request> and checking whether
1319 or not Privoxy modified the original request as expected.
1320
1321 The original request contains both the header the action-to-be-tested
1322 acts upon and an additional tagger-triggering header that enables
1323 the action to test.
1324
1325 =head1 CONFIGURATION FILE SYNTAX
1326
1327 Privoxy-Regression-Test's configuration is embedded in
1328 Privoxy action files and loaded through Privoxy's web interface.
1329
1330 It makes testing a Privoxy version running on a remote system easier
1331 and should prevent you from updating your tests without updating Privoxy's
1332 configuration accordingly.
1333
1334 A client-header-action test section looks like this:
1335
1336     # Set Header    = Referer: http://www.example.org.zwiebelsuppe.exit/
1337     # Expect Header = Referer: http://www.example.org/
1338     {+client-header-filter{hide-tor-exit-notation} -hide-referer}
1339     TAG:^client-header-filter\{hide-tor-exit-notation\}$
1340
1341 The example above causes Privoxy-Regression-Test to set
1342 the header B<Referer: http://www.example.org.zwiebelsuppe.exit/>
1343 and to expect it to be modified to
1344 B<Referer: http://www.example.org/>.
1345
1346 When testing this section, Privoxy-Regression-Test will set the header
1347 B<X-Privoxy-Control: client-header-filter{hide-tor-exit-notation}>
1348 causing the B<privoxy-control> tagger to create the tag
1349 B<client-header-filter{hide-tor-exit-notation}> which will finally
1350 cause Privoxy to enable the action section.
1351
1352 Note that the actions itself are only used by Privoxy,
1353 Privoxy-Regression-Test ignores them and will be happy
1354 as long as the expectations are satisfied.
1355
1356 A fetch test looks like this:
1357
1358     # Fetch Test = http://p.p/user-manual
1359     # Expect Status Code = 302
1360
1361 It tells Privoxy-Regression-Test to request B<http://p.p/user-manual>
1362 and to expect a response with the HTTP status code B<302>. Obviously that's
1363 not a very thorough test and mainly useful to get some code coverage
1364 for Valgrind or to verify that the templates are installed correctly.
1365
1366 If you want to test CGI pages that require a trusted
1367 referer, you can use:
1368
1369     # Trusted CGI Request =  http://p.p/edit-actions
1370
1371 It works like ordinary fetch tests, but sets the referer
1372 header to a trusted value.
1373
1374 If no explicit status code expectation is set, B<200> is used.
1375
1376 Additionally all tests have test levels to let the user
1377 control which ones to execute (see I<OPTIONS> below).
1378 Test levels are either set with the B<Level> directive,
1379 or implicitly through the test type.
1380
1381 Fetch tests default to level 6, tests for trusted
1382 CGI requests to level 3 and client-header-action tests
1383 to level 1.
1384
1385 =head1 OPTIONS
1386
1387 B<--debug bitmask> Add the bitmask provided as integer
1388 to the debug settings.
1389
1390 B<--fuzzer-feeding> Ignore some errors that would otherwise
1391 cause Privoxy-Regression-Test to abort the test because
1392 they shouldn't happen in normal operation. This option is
1393 intended to be used if Privoxy-Regression-Test is only
1394 used to feed a fuzzer in which case there's a high chance
1395 that Privoxy gets an invalid request and returns an error
1396 message.
1397
1398 B<--help> Shows available command line options.
1399
1400 B<--level level> Only execute tests with the specified B<level>.
1401
1402 B<--loop count> Loop through the regression tests B<count> times.
1403 Useful to feed a fuzzer, or when doing stress tests with
1404 several Privoxy-Regression-Test instances running at the same
1405 time.
1406
1407 B<--max-level max-level> Only execute tests with a B<level>
1408 below or equal to the numerical B<max-level>.
1409
1410 B<--max-time max-time> Give Privoxy B<max-time> seconds
1411 to return data. Increasing the default may make sense when
1412 Privoxy is run through Valgrind, decreasing the default may
1413 make sense when Privoxy-Regression-Test is used to feed
1414 a fuzzer.
1415
1416 B<--min-level min-level> Only execute tests with a B<level>
1417 above or equal to the numerical B<min-level>.
1418
1419 B<--privoxy-address proxy-address> Privoxy's listening address.
1420 If it's not set, the value of the environment variable http_proxy
1421 will be used. B<proxy-address> has to be specified in http_proxy
1422 syntax.
1423
1424 B<--retries retries> Retry B<retries> times.
1425
1426 B<--silent> Don't log succesful test runs.
1427
1428 B<--version> Print version and exit.
1429
1430 The second dash is optional, options can be shortened,
1431 as long as there are no ambiguities.
1432
1433 =head1 PRIVOXY CONFIGURATION
1434
1435 Privoxy-Regression-Test is shipped with B<regression-tests.action>
1436 which aims to test all official client-header modifying actions
1437 and can be used to verify that the templates and the user manual
1438 files are installed correctly.
1439
1440 To use it, it has to be copied in Privoxy's configuration
1441 directory, and afterwards referenced in Privoxy's configuration
1442 file with the line:
1443
1444     actionsfile regression-tests.action
1445
1446 In general, its tests are supposed to work without changing
1447 any other action files, unless you already added lots of
1448 taggers yourself. If you are using taggers that cause problems,
1449 you might have to temporary disable them for Privoxy's CGI pages.
1450
1451 Some of the regression tests rely on Privoxy features that
1452 may be disabled in your configuration. Tests with a level below
1453 7 are supposed to work with all Privoxy configurations (provided
1454 you didn't build with FEATURE_GRACEFUL_TERMINATION).
1455
1456 Tests with level 9 require Privoxy to deliver the User Manual,
1457 tests with level 12 require the CGI editor to be enabled.
1458
1459 =head1 CAVEATS
1460
1461 Expect the configuration file syntax to change with future releases.
1462
1463 =head1 LIMITATIONS
1464
1465 As Privoxy's B<show-request> page only shows client headers,
1466 Privoxy-Regression-Test can't use it to test Privoxy actions
1467 that modify server headers.
1468
1469 As Privoxy-Regression-Test relies on Privoxy's tag feature to
1470 control the actions to test, it currently only works with
1471 Privoxy 3.0.7 or later.
1472
1473 At the moment Privoxy-Regression-Test fetches Privoxy's
1474 configuration page through I<curl>(1), therefore you have to
1475 have I<curl> installed, otherwise you won't be able to run
1476 Privoxy-Regression-Test in a meaningful way.
1477
1478 =head1 SEE ALSO
1479
1480 privoxy(1) curl(1)
1481
1482 =head1 AUTHOR
1483
1484 Fabian Keil <fk@fabiankeil.de>
1485
1486 =cut