view release on metacpan or  search on metacpan

t/04-cli-cert.t  view on Meta::CPAN

#!/usr/bin/perl
#
#  t/04-cli-cert.t - Test client certificates - based on an example
#                    program from Net::SSLeay
#
# Copyright (C) 2009  NZ Registry Services
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the Artistic License 2.0 or later.  You should
# have received a copy of the Artistic License the file COPYING.txt.
# If not, see <http://www.perlfoundation.org/artistic_license_2_0>

use strict;
use warnings;
use FindBin qw($Bin);

our $TC;
our $DEBUG = $ENV{DEBUG_SSL};

sub ok($$) {
	if ( !$_[0] ) {
		print "not ";
	}
	print "ok " . ( ++$TC ) . ( $_[1] ? " - $_[1]" : "" ) . "\n";
	return !!$_[0];
}

sub diag {
	if ($DEBUG) {
		print map {"# $_\n"} map { split "\n", $_ } @_;
	}
}

$ENV{RND_SEED} = '1234567890123456789012345678901234567890';

use Net::SSLeay::OO;
use Net::SSLeay::OO::Constants qw(VERIFY_PEER FILETYPE_PEM);
use Net::SSLeay::OO::X509;
use Net::SSLeay::OO::X509::Context;

my $cert_dir = "$Bin/certs";

my $ctx = Net::SSLeay::OO::Context->new;
$ctx->set_default_passwd_cb( sub {"secr1t"} );
$ctx->load_verify_locations( '', $cert_dir );

pipe RS, WC or die "pipe 1 ($!)";
pipe RC, WS or die "pipe 2 ($!)";
select WC;
$| = 1;
select WS;
$| = 1;
select STDOUT;
$| = 1;
pipe R2, W2 or die "pipe 3 ($!)";

ok( $ctx, "Set up Context OK" );

my $child_pid = fork;
defined($child_pid) or die $!;
unless ($child_pid) {
	diag("child - using server cert");
	$ctx->use_certificate_chain_file("$cert_dir/server-cert.pem");
	$ctx->use_PrivateKey_file( "$cert_dir/server-key.pem", FILETYPE_PEM,);

	# we get one event for each certificate check
	my @check_certs;
	my @found_altnames;
	my $cb = (
		sub {
			my ( $ok, $x509 ) = @_;
			diag("$$ - ok = $ok");

			#my $x509 = $x509_store_ctx->get_current_cert;
			if ($x509) {
				my $name = $x509->get_subject_name;
				diag "  Verifying cert: "
					. $name->oneline . "\n";
				push @check_certs, $name->cn;
				if ($DEBUG) {