view release on metacpan or  search on metacpan

lib/Test/CGI/External.pm  view on Meta::CPAN

{
    my ($self, $request_method) = @_;
    my $default_request_method = 'GET';
    if ($request_method) {
        if ($request_method && ! $valid_request_method{$request_method}) {
	    if (! $self->{no_warn}) {
		carp "You have set the request method to a value '$request_method' which is not one of the ones I know about, which are ", join (', ', @request_method_list), " so I am setting it to the default, '$default_request_method'";
	    }
            $request_method = $default_request_method;
        }
    }
    else {
	if (! $self->{no_warn}) {
	    carp "You have not set the request method, so I am setting it to the default, '$default_request_method'";
	}
        $request_method = $default_request_method;
    }
    return $request_method;
}

sub do_test
{
    my ($self, $test, $message) = @_;
    $self->{tb}->ok ($test, $message);
}

# Register a successful test (deprecated legacy from pre-Test::Builder days)

sub pass_test
{
    my ($self, $test) = @_;
    $self->{tb}->ok (1, $test);
}

# Fail a test and keep going (deprecated legacy from pre-Test::Builder days)

sub fail_test
{
    my ($self, $test) = @_;
    $self->{tb}->ok (0, $test);
}

# Print the TAP plan

sub plan
{
    my ($self) = @_;
    $self->{tb}->done_testing ();
}

# Fail a test which means that we cannot keep going.

sub abort_test
{
    my ($self, $test) = @_;
    $self->{tb}->skip_all ($test);
}

# Set an environment variable, with warning about collisions.

sub setenv_private
{
    my ($self, $name, $value) = @_;
    if (! $self->{set_env}) {
        $self->{set_env} = [$name];
    }
    else {
        push @{$self->{set_env}}, $name;
    }
    if ($ENV{$name}) {
	if (! $self->{no_warn}) {
	    carp "A variable '$name' is already set in the environment.\n";
	}
    }
    $ENV{$name} = $value;
}

sub encode_utf8_safe
{
    my ($self) = @_;
    my $input = $self->{input};
    eval "use Unicode::UTF8;";
    if ($@) {
	if (! $self->{no_warn} && ! $self->{_warned_unicode_utf8}) {
	    carp "Unicode::UTF8 is not installed, using Encode";
	    $self->{_warned_unicode_utf8} = 1;
	}
	# Encode::encode_utf8 uses prototypes so we have to hassle this up.
	return Encode::encode_utf8 ($input);
    }
    return Unicode::UTF8::encode_utf8 ($input);
}

# Internal routine to run a CGI program.

sub run_private
{
    my ($self) = @_;

    # Pull everything out of the object and into normal variables.

    my $verbose = $self->{verbose};
    my $options = $self->{run_options};
    my $cgi_executable = $self->{cgi_executable};
    my $comp_test = $self->{comp_test};

    # Hassle up the CGI inputs, including environment variables, from
    # the options the user has given.

    # mwforum requires GATEWAY_INTERFACE to be set to CGI/1.1
    #    setenv_private ($o, 'GATEWAY_INTERFACE', 'CGI/1.1');

    my $query_string = $options->{QUERY_STRING};
    if (defined $query_string) {
	$self->note ("I am setting the query string to '$query_string'.");
        setenv_private ($self, 'QUERY_STRING', $query_string);
    }
    else {
	$self->note ("There is no query string.");
        setenv_private ($self, 'QUERY_STRING', "");
    }

    my $request_method;
    if ($options->{no_check_request_method}) {
	$request_method = $options->{REQUEST_METHOD};
    }
    else {
	$request_method = $self->check_request_method ($options->{REQUEST_METHOD});
    }
    $self->note ("The request method is '$request_method'.");
    setenv_private ($self, 'REQUEST_METHOD', $request_method);
    my $content_type = $options->{CONTENT_TYPE};
    if ($content_type) {
	$self->note ("The content type is '$content_type'.");
	setenv_private ($self, 'CONTENT_TYPE', $content_type);
    }
    if ($options->{HTTP_COOKIE}) {
        setenv_private ($self, 'HTTP_COOKIE', $options->{HTTP_COOKIE});
    }
    my $remote_addr = $self->{run_options}->{REMOTE_ADDR};
    if ($remote_addr) {
	$self->note ("I am setting the remote address to '$remote_addr'.");
        setenv_private ($self, 'REMOTE_ADDR', $remote_addr);
    }
    if (defined $options->{input}) {
        $self->{input} = $options->{input};
	if (utf8::is_utf8 ($self->{input})) {
	    $self->{input} = $self->encode_utf8_safe ();
	}
	if ($self->{bad_content_length}) {
	    setenv_private ($self, 'CONTENT_LENGTH', '0');
	}
	else {
	    my $content_length = length ($self->{input});
	    setenv_private ($self, 'CONTENT_LENGTH', $content_length);
	    $self->note ("I am setting the CGI program's standard input to a string of length $content_length taken from the input options.");
	    $options->{content_length} = $content_length;
	}
    }

    if ($comp_test) {
        if ($verbose) {
	    $self->{tb}->note ("I am requesting gzip encoding from the CGI executable.\n");
        }
        setenv_private ($self, 'HTTP_ACCEPT_ENCODING', 'gzip, fake');
    }

    # Actually run the executable under the current circumstances.

    my @cmd = ($cgi_executable);
    if ($self->{command_line_options}) {
	push @cmd, @{$self->{command_line_options}};
    }
    $self->note ("I am running '@cmd'");
    $self->run3 (\@cmd);
    $options->{output} = $self->{output};
    $options->{error_output} = $self->{errors};
    $options->{exit_code} = $?;
    $self->note (sprintf ("The program has now finished running. There were %d bytes of output.", length ($self->{output})));
    if ($options->{expect_failure}) {
    }
    else {
	$self->do_test ($options->{exit_code} == 0,
			"The CGI executable exited with zero status");
    }
    $self->do_test ($options->{output}, "The CGI executable produced some output");
    if ($options->{expect_errors}) {
	if ($options->{error_output}) {
	    $self->pass_test ("The CGI executable produced some output on the error stream as follows:\n$self->{errors}\n");
	}
	else {
	    $self->fail_test ("Expecting errors, but the CGI executable did not produce any output on the error stream");
	}
    }
    else {
	if ($self->{errors}) {
	    $self->fail_test ("Not expecting errors, but the CGI executable produced some output on the error stream as follows:\n$self->{errors}\n");
	}
	else {
	    $self->pass_test ("The CGI executable did not produce any output on the error stream");
	}
    }

    $self->tidy_files ();

    return;
}


# my %token_valid_chars;
# @token_valid_chars{0..127} = (1) x 128;
# my @ctls = (0..31,127);
# @token_valid_chars{@ctls} = (0) x @ctls;
# my @tspecials = 
#     ('(', ')', '<', '>', '@', ',', ';', ':', '\\', '"',
#      '/', '[', ']', '?', '=', '{', '}', \x32, \x09 );
# @token_valid_chars{@tspecials} = (0) x @tspecials;

# These regexes are for testing the validity of the HTTP headers
# produced by the CGI script.

my $HTTP_CTL = qr/[\x{0}-\x{1F}\x{7f}]/;

my $HTTP_TSPECIALS = qr/[\x{09}\x{20}\x{22}\x{28}\x{29}\x{2C}\x{2F}\x{3A}-\x{3F}\x{5B}-\x{5D}\x{7B}\x{7D}]/;