################################################################################
# privoxy-runtests.pm
#
# Code that has to be loaded by curl's runtests.pl with the -L option
# to deal with modifications required when using the tests with Privoxy.
#
# Copyright (c) 2014-2022 Fabian Keil <fk@fabiankeil.de>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
################################################################################

use strict;
use warnings;
no warnings "redefine";

my $verbose = 0;
my $use_external_proxy = 0;

BEGIN {
    # Keep a couple of functions from getpart.pm accessible so
    # our redefinitions don't have to reimplement them.
    our $real_showdiff = \&showdiff;
    our $real_getpart = \&getpart;
    our $real_getpartattr = \&getpartattr;
    our $real_compareparts = \&compareparts;
    our $real_startnew = \&startnew;
}

sub print_skipped_header($) {
    my $skipped_header = shift;
    $skipped_header =~ s@\r?\n$@@;
    print "Skipping '$skipped_header'\n";
}

# Process headers to ignore differences that are to be expected
# when Privoxy is being used.
#
# - Filter out "Proxy-Connection:" headers when checking for
#   test success.
# - Filter out a header that is specified with a "X-Ignore-Header" header.
# - Deal with tests that don't expect CRLF header endings as
#   long as the test uses it consistently.
# - Reduce spaces in server headers with a too-simplistic heuristic
#   that happens to work for the existing tests.
sub process_headers($$) {
    my ($head1_ref, $head2_ref) = @_;
    my @head1;
    my @head2;
    my $crlf_expected = 0;
    my $connection_header_expected = 0;
    my $proxy_connection_header_expected = 0;
    my $parsing_server_headers = 0;
    my $ignore_header;
    my $ignored_header;

    foreach (@$head2_ref) {
        if (/^HTTP/) {
            # If it starts like a response line, assume we are
            # looking at server headers.
            $parsing_server_headers = 1;
        }
        if (/^\r?\n$/) {
            $parsing_server_headers = 0;
        }
        if (/\r\n$/) {
            $crlf_expected = 1; # XXX: assume the expectancy is consistent.
        }

        if (/^Connection:/) {
            $connection_header_expected = 1;
        }
        if (/^Proxy-Connection:/) {
            $proxy_connection_header_expected = 1;
        }
        if (/^X-Ignore-Header: (.*)/) {
            $ignore_header = $1;
            print "Ignoring header '$ignore_header'\n" if $verbose;
        }
        if (defined $ignore_header and /^$ignore_header: .*/) {
            $ignored_header = $_;
        }

        if ($parsing_server_headers and not /"/) {
            # Normalize spaces in server headers similar to the way Privoxy
            # does. This is required for curl tests 29, 40, 42 and 54.
            s@  +@ @g;
        }
    }

    if ($verbose) {
        print "Expecting " . ($crlf_expected ? "" : "no ") . "crlf\n";
        print "Expecting " . ($connection_header_expected ? "a" : "no") . " Connection: header\n";
        print "Expecting " . ($proxy_connection_header_expected ? "a" : "no") . " Proxy-Connection: header\n";
    }

    foreach (@$head1_ref) {

        s@\r\n$@\n@ unless ($crlf_expected);

        if ((m/^Connection:/ and not $connection_header_expected) or
            (m/^Proxy-Connection:/ and not $proxy_connection_header_expected)) {
            print_skipped_header($_) if ($verbose);
            next;
        }
        if (defined $ignore_header) {
            if (m/^$ignore_header:/) {
                push @head1, "X-Ignore-Header: $ignore_header\n";
                $_ = $ignored_header;
            }
        }
        push @head1, $_;
    }
    $head1_ref = \@head1;

    return ($head1_ref, $head2_ref);
}

# Behaves like the real compareparts(), but if a proxy is being used,
# headers are run through process_headers() before checking them for
# differences.
sub compareparts {
    my ($head1_ref, $head2_ref) = @_;
    our $real_compareparts;

    if ($use_external_proxy) {
        ($head1_ref, $head2_ref) = process_headers($head1_ref, $head2_ref);
    }

    return &$real_compareparts($head1_ref, $head2_ref);
}

# Behaves like the real getpart() but if a proxy is being used
# and a proxy-reply section exists, it is returned instead of
# a common reply section.
sub getpart {
    my ($section, $part) = @_;
    our $real_getpart;

    if ($use_external_proxy and
        $section eq 'reply' and
        partexists("proxy-reply", $part)) {
        $section = "proxy-reply";
    }

    return &$real_getpart($section, $part);
}

# Behaves like the real getpartattr() but if a proxy is being used
# and a proxy-reply section exists, it is being used instead of
# a common reply section.
sub getpartattr {
    my ($section, $part)=@_;
    our $real_getpartattr;

    if ($use_external_proxy and
        $section eq 'reply' and
        partexists("proxy-reply", $part)) {
        $section = "proxy-reply";
    }

    return &$real_getpartattr($section, $part);
}

# Behaves like the real logmsg but suppresses warnings
# about unknown tests
sub logmsg {
    for (@_) {
        next if /^Warning: test\d+ not present in/;
        print "$_";
    }
}

# Behaves like the real showdiff() but diffs twice,
# the second time after processing the headers.
sub showdiff {
    my ($logdir, $head1_ref, $head2_ref) = @_;
    our $real_showdiff;

    print "Unprocessed headers:\n";
    print &$real_showdiff($logdir, $head1_ref, $head2_ref);

    print "Processed headers:\n";
    ($head1_ref, $head2_ref) = process_headers($head1_ref, $head2_ref);
    return &$real_showdiff($logdir, $head1_ref, $head2_ref);
}

# Behaves like the real startnew() but sets a static port if
# the started server is httpserver.pl.
sub startnew {
    my ($cmd, $pidfile, $timeout, $fake) = @_;
    our $real_startnew;

    if ($cmd =~ /httpserver\.pl/) {
        $cmd =~ s@--port 0@--port 20000@;
    } elsif ($cmd =~ m@server/socksd@) {
        $cmd =~ s@--port 0@--port 20001@;
    }

    return &$real_startnew($cmd, $pidfile, $timeout, $fake);
}

sub main() {

    # Look but don't touch, @ARGV is still needed elsewhere
    foreach my $arg (@ARGV) {
        $use_external_proxy = 1 if ($arg eq "-P");
        $verbose = 1 if ($arg eq "-v");
    }

    return 1;
}

main();