view release on metacpan or  search on metacpan

lib/Apache/TestRequest.pm  view on Meta::CPAN

            : $RedirectOK;
        return lwp_call($method, undef, $url, @$pass);
    };

    while (my($shortcut, $cv) = each %shortcuts) {
        my $alias = join '_', $name, $shortcut;
        *$alias = sub { lwp_call($name, $cv, @_) };
    }
}

my @export_std = @EXPORT;
for my $method (@export_std) {
    push @EXPORT, map { join '_', $method, $_ } keys %shortcuts;
}

push @EXPORT, qw(UPLOAD UPLOAD_BODY UPLOAD_BODY_ASSERT);

sub to_string {
    my $obj = shift;
    ref($obj) ? $obj->as_string : $obj;
}

# request an interpreter instance and use this interpreter id to
# select the same interpreter in requests below
sub same_interp_tie {
    my($url) = @_;

    my $res = GET($url, INTERP_KEY, 'tie');
    unless ($res->code == 200) {
        die sprintf "failed to init the same_handler data (url=%s). " .
            "Failed with code=%s, response:\n%s",
                $url, $res->code, $res->content;
    }
    my $same_interp = $res->header(INTERP_KEY);

    return $same_interp;
}

# run the request though the selected perl interpreter, by polling
# until we found it
# currently supports only GET, HEAD, PUT, POST subs
sub same_interp_do {
    my($same_interp, $sub, $url, @args) = @_;

    die "must pass an interpreter id, obtained via same_interp_tie()"
        unless defined $same_interp and $same_interp;

    push @args, (INTERP_KEY, $same_interp);

    my $res      = '';
    my $times    = 0;
    my $found_same_interp = '';
    do {
        #loop until we get a response from our interpreter instance
        $res = $sub->($url, @args);
        die "no result" unless $res;
        my $code = $res->code;
        if ($code == 200) {
            $found_same_interp = $res->header(INTERP_KEY) || '';
        }
        elsif ($code == 404) {
            # try again
        }
        else {
            die sprintf "failed to run the request (url=%s):\n" .
                "code=%s, response:\n%s", $url, $code, $res->content;
        }

        unless ($found_same_interp eq $same_interp) {
            $found_same_interp = '';
        }

        if ($times++ > TRY_TIMES) { #prevent endless loop
            die "unable to find interp $same_interp\n";
        }
    } until ($found_same_interp);

    return $found_same_interp ? $res : undef;
}


sub set_client_cert {
    my $name = shift;
    my $vars = Apache::Test::vars();
    my $dir = join '/', $vars->{sslca}, $vars->{sslcaorg};

    if ($name) {
        my ($cert, $key) = ("$dir/certs/$name.crt", "$dir/keys/$name.pem");
        # IO::Socket:SSL raw socket compatibility
        $conn_opts->{SSL_cert_file} = $cert;
        $conn_opts->{SSL_key_file} = $key;
        if ($LWP::VERSION >= 6.0) {
            # IO::Socket:SSL doesn't look at environment variables
            if ($UA) {
                $UA->ssl_opts(SSL_cert_file => $cert);
                $UA->ssl_opts(SSL_key_file  => $key);
            } else {
                user_agent(ssl_opts => { SSL_cert_file => $cert,
                                         SSL_key_file  => $key });
            }
        }
    }
    else {
        # IO::Socket:SSL raw socket compatibility
        $conn_opts->{SSL_cert_file} = undef;
        $conn_opts->{SSL_key_file} = undef;
        if ($LWP::VERSION >= 6.0 and $UA) {
            $UA->ssl_opts(SSL_cert_file => undef);
            $UA->ssl_opts(SSL_key_file  => undef);
        }
    }
}

# Only for IO::Socket:SSL raw socket compatibility,
# when using user_agent() already done in its
# constructor.
sub set_ca_cert {
    my $vars = Apache::Test::vars();
    my $cafile = "$vars->{sslca}/$vars->{sslcaorg}/certs/ca.crt";
    $conn_opts->{SSL_ca_file} = $cafile;
}