File Coverage

inc/Test/Net/SSLeay.pm

Criterion	Covered	Total	%
statement	156	207	75.3
branch	44	92	47.8
condition	2	30	6.6
subroutine	36	40	90.0
pod	16	16	100.0
total	254	385	65.9

package Test::Net::SSLeay;

use 5.008001;
use strict;
use warnings;
use base qw(Exporter);

use Carp qw(croak);
use Config;
use Cwd qw(abs_path);
use English qw( $EVAL_ERROR $OSNAME $PERL_VERSION -no_match_vars );
use File::Basename qw(dirname);
use File::Spec::Functions qw( abs2rel catfile );
use Test::Builder;
use Test::Net::SSLeay::Socket;

our $VERSION = '1.93_02';

our @EXPORT_OK = qw(
    can_fork can_really_fork can_thread
    data_file_path
    dies_like
    dies_ok
    doesnt_warn
    initialise_libssl
    is_libressl is_openssl
    is_protocol_usable
    lives_ok
    new_ctx
    protocols
    tcp_socket
    warns_like
);

my $tester = Test::Builder->new();

my $data_path = catfile( dirname(__FILE__), '..', '..', '..', 't', 'data' );

my $initialised = 0;

my %protos = (
    'TLSv1.3' => {
        constant      => \&Net::SSLeay::TLS1_3_VERSION,
        constant_type => 'version',
        priority      => 6,
    },
    'TLSv1.2' => {
        constant      => \&Net::SSLeay::TLSv1_2_method,
        constant_type => 'method',
        priority      => 5,
    },
    'TLSv1.1' => {
        constant      => \&Net::SSLeay::TLSv1_1_method,
        constant_type => 'method',
        priority      => 4,
    },
    'TLSv1' => {
        constant      => \&Net::SSLeay::TLSv1_method,
        constant_type => 'method',
        priority      => 3,
    },
    'SSLv3' => {
        constant      => \&Net::SSLeay::SSLv3_method,
        constant_type => 'method',
        priority      => 2,
    },
    'SSLv2' => {
        constant      => \&Net::SSLeay::SSLv2_method,
        constant_type => 'method',
        priority      => 1,
    },
);

my ( $test_no_warnings, $test_no_warnings_name, @warnings );

END {
    _test_no_warnings() if $test_no_warnings;
}

sub _all {
    my ( $sub, @list ) = @_;

    for (@list) {
        $sub->() or return 0;
    }

    return 1;
}

sub _diag {
    my (%args) = @_;

    $tester->diag( ' ' x 9, 'got: ', $args{got} );
    $tester->diag( ' ' x 4, 'expected: ', $args{expected} );
}

sub _libssl_fatal {
    my ($context) = @_;

    croak "$context: "
        . Net::SSLeay::ERR_error_string( Net::SSLeay::ERR_get_error() );
}

sub _load_net_ssleay {
    eval { require Net::SSLeay; 1; } or croak $EVAL_ERROR;

    return 1;
}

sub _test_no_warnings {
    my $got_str = join q{, }, map { qq{'$_'} } @warnings;
    my $got_type = @warnings == 1 ? 'warning' : 'warnings';

    $tester->ok( @warnings == 0, $test_no_warnings_name )
        or _diag(
            got      => "$got_type $got_str",
            expected => 'no warnings',
        );
}

sub import {
    my ( $class, @imports ) = @_;

    # Enable strict and warnings in the caller
    strict->import;
    warnings->import;

    # Import common modules into the caller's namespace
    my $caller = caller;
    for (qw(Test::More)) {
        eval "package $caller; use $_; 1;" or croak $EVAL_ERROR;
    }

    # Import requested Test::Net::SSLeay symbols into the caller's namespace
    __PACKAGE__->export_to_level( 1, $class, @imports );

    return 1;
}

sub can_fork {
    return 1 if can_really_fork();

    # Some platforms provide fork emulation using ithreads
    return 1 if $Config{d_pseudofork};

    # d_pseudofork was added in Perl 5.10.0 - this is an approximation for
    # older Perls
    if (    ( $OSNAME eq 'Win32' or $OSNAME eq 'NetWare' )
        and $Config{useithreads}
        and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ )
    {
        return 1;
    }

    return can_thread();
}

sub can_really_fork {
    return 1 if $Config{d_fork};

    return 0;
}

sub can_thread {
    return 0 if not $Config{useithreads};

    # Threads are broken in Perl 5.10.0 when compiled with GCC 4.8 or above
    # (see GH #175)
    if (    $PERL_VERSION == 5.010000
        and $Config{ccname} eq 'gcc'
        and defined $Config{gccversion}
        # gccversion is sometimes defined for non-GCC compilers (see GH-350);
        # compilers that are truly GCC are identified with a version number in
        # gccversion
        and $Config{gccversion} =~ /^\d+\.\d+/ )
    {
        my ( $gcc_major, $gcc_minor ) = split /[.\s]+/, $Config{gccversion};

        return 0
            if ( $gcc_major > 4 or ( $gcc_major == 4 and $gcc_minor >= 8 ) );
    }

    # Devel::Cover doesn't (currently) work with threads
    return 0 if $INC{'Devel/Cover.pm'};

    return 1;
}

