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