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