view release on metacpan or  search on metacpan

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

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 credentials {
    my $self = shift;
    return $self->get_basic_credentials(@_);
}

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/ || $module eq 'h2')) {
        require IO::Socket::SSL;
        # Add all conn_opts to args
        map {$args{$_} = $conn_opts->{$_}} keys %{$conn_opts};
        return IO::Socket::SSL->new(%args, Timeout => UA_TIMEOUT);
    }
    else {
        require IO::Socket;
        return IO::Socket::INET->new(%args);
    }
}

#IO::Socket::SSL::getline does not correctly handle OpenSSL *_WANT_*.
#Could care less about performance here, just need a getline()
#that returns the same results with or without ssl.
#Inspired from Net::SSLeay::ssl_read_all().
my %getline = (
    'IO::Socket::SSL' => sub {
        my $self = shift;
        # _get_ssl_object in IO::Socket::SSL only meant for internal use!
        # But we need to compensate for unsufficient getline impl there.
        my $ssl = $self->_get_ssl_object;
        my ($got, $rv, $errs);
        my $reply = '';
    
        while (1) {
            ($got, $rv) = Net::SSLeay::read($ssl, 1);
            if (! defined $got) {
                my $err = Net::SSLeay::get_error($ssl, $rv);
                if ($err != Net::SSLeay::ERROR_WANT_READ() and
                    $err != Net::SSLeay::ERROR_WANT_WRITE()) {
                    $errs = Net::SSLeay::print_errs('SSL_read');
                    last;
                }
                next;
            }
            last if $got eq '';  # EOF
            $reply .= $got;
            last if $got eq "\n";
        }

        wantarray ? ($reply, $errs) : $reply;
    },
);

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