PUT results from the CPAN

Apache-Test

# The ASF licenses this file to You under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
package Apache::TestRequest;

use strict;
use warnings FATAL => 'all';

BEGIN {
    $ENV{PERL_LWP_USE_HTTP_10}   = 1;    # default to http/1.0
    $ENV{APACHE_TEST_HTTP_09_OK} ||= 0;  # 0.9 responses are ok
}

use Apache::Test ();
use Apache::TestConfig ();

use Carp;

use constant TRY_TIMES => 200;
use constant INTERP_KEY => 'X-PerlInterpreter';
use constant UA_TIMEOUT => 60 * 10; #longer timeout for debugging

my $have_lwp = 0;

# APACHE_TEST_PRETEND_NO_LWP=1 pretends that LWP is not available so
# one can test whether the test suite survives if the user doesn't
# have lwp installed
unless ($ENV{APACHE_TEST_PRETEND_NO_LWP}) {
    $have_lwp = eval {
        require LWP::UserAgent;
        require HTTP::Request::Common;

        unless (defined &HTTP::Request::Common::OPTIONS) {
            package HTTP::Request::Common;
            no strict 'vars';
            *OPTIONS = sub { _simple_req(OPTIONS => @_) };
            push @EXPORT, 'OPTIONS';
        }
        1;
    };
}

unless ($have_lwp) {
    require Apache::TestClient;
}

sub has_lwp { $have_lwp }

unless ($have_lwp) {
    #need to define the shortcuts even though the wont be used
    #so Perl can parse test scripts
    @HTTP::Request::Common::EXPORT = qw(GET HEAD POST PUT OPTIONS);
}

sub install_http11 {
    eval {
        die "no LWP" unless $have_lwp;
        LWP->VERSION(5.60); #minimal version
        require LWP::Protocol::http;
        #LWP::Protocol::http10 is used by default
        LWP::Protocol::implementor('http', 'LWP::Protocol::http');
    };
}

use vars qw(@EXPORT @ISA $RedirectOK $DebugLWP);

require Exporter;
*import = \&Exporter::import;
@EXPORT = @HTTP::Request::Common::EXPORT;

@ISA = qw(LWP::UserAgent);

my $UA;
my $REDIR = $have_lwp ? undef : 1;
my $conn_opts = {};

sub module {
    my $module = shift;
    $Apache::TestRequest::Module = $module if $module;
    $Apache::TestRequest::Module;
}

sub scheme {
    my $scheme = shift;
    $Apache::TestRequest::Scheme = $scheme if $scheme;
    $Apache::TestRequest::Scheme;
}

sub module2path {
    my $package = shift;

    # httpd (1.3 && 2) / winFU have problems when the first path's
    # segment includes ':' (security precaution which breaks the rfc)
    # so we can't use /TestFoo::bar as path_info
    (my $path = $package) =~ s/::/__/g;

    return $path;
}

sub module2url {
    my $module   = shift;
    my $opt      = shift || {};
    my $scheme   = $opt->{scheme} || 'http';
    my $path     = exists $opt->{path} ? $opt->{path} : module2path($module);

    module($module);

    my $config   = Apache::Test::config();
    my $hostport = hostport($config);

    $path =~ s|^/||;
    return "$scheme://$hostport/$path";

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

                 OK   => sub { shift->is_success },
                 STR  => sub { shift->as_string },
                 HEAD => sub { lwp_as_string(shift, 0) },
                 BODY => sub { shift->content },
                 BODY_ASSERT => sub { content_assert(shift) },
);

for my $name (@EXPORT) {
    my $package = $have_lwp ?
      'HTTP::Request::Common': 'Apache::TestClient';

    my $method = join '::', $package, $name;
    no strict 'refs';

    next unless defined &$method;

    *$name = sub {
        my($url, $pass, $keep) = prepare(@_);
        local $RedirectOK = exists $keep->{redirect_ok}
            ? $keep->{redirect_ok}
            : $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 });
            }
        }

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


A shortcut function for C<GET($uri)-E<gt>is_success>.

=head3 GET_RC

A shortcut function for C<GET($uri)-E<gt>code>.

=head3 GET_HEAD

Throws out the content of the request, and returns the string
representation of the request. Since the body has been thrown out, the
representation will consist solely of the headers. Furthermore,
C<GET_HEAD> inserts a "#" at the beginning of each line of the return
string, so that the contents are suitable for printing to STDERR
during your tests without interfering with the workings of
C<Test::Harness>.

