testrequest.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

sub upload_file {
    my($url, $file, $args) = @_;

    my $content = [@$args, filename => [$file]];

    $UA->request(HTTP::Request::Common::POST($url,
                 Content_Type => 'form-data',
                 Content      => $content,
    ));
}

#useful for POST_HEAD and $DebugLWP (see below)
sub lwp_as_string {
    my($r, $want_body) = @_;
    my $content = $r->content;

    unless ($r->isa('HTTP::Request') or
            $r->header('Content-Length') or
            $r->header('Transfer-Encoding'))
    {
        $r->header('Content-Length' => length $content);
        $r->header('X-Content-length-note' => 'added by Apache::TestRequest');
    }

    $r->content('') unless $want_body;

    (my $string = $r->as_string) =~ s/^/\#/mg;
    $r->content($content); #reset
    $string;
}

$DebugLWP = 0; #1 == print METHOD URL and header response for all requests
               #2 == #1 + response body
               #other == passed to LWP::Debug->import

sub lwp_debug {
    package main; #wtf: else package in perldb changes
    my $val = $_[0] || $ENV{APACHE_TEST_DEBUG_LWP};

    return unless $val;

    if ($val =~ /^\d+$/) {
        $Apache::TestRequest::DebugLWP = $val;
        return "\$Apache::TestRequest::DebugLWP = $val\n";
    }
    else {
        my(@args) = @_ ? @_ : split /\s+/, $val;
        require LWP::Debug;
        LWP::Debug->import(@args);
        return "LWP::Debug->import(@args)\n";
    }
}

sub lwp_trace {
    my $r = shift;

    unless ($r->request->protocol) {
        #lwp always sends a request, but never sets
        #$r->request->protocol, happens deeper in the
        #LWP::Protocol::http* modules
        my $proto = user_agent_request_num($r) ? "1.1" : "1.0";
        $r->request->protocol("HTTP/$proto");
    }

    my $want_body = $DebugLWP > 1;
    print "#lwp request:\n",
      lwp_as_string($r->request, $want_body);

    print "#server response:\n",
      lwp_as_string($r, $want_body);
}

sub lwp_call {
    my($name, $shortcut) = (shift, shift);

    my $r = (\&{$name})->(@_);

    Carp::croak("$name(@_) didn't return a response object") unless $r;

    my $error = "";
    unless ($shortcut) {
        #GET, HEAD, POST
        if ($r->method eq "POST" && !defined($r->header("Content-Length"))) {
            $r->header('Content-Length' => length($r->content));
        }
        $r = $UA ? $UA->request($r) : $r;
        my $proto = $r->protocol;
        if (defined($proto)) {
            if ($proto !~ /^HTTP\/(\d\.\d)$/) {
                $error = "response had no protocol (is LWP broken or something?)";
            }
            if ($1 ne "1.0" && $1 ne "1.1") {
                $error = "response had protocol HTTP/$1 (headers not sent?)"
                    unless ($1 eq "0.9" && $ENV{APACHE_TEST_HTTP_09_OK});
            }
        }
    }

    if ($DebugLWP and not $shortcut) {
        lwp_trace($r);
    }

    Carp::croak($error) if $error;

    return $shortcut ? $r->$shortcut() : $r;
}

my %shortcuts = (RC   => sub { shift->code },
                 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) {
        $ENV{HTTPS_CERT_FILE} = "$dir/certs/$name.crt";
        $ENV{HTTPS_KEY_FILE}  = "$dir/keys/$name.pem";
    }
    else {
        for (qw(CERT KEY)) {
            delete $ENV{"HTTPS_${_}_FILE"};
        }
    }
}

#want news: urls to work with the LWP shortcuts
#but cant find a clean way to override the default nntp port
#by brute force we trick Net::NTTP into calling FixupNNTP::new
#instead of IO::Socket::INET::new, we fixup the args then forward
#to IO::Socket::INET::new

#also want KeepAlive on for Net::HTTP
#XXX libwww-perl 5.53_xx has: LWP::UserAgent->new(keep_alive => 1);

sub install_net_socket_new {
    my($module, $code) = @_;

    return unless Apache::Test::have_module($module);

    no strict 'refs';

    my $new;
    my $isa = \@{"$module\::ISA"};

    for (@$isa) {
        last if $new = $_->can('new');
    }

    my $fixup_class = "Apache::TestRequest::$module";
    unshift @$isa, $fixup_class;

    *{"$fixup_class\::new"} = sub {
        my $class = shift;
        my $args = {@_};
        $code->($args);
        return $new->($class, %$args);
    };
}

my %scheme_fixups = (
    'news' => sub {
        return if $INC{'Net/NNTP.pm'};
        eval {
            install_net_socket_new('Net::NNTP' => sub {
                my $args = shift;
                my($host, $port) = split ':',
                  Apache::TestRequest::hostport();
                $args->{PeerPort} = $port;
                $args->{PeerAddr} = $host;
            });
        };
    },
);