sub data_file_path {
    my ($data_file) = @_;

    my $abs_path = catfile( abs_path($data_path), $data_file );
    my $rel_path = abs2rel($abs_path);

    croak "$rel_path: data file does not exist"
        if not -e $abs_path;

    return $rel_path;
}

sub dies_like {
    my ( $sub, $expected, $name ) = @_;

    my ( $got, $ok );

    if ( eval { $sub->(); 1 } ) {
        $ok = $tester->ok ( 0, $name );

        _diag(
            got      => 'subroutine lived',
            expected => "subroutine died with exception matching $expected",
        );
    }
    else {
        $got = $EVAL_ERROR;

        my $test = $got =~ $expected;

        $ok = $tester->ok( $test, $name )
            or _diag(
                got      => qq{subroutine died with exception '$got'},
                expected => "subroutine died with exception matching $expected",
            );
    }

    $EVAL_ERROR = $got;

    return $ok;
}

sub dies_ok {
    my ( $sub, $name ) = @_;

    my ( $got, $ok );

    if ( eval { $sub->(); 1 } ) {
        $got = $EVAL_ERROR;

        $ok = $tester->ok ( 0, $name );

        _diag(
            got      => 'subroutine lived',
            expected => 'subroutine died',
        );
    }
    else {
        $got = $EVAL_ERROR;

        $ok = $tester->ok( 1, $name );
    }

    $EVAL_ERROR = $got;

    return $ok;
}

sub doesnt_warn {
    $test_no_warnings      = 1;
    $test_no_warnings_name = shift;

    $SIG{__WARN__} = sub { push @warnings, shift };
}

sub initialise_libssl {
    return 1 if $initialised;

    _load_net_ssleay();

    Net::SSLeay::randomize();

    # Error strings aren't loaded by default until OpenSSL 1.1.0, but it's safe
    # to load them unconditionally because these functions are simply no-ops in
    # later OpenSSL versions
    Net::SSLeay::load_error_strings();
    Net::SSLeay::ERR_load_crypto_strings();

    Net::SSLeay::library_init();

    # The test suite makes heavy use of SHA-256, but SHA-256 isn't registered by
    # default in all OpenSSL versions - register it manually when Net::SSLeay is
    # built against the following OpenSSL versions:

    # OpenSSL 0.9.8 series < 0.9.8o
    Net::SSLeay::OpenSSL_add_all_digests()
        if Net::SSLeay::constant('OPENSSL_VERSION_NUMBER') < 0x009080ff;

    # OpenSSL 1.0.0 series < 1.0.0a
    Net::SSLeay::OpenSSL_add_all_digests()
        if    Net::SSLeay::constant('OPENSSL_VERSION_NUMBER') >= 0x10000000
           && Net::SSLeay::constant('OPENSSL_VERSION_NUMBER') < 0x1000001f;

    $initialised = 1;

    return 1;
}

sub is_libressl {
    _load_net_ssleay();

    # The most foolproof method of checking whether libssl is provided by
    # LibreSSL is by checking OPENSSL_VERSION_NUMBER: every version of
    # LibreSSL identifies itself as OpenSSL 2.0.0, which is a version number
    # that OpenSSL itself will never use (version 3.0.0 follows 1.1.1)
    return 0
        if Net::SSLeay::constant('OPENSSL_VERSION_NUMBER') != 0x20000000;

    return 1;
}

sub is_openssl {
    _load_net_ssleay();

    # "OpenSSL 2.0.0" is actually LibreSSL
    return 0
        if Net::SSLeay::constant('OPENSSL_VERSION_NUMBER') == 0x20000000;

    return 1;
}