=head3 HEAD

  my $res = HEAD $uri;

Sends a HEAD request to the Apache test server. Returns an
C<HTTP::Response> object.

=head3 HEAD_STR

A shortcut function for C<HEAD($uri)-E<gt>as_string>.

=head3 HEAD_BODY

A shortcut function for C<HEAD($uri)-E<gt>content>. Of course, this
means that it will likely return nothing.

=head3 HEAD_BODY_ASSERT

Use this function when your test is outputting content that you need
to check, and you want to make sure that the request was successful
before comparing the contents of the request. If the request was
unsuccessful, C<HEAD_BODY_ASSERT> will return an error
message. Otherwise it will simply return the content of the request
just as C<HEAD_BODY> would.

=head3 HEAD_OK

A shortcut function for C<GET($uri)-E<gt>is_success>.

=head3 HEAD_RC

A shortcut function for C<GET($uri)-E<gt>code>.

=head3 HEAD_HEAD

Throws out the content of the request, and returns the string
representation of the request. Since the body has been thrown out, the
representation will consist solely of the headers. Furthermore,
C<GET_HEAD> inserts a "#" at the beginning of each line of the return
string, so that the contents are suitable for printing to STDERR
during your tests without interfering with the workings of
C<Test::Harness>.

=head3 PUT

  my $res = PUT $uri;

Sends a simple PUT request to the Apache test server. Returns an
C<HTTP::Response> object.

=head3 PUT_STR

A shortcut function for C<PUT($uri)-E<gt>as_string>.

=head3 PUT_BODY

A shortcut function for C<PUT($uri)-E<gt>content>.

=head3 PUT_BODY_ASSERT

Use this function when your test is outputting content that you need
to check, and you want to make sure that the request was successful
before comparing the contents of the request. If the request was
unsuccessful, C<PUT_BODY_ASSERT> will return an error
message. Otherwise it will simply return the content of the request
just as C<PUT_BODY> would.

=head3 PUT_OK

A shortcut function for C<PUT($uri)-E<gt>is_success>.

=head3 PUT_RC

A shortcut function for C<PUT($uri)-E<gt>code>.

=head3 PUT_HEAD

Throws out the content of the request, and returns the string
representation of the request. Since the body has been thrown out, the
representation will consist solely of the headers. Furthermore,
C<PUT_HEAD> inserts a "#" at the beginning of each line of the return
string, so that the contents are suitable for printing to STDERR
during your tests without interfering with the workings of
C<Test::Harness>.

=head3 POST

  my $res = POST $uri, [ arg => $val, arg2 => $val ];

Sends a POST request to the Apache test server and returns an
C<HTTP::Response> object. An array reference of parameters passed as
the second argument will be submitted to the Apache test server as the
POST content. Parameters corresponding to those documented in
L<Optional Parameters|/Optional
Parameters> can follow the optional array reference of parameters, or after
C<$uri>.

To upload a chunk of data, simply use:

  my $res = POST $uri, content => $data;

=head3 POST_STR

A shortcut function for C<POST($uri, @args)-E<gt>content>.

=head3 POST_BODY

A shortcut function for C<POST($uri, @args)-E<gt>content>.

=head3 POST_BODY_ASSERT

Use this function when your test is outputting content that you need
to check, and you want to make sure that the request was successful
before comparing the contents of the request. If the request was
unsuccessful, C<POST_BODY_ASSERT> will return an error
message. Otherwise it will simply return the content of the request
just as C<POST_BODY> would.

=head3 POST_OK

A shortcut function for C<POST($uri, @args)-E<gt>is_success>.

=head3 POST_RC

A shortcut function for C<POST($uri, @args)-E<gt>code>.

=head3 POST_HEAD

Throws out the content of the request, and returns the string
representation of the request. Since the body has been thrown out, the
representation will consist solely of the headers. Furthermore,
C<POST_HEAD> inserts a "#" at the beginning of each line of the return
string, so that the contents are suitable for printing to STDERR
during your tests without interfering with the workings of
C<Test::Harness>.

=head3 UPLOAD

  my $res = UPLOAD $uri, \@args, filename => $filename;

Sends a request to the Apache test server that includes an uploaded

( run in 0.866 second using v1.01-cache-2.11-cpan-39bf76dae61 )