sub scheme_fixup {
    my $scheme = shift;
    my $fixup = $scheme_fixups{$scheme};
    return unless $fixup;
    $fixup->();
}

# when the client side simply prints the response body which should
# include the test's output, we need to make sure that the request
# hasn't failed, or the test will be skipped instead of indicating the
# error.
sub content_assert {
    my $res = shift;

    return $res->content if $res->is_success;

    die join "\n", 
        "request has failed (the response code was: " . $res->code . ")",
        "see t/logs/error_log for more details\n";
}

1;

=head1 NAME

Apache::TestRequest - Send requests to your Apache test server

=head1 SYNOPSIS

  use Apache::Test qw(ok have_lwp);
  use Apache::TestRequest qw(GET POST);
  use Apache::Constants qw(HTTP_OK);

  plan tests => 1, have_lwp;

  my $res = GET '/test.html';
  ok $res->code == HTTP_OK, "Request is ok";

=head1 DESCRIPTION

B<Apache::TestRequest> provides convenience functions to allow you to
make requests to your Apache test server in your test scripts. It
subclasses C<LWP::UserAgent>, so that you have access to all if its
methods, but also exports a number of useful functions likely useful
for majority of your test requests. Users of the old C<Apache::test>
(or C<Apache::testold>) module, take note! Herein lie most of the
functions you'll need to use to replace C<Apache::test> in your test
suites.

Each of the functions exported by C<Apache::TestRequest> uses an
C<LWP::UserAgent> object to submit the request and retrieve its
results. The return value for many of these functions is an
HTTP::Response object. See L<HTTP::Response|HTTP::Response> for
documentation of its methods, which you can use in your tests. For
example, use the C<code()> and C<content()> methods to test the
response code and content of your request. Using C<GET>, you can
perform a couple of tests using these methods like this:

  use Apache::Test qw(ok have_lwp);
  use Apache::TestRequest qw(GET POST);
  use Apache::Constants qw(HTTP_OK);

  plan tests => 2, have_lwp;

  my $uri = "/test.html?foo=1&bar=2";
  my $res = GET $uri;
  ok $res->code == HTTP_OK, "Check that the request was OK";
  ok $res->content eq "foo => 1, bar => 2", "Check its content";

Note that you can also use C<Apache::TestRequest> with
C<Test::Builder> and its derivatives, including C<Test::More>:

  use Test::More;
  # ...
  is $res->code, HTTP_OK, "Check that the request was OK";
  is $res->content, "foo => 1, bar => 2", "Check its content";

=head1 CONFIGURATION FUNCTION

You can tell C<Apache::TestRequest> what kind of C<LWP::UserAgent>
object to use for its convenience functions with C<user_agent()>. This
function uses its arguments to construct an internal global
C<LWP::UserAgent> object that will be used for all subsequent requests
made by the convenience functions. The arguments it takes are the same
as for the C<LWP::UserAgent> constructor. See the
C<L<LWP::UserAgent|LWP::UserAgent>> documentation for a complete list.

The C<user_agent()> function only creates the internal
C<LWP::UserAgent> object the first time it is called. Since this
function is called internally by C<Apache::TestRequest>, you should
always use the C<reset> parameter to force it to create a new global
C<LWP::UserAgent> Object:

  Apache::TestRequest::user_agent(reset => 1, %params);

C<user_agent()> differs from C<< LWP::UserAgent->new >> in two
additional ways. First, it supports an additional parameter,
C<keep_alive>, which enables connection persistence, where the same
connection is used to process multiple requests (and, according to the
C<L<LWP::UserAgent|LWP::UserAgent>> documentation, has the effect of
loading and enabling the new experimental HTTP/1.1 protocol module).

And finally, the semantics of the C<requests_redirectable> parameter is
different than for C<LWP::UserAgent> in that you can pass it a boolean
value as well as an array for C<LWP::UserAgent>. To force
C<Apache::TestRequest> not to follow redirects in any of its convenience
functions, pass a false value to C<requests_redirectable>:

  Apache::TestRequest::user_agent(reset => 1,
                                  requests_redirectable => 0);

If LWP is not installed, then you can still pass in an array reference
as C<LWP::UserAgent> expects. C<Apache::TestRequest> will examine the
array and allow redirects if the array contains more than one value or
if there is only one value and that value is not "POST":

  # Always allow redirection.
  my $redir = have_lwp() ? [qw(GET HEAD POST)] : 1;
  Apache::TestRequest::user_agent(reset => 1,
                                  requests_redirectable => $redir);

But note that redirection will B<not> work with C<POST> unless LWP is
installed. It's best, therefore, to check C<have_lwp> before running
tests that rely on a redirection from C<POST>.

Sometimes it is desireable to have C<Apache::TestRequest> remember