File Coverage

blib/lib/IO/Socket/CLI.pm

Criterion	Covered	Total	%
statement	92	144	63.8
branch	38	72	52.7
condition	10	23	43.4
subroutine	16	25	64.0
pod	17	17	100.0
total	173	281	61.5

package IO::Socket::CLI;
$IO::Socket::CLI::VERSION = '0.041';
use 5.006;
use strict;
use warnings;
use IO::Socket::SSL;
use IO::Socket::INET6;
use Carp;

# defaults
my $DEBUG = 0;			# boolean?
my $DELAY = 10;			# number of milliseconds between each attempt at reading the response from the server.
my $TIMEOUT = 5;		# number of seconds to wait for a response from server before returning an empty list.
my $PRINT_RESPONSE = 1;		# boolean
my $PREPEND = 1;		# boolean
our $SSL = 0;			# boolean
my $HOST = '127.0.0.1';		# IP or domain
our $PORT = '143';		# port
our $BYE = qr'^\* BYE( |\r?$)';	# string server sends when it hangs up.

sub new {
    my $this = shift;
    my $class = ref($this) || $this;
    my $self = {};
    my $args = (ref($_[0]) eq 'HASH') ? $_[0] : {@_};

    $self->{_HOST} = ($args->{HOST}) ? $args->{HOST} : $HOST;
    $self->{_PORT} = ($args->{PORT}) ? $args->{PORT} : $PORT;
    $self->{_BYE} = ($args->{BYE}) ? $args->{BYE} : $BYE;
    $self->{_DELAY} = ($args->{DELAY}) ? $args->{DELAY} : $DELAY;
    $self->{_TIMEOUT} = ($args->{TIMEOUT}) ? $args->{TIMEOUT} : $TIMEOUT;
    $self->{_PRINT_RESPONSE} = (defined $args->{PRINT_RESPONSE}) ? $args->{PRINT_RESPONSE} : $PRINT_RESPONSE;
    $self->{_PREPEND} = (defined $args->{PREPEND}) ? $args->{PREPEND} : $PREPEND;
    $self->{_DEBUG} = (defined $args->{DEBUG}) ? $args->{DEBUG} : $DEBUG;
    $self->{_SSL} = (defined $args->{SSL}) ? $args->{SSL} : $SSL;
    $self->{_SOCKET} = IO::Socket::INET6->new(PeerAddr => $self->{_HOST},
                                              PeerPort => $self->{_PORT},
                                              Blocking => 0) ||
            die "Can't bind : $@\n";

    ($self->{_SSL}) and IO::Socket::SSL->start_SSL($self->{_SOCKET});
    $self->{_OPEN} = ($self->{_SOCKET}->connected()) ? 1 : 0;
    $self->{_COMMAND} = '';
    $self->{_SERVER_RESPONSE} = [];

    bless ($self, $class);
    return $self;
}

sub read {
    my $self = shift;
    my $i = 0;
    my $max_i = $self->{_TIMEOUT} / ($self->{_DELAY} / 1000);

    do {
        select(undef, undef, undef, $self->{_DELAY} / 1000);
        @{$self->{_SERVER_RESPONSE}} = $self->{_SOCKET}->getlines;
        $i++;
    } while (!@{$self->{_SERVER_RESPONSE}} && $i < $max_i);

    if ($DEBUG || $self->{_DEBUG}) {
        print STDOUT "D: response took roughly " . ($i * $self->{_DELAY}) . " milliseconds\n";
    }

    $self->print_resp() if ($self->{_PRINT_RESPONSE});

    return  @{$self->{_SERVER_RESPONSE}};
}

sub response {
    my $self = shift;
    return @{$self->{_SERVER_RESPONSE}};
}

sub print_resp {
    my $self = shift;
    foreach (@{$self->{_SERVER_RESPONSE}}) {
        print STDOUT "" . (($self->{_PREPEND}) ? "S: " : "") . "$_";
    }
}

sub is_open {
    my $self = shift;
    my $bye = $self->{_BYE};
    $self->{_OPEN} = ($self->{_SOCKET}->connected()) ? 1 : 0;
    foreach (@{$self->{_SERVER_RESPONSE}}) {
        $self->{_OPEN} = 0 if (/$bye/);
        last;
    }
    return $self->{_OPEN};
}

