ssl results from the CPAN

Apache-Test

    # 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');
        };
    }

    # in LWP 6, verify_hostname defaults to on, so SSL_ca_file
    # needs to be set accordingly
    if ($have_lwp and $LWP::VERSION >= 6.0 and not exists $args->{ssl_opts}->{SSL_ca_file}) {
        my $vars = Apache::Test::vars();
        my $cafile = "$vars->{sslca}/$vars->{sslcaorg}/certs/ca.crt";
        $args->{ssl_opts}->{SSL_ca_file} = $cafile;
        # IO::Socket:SSL raw socket compatibility
        $conn_opts->{SSL_ca_file} = $cafile;
    }

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

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}];
    }
    if (defined(my $content = $keep->{content})) {
        if ($content eq '-') {
            $content = join '', <STDIN>;
        }
        elsif ($content =~ /^x(\d+)$/) {
            $content = 'a' x $1;
        }
        push @$pass, content => $content;
    }

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

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

#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

( run in 0.944 second using v1.01-cache-2.11-cpan-acf6aa7dc9e )