File Coverage

blib/lib/Net/STOMP/Client/Peer.pm

Criterion	Covered	Total	%
statement	26	37	70.2
branch			n/a
condition			n/a
subroutine	8	13	61.5
pod	6	6	100.0
total	40	56	71.4

#+##############################################################################
#                                                                              #
# File: Net/STOMP/Client/Peer.pm                                               #
#                                                                              #
# Description: Peer support for Net::STOMP::Client                             #
#                                                                              #
#-##############################################################################

#
# module definition
#

package Net::STOMP::Client::Peer;
use strict;
use warnings;
our $VERSION  = "2.3";
our $REVISION = sprintf("%d.%02d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use Params::Validate qw(validate :types);

#
# constants
#

use constant I_PROTO => 0;
use constant I_HOST  => 1;
use constant I_PORT  => 2;
use constant I_ADDR  => 3;

#+++############################################################################
#                                                                              #
# constructor                                                                  #
#                                                                              #
#---############################################################################

my %new_options = (
    "proto" => {
        type     => SCALAR,
        regex    => qr/^(tcp|ssl|stomp|stomp\+ssl)$/,
    },
    "host" => {
        type     => SCALAR,
        regex    => qr/^[a-z0-9\.\-]+$/,
    },
    "port" => {
        type     => SCALAR,
        regex    => qr/^\d+$/,
    },
    "addr" => {
        optional => 1,
        type     => SCALAR,
        regex    => qr/^\d+\.\d+\.\d+\.\d+$/,
    },
);

sub new : method {
    my($class, %option, $object);

    $class = shift(@_);
    %option = validate(@_, \%new_options);
    $object = [ @option{ qw(proto host port addr) } ];
    return(bless($object, $class));
}

#+++############################################################################
#                                                                              #
# getters                                                                      #
#                                                                              #
#---############################################################################

sub proto : method {
    my($self) = @_;

    return($self->[I_PROTO]);
}

sub host : method {
    my($self) = @_;

    return($self->[I_HOST]);
}

sub port : method {
    my($self) = @_;

    return($self->[I_PORT]);
}

sub addr : method {
    my($self) = @_;

    return($self->[I_ADDR]);
}

sub uri : method {
    my($self) = @_;

    return(sprintf("%s://%s:%s", @{ $self }[I_PROTO, I_HOST, I_PORT]));
}

1;

__END__