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