sub send($) {
    my $self = shift;
    chomp (my $command = shift);
    $self->{_COMMAND} = $command;
    print STDOUT "" . ($self->{_PREPEND} ? "C: " : "") . "$command\r\n" if ($self->{_PRINT_RESPONSE});
    $self->{_SOCKET}->syswrite("$command\r\n");
}

sub prompt {
    my $self = shift;
    print STDOUT "C: " if ($self->{_PREPEND}); # client prompt
    chomp(my $command = );
    $self->{_COMMAND} = $command;
    $self->{_SOCKET}->syswrite("$command\r\n");
}

sub command() {
    my $self = shift;
    return $self->{_COMMAND};
}

sub print_response {
    my $self = shift;
    if (@_) {
        my $boolean = shift;
        if ($boolean and $boolean != 1) {
            carp "warning: valid settings for print_response() are 0 or 1 -- setting to $PRINT_RESPONSE";
            $boolean = $PRINT_RESPONSE;
        }
        $self->{_PRINT_RESPONSE} = $boolean;
    }
    return $self->{_PRINT_RESPONSE};
}

sub prepend {
    my $self = shift;
    if (@_) {
        my $boolean = shift;
        if ($boolean and $boolean != 1) {
            carp "warning: valid settings for prepend() are 0 or 1 -- setting to $PREPEND";
            $boolean = $PREPEND;
        }
        $self->{_PREPEND} = $boolean;
    }
    return $self->{_PREPEND};
}

sub timeout {
    my $self = shift;
    if (@_) {
        my $seconds = shift;
        if ($seconds < 0) {
            carp "warning: timeout() must be non-negative -- setting to $TIMEOUT";
            $seconds = $TIMEOUT;
        }
        $self->{_TIMEOUT} = $seconds;
    }
    return $self->{_TIMEOUT};
}

sub delay {
    my $self = shift;
    if (@_) {
        my $milliseconds = shift;
        if ($milliseconds < 1) {
            carp "warning: delay() must be positive -- setting to $DELAY";
            $milliseconds = $DELAY;
        }
        $self->{_DELAY} = $milliseconds;
    }
    return $self->{_DELAY};
}

sub bye {
    my $self = shift;
    if (@_) {
        my $bye = shift;
        unless ($bye =~ /\(\?(?:-xism|\^):.*\)/) {
            carp "warning: bye() must be a regexp-like quote: qr/STRING/ -- setting to '$BYE' instead of '$bye'";
            $bye = $BYE;
        }
        $self->{_BYE} = $bye;
    }
    return $self->{_BYE};
}

sub debug {
    my $self = shift;
    if (@_) {
        my $boolean = shift;
        if ($boolean and $boolean != 1) {
            carp "warning: valid settings for debug() are 0 or 1 -- setting to 1";
            $boolean = 1;
        }
        $self->{_DEBUG} = $boolean;
    }
    return $self->{_DEBUG};
}

#sub debug {
#    my $self = shift;
#    confess 'error: thing->debug($level)' unless @_ == 1;
#    my $level = shift;
#    if (ref($self)) {
#        $self->{_DEBUG} = $level; # just myself
#    } else {
#        $DEBUG = $level; # whole class
#    }
#}

sub socket {
    my $self = shift;
    return $self->{_SOCKET};
}

sub errstr {
    my $self = shift;
    if ($self->{_SSL}) {
        return $self->{_SOCKET}->errstr();
    } else {
        return undef;
    }
}

sub close {
    my $self = shift;
    return $self->{_SOCKET}->close();
    if ($self->{_SSL}) {
        return $self->{_SOCKET}->stop_SSL(SSL_ctx_free => 1);
    } else {
        return $self->{_SOCKET}->close();
    }
}

# object destructor
sub DESTROY {
    my $self = shift;
    if ($DEBUG || $self->{"_DEBUG"}) {
        carp "Destroying $self " . $self->{_HOST} . ":" . $self->{_PORT};
    }
    $self->close();
}

# class destructor
sub END {
    if ($DEBUG) {
        print STDOUT "class destroyed.\n";
    }
}

1;

__END__