testrequest.pm

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

# Copyright 2001-2005 The Apache Software Foundation or its licensors, as
# applicable.
#
# Licensed 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;

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";
}

sub user_agent {
    my $args = {@_};

    if (delete $args->{reset}) {
        $UA = undef;
    }

    if (exists $args->{requests_redirectable}) {
        my $redir = $args->{requests_redirectable};
        if (ref $redir and (@$redir > 1 or $redir->[0] ne 'POST')) {
            # Set our internal flag if there's no LWP.
            $REDIR = $have_lwp ? undef : 1;
        } elsif ($redir) {
            if ($have_lwp) {
                $args->{requests_redirectable} = [ qw/GET HEAD POST/ ];
                $REDIR = undef;
            } else {
                # Set our internal flag.
                $REDIR = 1;
            }
        } else {
            # Make sure our internal flag is false if there's no LWP.
            $REDIR = $have_lwp ? undef : 0;
        }
    }

    $args->{keep_alive} ||= $ENV{APACHE_TEST_HTTP11};

    if ($args->{keep_alive}) {
        install_http11();
        eval {
            require LWP::Protocol::https; #https10 is the default
            LWP::Protocol::implementor('https', 'LWP::Protocol::https');
        };
    }

    eval { $UA ||= __PACKAGE__->new(%$args); };
}

sub user_agent_request_num {
    my $res = shift;
    $res->header('Client-Request-Num') ||  #lwp 5.60
        $res->header('Client-Response-Num'); #lwp 5.62+
}

sub user_agent_keepalive {
    $ENV{APACHE_TEST_HTTP11} = shift;
}

sub do_request {
    my($ua, $method, $url, $callback) = @_;
    my $r = HTTP::Request->new($method, resolve_url($url));
    my $response = $ua->request($r, $callback);
    lwp_trace($response);
}

sub hostport {
    my $config = shift || Apache::Test::config();
    my $vars = $config->{vars};
    local $vars->{scheme} =
        $Apache::TestRequest::Scheme || $vars->{scheme};
    my $hostport = $config->hostport;

    my $default_hostport = join ':', $vars->{servername}, $vars->{port};
    if (my $module = $Apache::TestRequest::Module) {
        $hostport = $module eq 'default'
            ? $default_hostport
            : $config->{vhosts}->{$module}->{hostport};
    }

    $hostport || $default_hostport;
}

sub resolve_url {
    my $url = shift;
    Carp::croak("no url passed") unless defined $url;

    return $url if $url =~ m,^(\w+):/,;
    $url = "/$url" unless $url =~ m,^/,;

    my $vars = Apache::Test::vars();

    local $vars->{scheme} =
      $Apache::TestRequest::Scheme || $vars->{scheme} || 'http';

    scheme_fixup($vars->{scheme});

    my $hostport = hostport();

    return "$vars->{scheme}://$hostport$url";
}

my %wanted_args = map {$_, 1} qw(username password realm content filename
                                 redirect_ok cert);

sub wanted_args {
    \%wanted_args;
}

sub redirect_ok {
    my $self = shift;
    if ($have_lwp) {
        # Return user setting or let LWP handle it.
        return $RedirectOK if defined $RedirectOK;
        return $self->SUPER::redirect_ok(@_);
    }

    # No LWP. We don't support redirect on POST.
    return 0 if $self->method eq 'POST';
    # Return user setting or our internal calculation.
    return $RedirectOK if defined $RedirectOK;
    return $REDIR;
}

my %credentials;

#subclass LWP::UserAgent
sub new {
    my $self = shift->SUPER::new(@_);

    lwp_debug(); #init from %ENV (set by Apache::TestRun)

    my $config = Apache::Test::config();
    if (my $proxy = $config->configure_proxy) {
        #t/TEST -proxy
        $self->proxy(http => "http://$proxy");
    }

    $self->timeout(UA_TIMEOUT);

    $self;
}

sub get_basic_credentials {
    my($self, $realm, $uri, $proxy) = @_;

    for ($realm, '__ALL__') {
        next unless $credentials{$_};
        return @{ $credentials{$_} };
    }

    return (undef,undef);
}

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

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

    my($host, $port) = split ':', $hostport;
    my(%args) = (PeerAddr => $host, PeerPort => $port);

    if ($module and $module =~ /ssl/) {
        require Net::SSL;
        local $ENV{https_proxy} ||= ""; #else uninitialized value in Net/SSL.pm
        return Net::SSL->new(%args, Timeout => UA_TIMEOUT);
    }
    else {
        require IO::Socket;
        return IO::Socket::INET->new(%args);
    }
}

#Net::SSL::getline is nothing like IO::Handle::getline
#could care less about performance here, just need a getline()
#that returns the same results with or without ssl
my %getline = (
    'Net::SSL' => sub {
        my $self = shift;
        my $buf = '';
        my $c = '';
        do {
            $self->read($c, 1);
            $buf .= $c;
        } until ($c eq "\n");
        $buf;
    },
);

sub getline {
    my $sock = shift;
    my $class = ref $sock;
    my $method = $getline{$class} || 'getline';
    $sock->$method();
}

sub socket_trace {
    my $sock = shift;
    return unless $sock->can('get_peer_certificate');

    #like having some -v info
    my $cert = $sock->get_peer_certificate;
    print "#Cipher:  ", $sock->get_cipher, "\n";
    print "#Peer DN: ", $cert->subject_name, "\n";
}

sub prepare {
    my $url = shift;

    if ($have_lwp) {
        user_agent();
        $url = resolve_url($url);
    }
    else {
        lwp_debug() if $ENV{APACHE_TEST_DEBUG_LWP};
    }

    my($pass, $keep) = Apache::TestConfig::filter_args(\@_, \%wanted_args);

    %credentials = ();
    if (defined $keep->{username}) {
        $credentials{$keep->{realm} || '__ALL__'} =
          [$keep->{username}, $keep->{password}];
    }
    if (defined(my $content = $keep->{content})) {
        if ($content eq '-') {
            $content = join '', <STDIN>;
        }
        elsif ($content =~ /^x(\d+)$/) {
            $content = 'a' x $1;
        }
        push @$pass, content => $content;
    }
    if ($keep->{cert}) {
        set_client_cert($keep->{cert});
    }

    return ($url, $pass, $keep);
}

sub UPLOAD {
    my($url, $pass, $keep) = prepare(@_);

    local $RedirectOK = exists $keep->{redirect_ok}
        ? $keep->{redirect_ok}
        : $RedirectOK;

    if ($keep->{filename}) {
        return upload_file($url, $keep->{filename}, $pass);
    }
    else {
        return upload_string($url, $keep->{content});
    }
}

sub UPLOAD_BODY {
    UPLOAD(@_)->content;
}

sub UPLOAD_BODY_ASSERT {
    content_assert(UPLOAD(@_));
}

#lwp only supports files
sub upload_string {
    my($url, $data) = @_;

    my $CRLF = "\015\012";
    my $bound = 742617000027;
    my $req = HTTP::Request->new(POST => $url);

    my $content = join $CRLF,
      "--$bound",
      "Content-Disposition: form-data; name=\"HTTPUPLOAD\"; filename=\"b\"",
      "Content-Type: text/plain", "",
      $data, "--$bound--", "";

    $req->header("Content-Length", length($content));
    $req->content_type("multipart/form-data; boundary=$bound");
    $req->content($content);

    $UA->request($req);
}