File Coverage

inc/Test/Net/SSLeay/Socket.pm

Criterion	Covered	Total	%
statement	63	65	96.9
branch	13	34	38.2
condition	6	11	54.5
subroutine	15	15	100.0
pod	6	6	100.0
total	103	131	78.6

package Test::Net::SSLeay::Socket;

use 5.008001;
use strict;
use warnings;

use Carp qw(croak);
use English qw( $EVAL_ERROR $OS_ERROR $OUTPUT_AUTOFLUSH -no_match_vars );
use Scalar::Util qw(refaddr reftype);
use SelectSaver;
use Socket qw(
    AF_INET SOCK_DGRAM SOCK_STREAM
    inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in
);

our $VERSION = '1.94';

my %PROTOS = (
    tcp => SOCK_STREAM,
    udp => SOCK_DGRAM,
);

sub new {
    my ( $class, %args ) = @_;

    my $self  = bless {
        addr  => delete $args{addr}  || '127.0.0.1',
        port  => delete $args{port}  || 0,
        proto => delete $args{proto} || 'tcp',
        queue => delete $args{queue} || 5,
    }, $class;

    if ( !exists $PROTOS{ $self->{proto} } ) {
        croak "Unknown protocol '$self->{proto}'";
    }

    $self->_init_server();

    return $self;
}

sub _init_server {
    my ($self) = @_;

    my $addr = eval { inet_aton( $self->{addr} ) }
        or croak 'Could not pack IP address'
        . ( $EVAL_ERROR ? ": $EVAL_ERROR" : q{} );

    my $sockaddr = eval { pack_sockaddr_in( $self->{port}, $addr ) }
        or croak 'Could not create sockaddr_in structure'
        . ( $EVAL_ERROR ? ": $EVAL_ERROR" : q{} );

    socket $self->{sock}, AF_INET, $PROTOS{ $self->{proto} }, 0
        or croak "Could not open server socket: $OS_ERROR";

    if ( $self->{proto} eq 'tcp' ) {
        bind $self->{sock}, $sockaddr
            or croak "Could not bind server socket: $OS_ERROR";

        listen $self->{sock}, $self->{queue}
            or croak "Could not listen on server socket: $OS_ERROR";
    }

    my $sockname = getsockname $self->{sock};
    ( $self->{sport}, $self->{saddr} ) = unpack_sockaddr_in($sockname);
    $self->{saddr} = inet_ntoa( $self->{saddr} );

    return 1;
}

sub get_addr {
    my ($self) = @_;

    return $self->{saddr};
}

sub get_port {
    my ($self) = @_;

    return $self->{sport};
}

sub accept {
    my ( $self, $sock ) = @_;

    if ( defined $sock && reftype($sock) ne 'GLOB' ) {
        croak 'Argument #1 to accept() must be a typeglob reference';
    }

    accept $sock, $self->{sock}
        or croak "Could not accept connection: $OS_ERROR";

    my $saver = SelectSaver->new($sock);
    local $OUTPUT_AUTOFLUSH = 1;

    return $sock;
}

sub connect {
    my ($self) = @_;

    my $addr = eval { inet_aton( $self->{saddr} ) }
        or croak 'Could not pack IP address in connect'
        . ( $EVAL_ERROR ? ": $EVAL_ERROR" : q{} );

    my $sockaddr = eval { pack_sockaddr_in( $self->{sport}, $addr ) }
        or croak 'Could not create sockaddr_in structure in connect'
        . ( $EVAL_ERROR ? ": $EVAL_ERROR" : q{} );

    socket my $sock, AF_INET, $PROTOS{ $self->{proto} }, 0
        or croak "Could not open server socket in connect: $OS_ERROR";
    connect $sock, $sockaddr
        or croak "Could not connect to server socket: $OS_ERROR";

    my $saver = SelectSaver->new($sock);
    local $OUTPUT_AUTOFLUSH = 1;

    return $sock;
}

sub close {
    my ($self) = @_;

    return close $self->{sock};
}

1;

__END__