File Coverage

blib/lib/IO/Socket/CLI.pm

Criterion	Covered	Total	%
statement	101	153	66.0
branch	38	72	52.7
condition	10	23	43.4
subroutine	18	27	66.6
pod	17	17	100.0
total	184	292	63.0

package IO::Socket::CLI;

=head1 NAME

IO::Socket::CLI - CLI for IO::Socket::INET6 and IO::Socket::SSL

=head1 VERSION

Version 0.04

=head1 SYNOPSIS

  use IO::Socket::CLI;
  @ISA = ("IO::Socket::CLI");

=head1 DESCRIPTION

C provides a command-line interface to L and
L.

=for comment
=head1 EXPORT
None by default.

=cut

use 5.006;
use strict;
use warnings;
use IO::Socket::SSL;
use IO::Socket::INET6;
use Carp;

BEGIN {
    use Exporter ();
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
    $VERSION     = '0.04';
    @ISA         = qw(Exporter);
    @EXPORT      = qw();	# qw( );
    @EXPORT_OK   = qw();	# ( @{ $EXPORT_TAGS{'all'} } );
    %EXPORT_TAGS = ();	# ( 'all' => [ qw( ) ] );
}

# 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.

=head1 METHODS

=over 2

=item new(...)

Creates a new IO::Socket::CLI object, returning its reference. Has the following options:

=over 2

=item HOST

Hostname or IP address. Default is C<'127.0.0.1'>.

=item PORT

Port of the service. Default is C<'143'>.

=item SSL

Boolean value for if an SSL connection. Default is C<0>.

=item BYE

String server sends when it hangs up. Default is C.

=item TIMEOUT

Timeout in seconds for reading from the socket before returning an empty list. Default is C<5>.

=item DELAY

Delay in milliseconds between read attempts if nothing is returned. Default is C<10>.

=item PRINT_RESPONSE

Boolean value for if to automatically print the server response on L. Default is C<1>.

=item PREPEND

Boolean value for if to pretend client commands and server responses with C<"C: "> and C<"S: ">, respectively. Default is C<1>.

=item DEBUG

Boolean value for if to give verbose debugging info. Default is C<0>.

=back

=cut

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;
}

=item read()

Reads the response from the server, returning it as a list. Tries every
C milliseconds until C seconds. Optionally prints the
response to C if C.

=cut

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}};
}

=item response()

Returns the last stored response from the server as a list.

=cut

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

=item print_resp()

Prints each line of server response to C, optionally prepending with C<"S: "> if C.

=cut

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

=item is_open()

Returns if the server hung up according to the last server response.

=cut

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};
}

=item send($command)

Sends C<$command> to the server. Optionally echoes C<$command> if C.

=cut

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");
}

=item prompt()

Reads command from C and sends it to the server.

=cut

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");
}

=item command()

Returns last command sent.

=cut

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

=item print_response(), print_response($boolean)

Optionally turns C on/off. Returns value.

=cut

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};
}

=item prepend(), prepend($boolean)

Optionally turns C on/off. Returns value.

=cut

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};
}

=item timeout(), timeout($seconds)

Optionally sets C in seconds. Must be non-negative. Returns value.

=cut

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};
}

=item delay(), delay($milliseconds)

Optionally sets C in milliseconds. Must be positive. Returns value.

=cut

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};
}

=item bye(), bye($bye)

Optionally sets C. Must be a regexp-like quote: C. Returns value.

=cut

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};
}

=item debug(), debug($boolean)

Optionally turns debugging info/verbosity on/off. Returns value.

=cut

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
#    }
#}

=item socket()

Returns the underlying socket.

=cut

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

=item errstr()

Returns C from the socket. Only for SSL - returns C otherwise.

=cut

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

=item close()

Closes the socket. Returns true on success. This method needs to be overridden for SSL connections.

=cut

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";
    }
}

=back

=head1 BUGS

Does not verify SSL connections. Has not been tried with STARTTLS.

=head1 SUPPORT

=over 2

=item * CPAN Bug Tracker

L

=item * Code, Pull Requests, alternative Issues Tracker

L

=back

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2012 by Ashley Willis [e-mail]

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.12.4 or,
at your option, any later version of Perl 5 you may have available.

=head1 SEE ALSO

L, L, L, L

=cut

1;