sub is_protocol_usable {
    my ($proto) = @_;

    _load_net_ssleay();
    initialise_libssl();

    my $proto_data = $protos{$proto};

    # If libssl does not support this protocol version, or if it was disabled at
    # compile-time, the appropriate method for that version will be missing
    if (
          $proto_data->{constant_type} eq 'version'
        ? !eval { &{ $proto_data->{constant} }; 1 }
        : !defined &{ $proto_data->{constant} }
    ) {
        return 0;
    }

    # If libssl was built with support for this protocol version, the only
    # reliable way to test whether its use is permitted by the security policy
    # is to attempt to create a connection that uses it - if it is permitted,
    # the state machine enters the following states:
    #
    #   SSL_CB_HANDSHAKE_START (ret=1)
    #   SSL_CB_CONNECT_LOOP    (ret=1)
    #   SSL_CB_CONNECT_EXIT    (ret=-1)
    #
    # If it is not permitted, the state machine instead enters the following
    # states:
    #
    #   SSL_CB_HANDSHAKE_START (ret=1)
    #   SSL_CB_CONNECT_EXIT    (ret=-1)
    #
    # Additionally, ERR_get_error() returns the error code 0x14161044, although
    # this might not necessarily be guaranteed for all libssl versions, so
    # testing for it may be unreliable

    my $constant = $proto_data->{constant}->();
    my $ctx;

    if ( $proto_data->{constant_type} eq 'version' ) {
        $ctx = Net::SSLeay::CTX_new_with_method( Net::SSLeay::TLS_method() )
            or _libssl_fatal('Failed to create libssl SSL_CTX object');

        Net::SSLeay::CTX_set_min_proto_version( $ctx, $constant );
        Net::SSLeay::CTX_set_max_proto_version( $ctx, $constant );
    }
    else {
        $ctx = Net::SSLeay::CTX_new_with_method($constant)
            or _libssl_fatal('Failed to create SSL_CTX object');
    }

    my $ssl = Net::SSLeay::new($ctx)
        or _libssl_fatal('Failed to create SSL structure');

    # For the purposes of this test, it isn't necessary to link the SSL
    # structure to a file descriptor, since no data actually needs to be sent or
    # received
    Net::SSLeay::set_fd( $ssl, -1 )
        or _libssl_fatal('Failed to set file descriptor for SSL structure');

    my @states;

    Net::SSLeay::CTX_set_info_callback(
        $ctx,
        sub {
            my ( $ssl, $where, $ret, $data ) = @_;

            push @states, $where;
        }
    );

    Net::SSLeay::connect($ssl)
        or _libssl_fatal('Failed to initiate connection');

    my $disabled =   Net::SSLeay::CB_HANDSHAKE_START()
                   + Net::SSLeay::CB_CONNECT_EXIT();

    my $enabled =   Net::SSLeay::CB_HANDSHAKE_START()
                  + Net::SSLeay::CB_CONNECT_LOOP()
                  + Net::SSLeay::CB_CONNECT_EXIT();

    Net::SSLeay::free($ssl);
    Net::SSLeay::CTX_free($ctx);

    my $observed = 0;
    for my $state (@states) {
        $observed += $state;
    }

    return 0 if $observed == $disabled;
    return 1 if $observed == $enabled;

    croak 'Unexpected TLS state machine sequence: ' . join( ', ', @states );
}

sub lives_ok {
    my ( $sub, $name ) = @_;

    my ( $got, $ok );

    if ( !eval { $sub->(); 1 } ) {
        $got = $EVAL_ERROR;

        $ok = $tester->ok ( 0, $name );

        _diag(
            got      => qq{subroutine died with exception '$got'},
            expected => 'subroutine lived',
        );
    }
    else {
        $got = $EVAL_ERROR;

        $ok = $tester->ok( 1, $name );
    }

    $EVAL_ERROR = $got;

    return $ok;
}

sub new_ctx {
    my ( $min_proto, $max_proto ) = @_;

    my @usable_protos =
        # Exclude protocol versions not supported by this libssl:
        grep {
            is_protocol_usable($_)
        }
        # Exclude protocol versions outside the desired range:
        grep {
               (
                     defined $min_proto
                   ? $protos{$_}->{priority} >= $protos{$min_proto}->{priority}
                   : 1
               )
            && (
                     defined $max_proto
                   ? $protos{$_}->{priority} <= $protos{$max_proto}->{priority}
                   : 1
               )
        }
        protocols();

    croak 'Failed to create libssl SSL_CTX object: no usable protocol versions'
        if !@usable_protos;

    my $proto    = shift @usable_protos;
    my $constant = $protos{$proto}->{constant}->();
    my $ctx;

    if ( $protos{$proto}->{constant_type} eq 'version' ) {
        $ctx = Net::SSLeay::CTX_new_with_method( Net::SSLeay::TLS_method() )
            or _libssl_fatal('Failed to create libssl SSL_CTX object');

        Net::SSLeay::CTX_set_min_proto_version( $ctx, $constant );
        Net::SSLeay::CTX_set_max_proto_version( $ctx, $constant );
    }
    else {
        $ctx = Net::SSLeay::CTX_new_with_method($constant)
            or _libssl_fatal('Failed to create SSL_CTX object');
    }

    return wantarray ? ( $ctx, $proto )
                     : $ctx;
}

sub protocols {
    return
        sort {
            $protos{$b}->{priority} <=> $protos{$a}->{priority}
        }
        keys %protos;
}

sub tcp_socket {
    return Test::Net::SSLeay::Socket->new( proto => 'tcp' );
}

sub warns_like {
    my ( $sub, $expected, $name ) = @_;

    my @expected =   ref $expected eq 'ARRAY'
                   ? @$expected
                   : ($expected);

    my @got;

    local $SIG{__WARN__} = sub { push @got, shift };

    $sub->();

    $SIG{__WARN__} = 'DEFAULT';

    my $test =    scalar @got == scalar @expected
               && _all( sub { $got[$_] =~ $expected[$_] }, 0 .. $#got );

    my $ok = $tester->ok( $test, $name )
        or do {
            my $got_str      = join q{, }, map { qq{'$_'} } @got;
            my $expected_str = join q{, }, map { qq{'$_'} } @expected;

            my $got_plural      = @got == 1 ? '' : 's';
            my $expected_plural = @expected == 1 ? '' : 's';

            _diag(
                got      => "warning$got_plural $got_str",
                expected => "warning$expected_plural matching $expected_str",
            );
        };

    return $ok;
}

1;

__END__