tests/cts/privoxy-runtests.pm

   1 ################################################################################
   2 # privoxy-runtests.pm
   3 #
   4 # Code that has to be loaded by curl's runtests.pl with the -L option
   5 # to deal with modifications required when using the tests with Privoxy.
   6 #
   7 # Copyright (c) 2014-2022 Fabian Keil <fk@fabiankeil.de>
   8 #
   9 # Permission to use, copy, modify, and distribute this software for any
  10 # purpose with or without fee is hereby granted, provided that the above
  11 # copyright notice and this permission notice appear in all copies.
  12 #
  13 # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  14 # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  15 # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  16 # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  17 # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  18 # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  19 # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  20 ################################################################################
  21
  22 use strict;
  23 use warnings;
  24 no warnings "redefine";
  25
  26 my $verbose = 0;
  27 my $use_external_proxy = 0;
  28
  29 BEGIN {
  30     # Keep a couple of functions from getpart.pm accessible so
  31     # our redefinitions don't have to reimplement them.
  32     our $real_showdiff = \&showdiff;
  33     our $real_getpart = \&getpart;
  34     our $real_getpartattr = \&getpartattr;
  35     our $real_compareparts = \&compareparts;
  36     our $real_startnew = \&startnew;
  37 }
  38
  39 sub print_skipped_header($) {
  40     my $skipped_header = shift;
  41     $skipped_header =~ s@\r?\n$@@;
  42     print "Skipping '$skipped_header'\n";
  43 }
  44
  45 # Process headers to ignore differences that are to be expected
  46 # when Privoxy is being used.
  47 #
  48 # - Filter out "Proxy-Connection:" headers when checking for
  49 #   test success.
  50 # - Filter out a header that is specified with a "X-Ignore-Header" header.
  51 # - Deal with tests that don't expect CRLF header endings as
  52 #   long as the test uses it consistently.
  53 # - Reduce spaces in server headers with a too-simplistic heuristic
  54 #   that happens to work for the existing tests.
  55 sub process_headers($$) {
  56     my ($head1_ref, $head2_ref) = @_;
  57     my @head1;
  58     my @head2;
  59     my $crlf_expected = 0;
  60     my $connection_header_expected = 0;
  61     my $proxy_connection_header_expected = 0;
  62     my $parsing_server_headers = 0;
  63     my $ignore_header;
  64     my $ignored_header;
  65
  66     foreach (@$head2_ref) {
  67         if (/^HTTP/) {
  68             # If it starts like a response line, assume we are
  69             # looking at server headers.
  70             $parsing_server_headers = 1;
  71         }
  72         if (/^\r?\n$/) {
  73             $parsing_server_headers = 0;
  74         }
  75         if (/\r\n$/) {
  76             $crlf_expected = 1; # XXX: assume the expectancy is consistent.
  77         }
  78
  79         if (/^Connection:/) {
  80             $connection_header_expected = 1;
  81         }
  82         if (/^Proxy-Connection:/) {
  83             $proxy_connection_header_expected = 1;
  84         }
  85         if (/^X-Ignore-Header: (.*)/) {
  86             $ignore_header = $1;
  87             print "Ignoring header '$ignore_header'\n" if $verbose;
  88         }
  89         if (defined $ignore_header and /^$ignore_header: .*/) {
  90             $ignored_header = $_;
  91         }
  92
  93         if ($parsing_server_headers and not /"/) {
  94             # Normalize spaces in server headers similar to the way Privoxy
  95             # does. This is required for curl tests 29, 40, 42 and 54.
  96             s@  +@ @g;
  97         }
  98     }
  99
 100     if ($verbose) {
 101         print "Expecting " . ($crlf_expected ? "" : "no ") . "crlf\n";
 102         print "Expecting " . ($connection_header_expected ? "a" : "no") . " Connection: header\n";
 103         print "Expecting " . ($proxy_connection_header_expected ? "a" : "no") . " Proxy-Connection: header\n";
 104     }
 105
 106     foreach (@$head1_ref) {
 107
 108         s@\r\n$@\n@ unless ($crlf_expected);
 109
 110         if ((m/^Connection:/ and not $connection_header_expected) or
 111             (m/^Proxy-Connection:/ and not $proxy_connection_header_expected)) {
 112             print_skipped_header($_) if ($verbose);
 113             next;
 114         }
 115         if (defined $ignore_header) {
 116             if (m/^$ignore_header:/) {
 117                 push @head1, "X-Ignore-Header: $ignore_header\n";
 118                 $_ = $ignored_header;
 119             }
 120         }
 121         push @head1, $_;
 122     }
 123     $head1_ref = \@head1;
 124
 125     return ($head1_ref, $head2_ref);
 126 }
 127
 128 # Behaves like the real compareparts(), but if a proxy is being used,
 129 # headers are run through process_headers() before checking them for
 130 # differences.
 131 sub compareparts {
 132     my ($head1_ref, $head2_ref) = @_;
 133     our $real_compareparts;
 134
 135     if ($use_external_proxy) {
 136         ($head1_ref, $head2_ref) = process_headers($head1_ref, $head2_ref);
 137     }
 138
 139     return &$real_compareparts($head1_ref, $head2_ref);
 140 }
 141
 142 # Behaves like the real getpart() but if a proxy is being used
 143 # and a proxy-reply section exists, it is returned instead of
 144 # a common reply section.
 145 sub getpart {
 146     my ($section, $part) = @_;
 147     our $real_getpart;
 148
 149     if ($use_external_proxy and
 150         $section eq 'reply' and
 151         partexists("proxy-reply", $part)) {
 152         $section = "proxy-reply";
 153     }
 154
 155     return &$real_getpart($section, $part);
 156 }
 157
 158 # Behaves like the real getpartattr() but if a proxy is being used
 159 # and a proxy-reply section exists, it is being used instead of
 160 # a common reply section.
 161 sub getpartattr {
 162     my ($section, $part)=@_;
 163     our $real_getpartattr;
 164
 165     if ($use_external_proxy and
 166         $section eq 'reply' and
 167         partexists("proxy-reply", $part)) {
 168         $section = "proxy-reply";
 169     }
 170
 171     return &$real_getpartattr($section, $part);
 172 }
 173
 174 # Behaves like the real logmsg but suppresses warnings
 175 # about unknown tests
 176 sub logmsg {
 177     for (@_) {
 178         next if /^Warning: test\d+ not present in/;
 179         print "$_";
 180     }
 181 }
 182
 183 # Behaves like the real showdiff() but diffs twice,
 184 # the second time after processing the headers.
 185 sub showdiff {
 186     my ($logdir, $head1_ref, $head2_ref) = @_;
 187     our $real_showdiff;
 188
 189     print "Unprocessed headers:\n";
 190     print &$real_showdiff($logdir, $head1_ref, $head2_ref);
 191
 192     print "Processed headers:\n";
 193     ($head1_ref, $head2_ref) = process_headers($head1_ref, $head2_ref);
 194     return &$real_showdiff($logdir, $head1_ref, $head2_ref);
 195 }
 196
 197 # Behaves like the real startnew() but sets a static port if
 198 # the started server is httpserver.pl.
 199 sub startnew {
 200     my ($cmd, $pidfile, $timeout, $fake) = @_;
 201     our $real_startnew;
 202
 203     if ($cmd =~ /httpserver\.pl/) {
 204         $cmd =~ s@--port 0@--port 20000@;
 205     } elsif ($cmd =~ m@server/socksd@) {
 206         $cmd =~ s@--port 0@--port 20001@;
 207     }
 208
 209     return &$real_startnew($cmd, $pidfile, $timeout, $fake);
 210 }
 211
 212 sub main() {
 213
 214     # Look but don't touch, @ARGV is still needed elsewhere
 215     foreach my $arg (@ARGV) {
 216         $use_external_proxy = 1 if ($arg eq "-P");
 217         $verbose = 1 if ($arg eq "-v");
 218     }
 219
 220     return 1;
 221 }
 222
 223 main();