# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Socket::Client
#   Author: Jason Rhinelander
#   CVS Info : 087,071,086,086,085      
#   $Id: Client.pm,v 1.16 2005/09/19 23:06:25 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ====================================================================
#
# Description:
#   Client socket module that handles TCP client functionality, including
#   SSL capabilities (via GT::Socket::Client::SSLHandle and Net::SSLeay).
#

# Perl 5.004 doesn't like: $$$self{foo} mixed with a tied filehandle (as used
# by the SSL capabilities) - it confuses Perl into thinking we have a tied
# scalar. Unfortunately, this means the rather more ugly ${*$self}{foo} syntax
# has to be used instead.

package GT::Socket::Client;
use strict;
use vars qw/$ERROR @ISA $MAX_READALL @EXPORT_OK %EXPORT_TAGS $CR $LF $CRLF $VERSION/;
use Carp;
use Net::servent;
use Socket;
use POSIX qw/:fcntl_h EINTR EAGAIN EWOULDBLOCK BUFSIZ/;
require Exporter;
@ISA = 'Exporter';
use constants
    CR             => "\015",
    LF             => "\012",
    CRLF           => "\015\012",
    LINE_SAFETY    => 100_000,
    READALL_MAX    => 20 * 1024 * 1024; # Default 20 MB max, but you can pass something larger to readall()

$CR = CR; $LF = LF; $CRLF = CRLF;
@EXPORT_OK = qw/CR LF CRLF $CR $LF $CRLF/;
%EXPORT_TAGS = (
    crlf => [qw/CR LF CRLF $CR $LF $CRLF/]
);
$VERSION = sprintf "%d.%03d", q$Revision: 1.16 $ =~ /(\d+)\.(\d+)/;

sub open {
    my $class = ref($_[0]) || $_[0]; shift;

    my $self = \do { local *GLOB; *GLOB };

    if (!@_ or @_ % 2) {
        croak('Invalid options: Usage: ' . __PACKAGE__ . '->new(HASH)');
    }
    my %opts = @_;

    $opts{host} or croak 'No host entered';
    $opts{port} or croak 'No port entered';

    if ($opts{port} =~ /\D/) { # Port is a name such as 'ftp' - get the port number
        my $serv = getservbyname($opts{port});
        if (!$serv) {
            $ERROR = "Invalid port entered: $opts{port}";
            carp $ERROR if $opts{debug};
            return undef;
        }
        $opts{port} = $serv->port;
    }

    my $iaddr = inet_aton($opts{host});
    if (!$iaddr) {
        $ERROR = "Unresolvable host entered: $opts{host}";
        carp $ERROR if $opts{debug};
        return undef;
    }
    my $paddr = pack_sockaddr_in($opts{port}, $iaddr);

    not $opts{timeout} or $opts{timeout} > 0 or croak "Invalid timeout specified";

    my $use_alarm;
    if ($opts{timeout} and $^O ne 'MSWin32') { # Perl on Win32 doesn't support alarm
        require Config;
        $use_alarm = !!$Config::Config{d_alarm};
    }

    unless (socket($self, PF_INET, SOCK_STREAM, scalar getprotobyname('tcp'))) {
        $ERROR = "Socket error: $!";
        carp $ERROR if $opts{debug};
        return undef;
    }

    my ($connected, $timeout);
    if ($use_alarm) { # This OS supports alarm
        local $SIG{__DIE__};
        local $SIG{ALRM} = sub { $timeout = 1; die "timeout\n" };

        alarm($opts{timeout});

        eval { $connected = connect($self, $paddr) };

        alarm(0);
    }
    else {
        $connected = connect($self, $paddr);
    }
    unless ($connected) {
        if ($timeout) {
            $ERROR = "Unable to connect: Connection timed out";
        }
        else {
            $ERROR = "Unable to connect: $!";
        }
        carp $ERROR if $opts{debug};
        return undef;
    }

    ${*$self}{timeout} = $opts{timeout};

    if ($opts{ssl}) {
        require GT::Socket::Client::SSLHandle;
        my $sock = $self;
        $self = \do { local *SSL; *SSL };
        tie *$self, "GT::Socket::Client::SSLHandle", \*$sock;
        %{*$self} = %{*$sock}; # Copy the hash options
        ${*$self}{ssl} = 1; # Keep track of this being an SSL socket
        bless $self, $class;
    }
    else {
        bless $self, $class;
    }

    if (not exists $opts{autoflush} or $opts{autoflush}) {
        select((select($self), $|++)[0]);
        ${*$self}{autoflush} = 1;
    }
    if ($opts{non_blocking}) {
        ${*$self}{ssl} and croak "Unable to use non_blocking with ssl sockets";
        $self->_non_blocking;
    }

    ${*$self}{host}    = $opts{host};
    ${*$self}{iaddr}   = $iaddr;
    ${*$self}{port}    = $opts{port};
    ${*$self}{debug}   = $opts{debug};
    ${*$self}{eol}     = LF; # Set the default EOL, for ->readline()

    if (${*$self}{non_blocking}) {
        my %default = (read_wait => 5, select_time => 0.05, read_size => BUFSIZ);
        # These options do nothing on blocking GT::Socket::Client objects:
        for (qw/read_wait select_time read_size/) {
            if (exists $opts{$_}) {
                $self->$_($opts{$_});
            }
            else {
                ${*$self}{$_} = $default{$_};
            }
        }
    }

    $self;
}

sub _non_blocking {
    $ERROR = undef;
    my $self = shift;

    if ($] >= 5.006) {
        # Using IO::Handle is much easier for 5.6.x and above; previous
        # versions need the two (Windows/non-Windows) code below.
        require IO::Handle;
        $self->IO::Handle::blocking(0);
    }
    else {
        if ($^O eq 'MSWin32') {
            # 126 is FIONBIO (some docs say 0x7F << 16)
            ioctl(
                $self,
                0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
                1
            ) or die "ioctl: $^E";
        }
        else {
            my $flags = fcntl($self, F_GETFL, 0) or die "getfl: $!";
            $flags |= O_NONBLOCK;
            fcntl($self, F_SETFL, $flags) or die "setfl: $!";
        }
    }

    ${*$self}{non_blocking} = 1;

    return 1;
}

sub eol {
    $ERROR = undef;
    my $self = shift;
    if (@_) {
        ${*$self}{eol} = shift;
        defined ${*$self}{eol} and length ${*$self}{eol} or croak "No valid EOL character entered";
        return 1;
    }
    return ${*$self}{eol};
}

sub readline {
    $ERROR = undef;
    my $self = shift;
    if (not ${*$self}{non_blocking} or ${*$self}{ssl}) {
        local $/ = ${*$self}{eol};
        $_[0] = <$self>;
    }
    else {
        $_[0] = '';
        require POSIX;
        local $!;
        vec(my $rin = '', fileno($self), 1) = 1;
        local $SIG{PIPE} = 'IGNORE';
        my $safety;

        my $select_time = ${*$self}{select_time};
        while () {
            if ($safety++ >= LINE_SAFETY) {
                $ERROR = 'Line reads exceeded safety line cutoff (' . LINE_SAFETY . ')';
                carp $ERROR if ${*$self}{debug};
                return undef;
            }
            my $nfound;
            my $rout = $rin;
            do {
                $! = 0;
                $nfound = select($rout, undef, undef, $select_time);
            } while $! == EINTR;
            if ($nfound > 0) {
                my $ret = sysread($self, my $buff, 1);
                unless ($ret) {
                    next if $! == EAGAIN or $! == EWOULDBLOCK;

                    $ERROR = "Unable to read from socket: $!. Read: $_[0]";
                    carp $ERROR if ${*$self}{debug};
                    return undef;
                }
                $_[0] .= $buff;
                last if length($_[0]) >= length(${*$self}{eol}) and
                    rindex($_[0], ${*$self}{eol}) == (length($_[0]) - length(${*$self}{eol}))
            }
            elsif ($nfound < 0) {
                $ERROR = "Socket error: $!";
                carp $ERROR if ${*$self}{debug};
                last;
            }
        }
    }
    return 1;
}

sub select_time {
    $ERROR = undef;
    my $self = shift;
    if (@_) {
        my $select_time = shift;
        unless ($select_time > 0) {
            croak 'Usage: $obj->select_time(SELECT_TIME)';
        }
        ${*$self}{select_time} = $select_time;
        return 1;
    }

    return ${*$self}{select_time};
}

sub read_wait {
    $ERROR = undef;
    my $self = shift;
    if (@_) {
        my $read_wait = shift;
        unless ($read_wait eq '0' or $read_wait > 0) {
            croak 'Usage: $obj->read_wait(READ_WAIT)';
        }
        ${*$self}{read_wait} = $read_wait;
        return 1;
    }

    return ${*$self}{read_wait};
}

sub read_size {
    $ERROR = undef;
    my $self = shift;
    if (@_) {
        my $read_size = shift;
        unless ($read_size >= 1) {
            croak 'Usage: $obj->read_size(READ_SIZE)';
        }
        ${*$self}{read_size} = $read_size;
        return 1;
    }

    return ${*$self}{read_size};
}

# Reads all (allowing for a timeout of read_wait, if non-blocking) data from the socket
sub readall {
    my $self = shift;
    $self->readblock($_[0], -1);
}

sub readblock {
    $ERROR = undef;
    my $self = shift;
    $_[0] = '';
    my $read_wait   = ${*$self}{read_wait};
    my $select_time = ${*$self}{select_time};

    my $max_size = pop;
    unless (@_ == 1 and int($max_size) != 0) {
        croak 'Usage: $obj->readblock($scalar, BLOCK_SIZE)';
    }

    unless (defined fileno $self) {
        $ERROR = "Socket closed";
        carp $ERROR if ${*$self}{debug};
        # Don't return undef - there could still be something waiting on the
        # socket.
    }

    local $!;

    if (not ${*$self}{non_blocking} or ${*$self}{ssl}) {
        if ($max_size > 0) {
            read($self, $_[0], $max_size);
        }
        else {
            local $/;
            $_[0] = <$self>;
        }
        if (not defined $_[0] and $!) {
            $ERROR = "Blocking block read failed: $!";
            carp $ERROR if ${*$self}{debug};
            return undef unless length($_[0]);
        }
    }
    else {
        my $read_size = ${*$self}{read_size};

        vec(my $rin = '', fileno($self), 1) = 1;
        local $SIG{PIPE} = 'IGNORE';
        my $try = 0;

        while () {
            my $nfound;
            my $rout = $rin;
            do {
                $! = 0;
                $nfound = select($rout, undef, undef, $select_time);
            } while $! == EINTR;
            if ($nfound > 0) {
                my $read_size = $read_size;
                if ($max_size > 0 and length($_[0]) + $read_size > $max_size) {
                    $read_size = $max_size - length($_[0]);
                }
                my $ret = sysread($self, my $buff, $read_size);
                unless ($ret) {
                    if ($! == EAGAIN or $! == EWOULDBLOCK) {
                        if (++$try * $select_time > $read_wait) {
                            last;
                        }
                    }
                    elsif ($! == 0) {
                        $ERROR = "Connection closed";
                        carp $ERROR if ${*$self}{debug};
                        close $self;
                        length($_[0]) ? last : undef;
                    }
                    else {
                        $ERROR = "Socket error: $!";
                        carp $ERROR if ${*$self}{debug};
                        close $self;
                        return undef;
                    }
                }
                else {
                    $try = 0;
                    $_[0] .= $buff;
                    undef $buff;
                    last if $max_size > 0 and length($_[0]) >= $max_size;
                }
            }
            elsif ($nfound < 0) {
                $ERROR = "Socket error: $!";
                carp $ERROR if ${*$self}{debug};
                return undef;
            }
            elsif (++$try * $select_time > $read_wait) {
                last;
            }
        }
    }
    return length($_[0]);
}

sub readalluntil {
    $ERROR = undef;
    my $self = shift;
    my $until = shift;
    $until = [$until] unless ref $until;
    @_ or croak 'Usage: $obj->readalluntil($string-or-\@strings, $scalar[, $scalar])';

    my $initial;
    $initial = pop if @_ > 1;

    return $self->readblock($_[0], -1) if not ${*$self}{non_blocking} or ${*$self}{ssl};

    $_[0] = '';

    my $read_wait   = ${*$self}{read_wait};
    my $select_time = ${*$self}{select_time};
    my $read_size   = ${*$self}{read_size};

    unless (defined fileno $self) {
        $ERROR = "Socket closed";
        carp $ERROR if ${*$self}{debug};
        # Don't return undef - there could still be something waiting on the socket.
    }

    local $!;

    vec(my $rin = '', fileno($self), 1) = 1;
    local $SIG{PIPE} = 'IGNORE';
    my ($try, $first) = (0);

    UNTIL: while () {
        my $nfound;
        my $rout = $rin;
        do {
            $! = 0;
            $nfound = select($rout, undef, undef, $select_time);
        } while $! == EINTR;
        if ($nfound > 0) {
            my $ret = sysread($self, my $buff, $read_size);
            unless ($ret) {
                if ($! == EAGAIN or $! == EWOULDBLOCK) {
                    if (++$try * $select_time > $read_wait) {
                        last;
                    }
                }
                elsif ($! == 0) {
                    $ERROR = "Connection closed";
                    carp $ERROR if ${*$self}{debug};
                    close $self;
                    length($_[0]) ? last : undef;
                }
                else {
                    $ERROR = "Socket error: $!";
                    carp $ERROR if ${*$self}{debug};
                    close $self;
                    return undef;
                }
            }
            else {
                $try = 0;
                $_[0] .= $buff;
                undef $buff;

                if (defined $initial and length($_[0]) >= length($initial) and not $first++) {
                    last if $_[0] eq $initial;
                }
                for (@$until) {
                    last UNTIL if rindex($_[0], $_) == length($_[0]) - length($_);
                }
            }
        }
        elsif ($nfound < 0) {
            $ERROR = "Socket error: $!";
            carp $ERROR if ${*$self}{debug};
            return undef;
        }
        elsif (++$try * $select_time > $read_wait) {
            last;
        }
    }
    return length($_[0]);
}

sub write {
    my ($self, $msg) = @_;

    unless (defined fileno $self) {
        $ERROR = "Socket closed";
        carp $ERROR if ${*$self}{debug};
    }

    return unless defined $msg and length $msg;
    if (not ${*$self}{non_blocking} or ${*$self}{ssl}) {
        unless (print $self $msg) {
            $ERROR = "print failed: $!";
            carp $ERROR if ${*$self}{debug};
            return undef;
        }
    }
    else {
        for (1 .. 10) { # Maximum 10 "EAGAIN" tries
            my $rv = syswrite $self, $msg, length $msg;
            if (!defined $rv and $! == EAGAIN) {
                next;
            }
            elsif (!defined $rv or $rv != length $msg) {
                $ERROR = "Could not write to socket: $!";
                carp $ERROR if ${*$self}{debug};
                return undef;
            }
            else {
                last;
            }
        }
    }

    1;
}

# Returns the IP that we ended up connecting to.
# This is the value returned from Socket.pm's inet_aton function.
sub iaddr {
    my $self = shift;
    ${*$self}{iaddr};
}

# This is the _numeric_ port that was connected to, regardless of whether or
# not you passed a number or string port.
sub port {
    my $self = shift;
    ${*$self}{port};
}

sub error { $ERROR }

1;

__END__

=head1 NAME

GT::Socket::Client - Socket module designed for TCP clients

=head1 SYNOPSIS

    use GT::Socket::Client qw/:crlf/;

    my $socket = GT::Socket::Client->open(
        host => "gossamer-threads.com",
        port => "shell", # AKA port 514
        timeout => 10
    ) or die GT::Socket::Client->error;

    # $socket is now a socket connected to the host. Use
    # it as you would use any socket.
    $sock->readline(my $line);
    print "Read this line from the socket: $line";
    print $sock "That line" . CRLF;

    $sock->readblock(my $block, 4096);
    print "Read 4KB from the socket: $block";
    print $sock "QUIT" . CRLF;

    $sock->readall(my $all);
    print "Everything else from the socket: $all";
    print $sock "Something else" . CRLF;


=head1 DESCRIPTION

This module is a basic socket module that is designed to only handle basic
socket connection and simple read capabilities. Anything else that you want to
do with the socket is entirely up to you - this doesn't try to support
superfluous options that only a few connections will ever use, or options that
should be done in the code using this module instead of the module itself. See
the GT::WWW::http and GT::WWW::https modules for a good working example.

By default, GT::Socket::Client exports nothing, however it can export the LF,
CR, CRLF, $LF, $CR, and $CRLF constants, individually, or together via the
':crlf' export tag.

=head1 METHODS

=head2 open

Takes a hash (not hash reference) of socket options, as follows:

=over 4

=item host

[REQUIRED] The name or IP of the host to connect to.

=item port

[REQUIRED] The numeric value (25) or service name ("smtp") of the port to
connect to.

=item ssl

[OPTIONAL] If this option is provided, the connection will use SSL. Note that
this requires the Net::SSLeay module.

=item timeout

[OPTIONAL] A connection timeout period, in integral seconds. Note that this is
only supported on systems that support the alarm() function; on other systems
(such as Windows), this argument has no effect.

=item non_blocking

[OPTIONAL] Before returning it to you, the connected socket will be set up as
non-blocking if this option is enabled. Note that this option B<DOES NOT WORK>
with the ssl option, due to the Net::SSLeay interface.

=item autoflush

[OPTIONAL] Before returning to you, the connected socket will be made non-
buffering.  If you want your socket to be buffered, pass in autoflush with a
false value.

=item ssl

[OPTIONAL] GT::Socket::Client has the ability to establish an SSL connection to
a server for protocols such as HTTPS, SMTPS, POP3S, IMAPS, etc. Note that it
currently has a limitation of not being able to change to or from an SSL
connection once the connection is established, for protocols like FTPS.

=item debug

[OPTIONAL] If debugging is enabled, internal warnings (such as invalid port,
unresolvable host, connection failure, etc.) will be warn()ed. This does not
affect the error() method, which will always be set to the error message when
a problem occurs. Provide a true value if you want the warn()s to appear.

=back

=head2 readline

This method reads a single line from the socket. It takes one argument, which
must be a scalar which will be set to the line read. See the eol() method,
which allows you to specify an EOL character other than "\012". Note that on a
blocking socket, this will block until it can read a full line (or the server
closes the connection). On a non-blocking socket, the amount of time it will
wait for input is dependent on the value of the read_wait() method.

1 is returned on success, undef on failure.

=head2 readblock

This method attempts to read a certain number of bytes from the server. This
takes two arguments: like readline(), the first argument is a scalar that will
be set to the data read. The second argument is the amount of data that may be
read.  Note that on a blocking socket, this will block until the required
amount of data is read, or the socket is closed. On a non-blocking socket, this
will return once the requested amount of data is read, the socket closes, or
there is no input for C<read_wait> seconds (See L</read_wait>).

Note that a block size of -1 makes the socket read until the connection is
closed, in the case of blocking sockets, or until the read_wait() is hit.

The number of bytes read is returned on success, undef on failure.

=head2 readall

A synonym for C<$obj-E<gt>readblock($_[0], -1)> - in other words, it reads all
available data (waiting for up to C<read_wait> seconds, if non-blocking).

=head2 readalluntil

A useful function for non-blocking sockets (completely useless for blocking
sockets, on which it simply becomes a readall call).  Basically, this works
like readall(), above, but it will terminate immediately if it encounters a
pattern that you provide on the end of the data read.  Note that this does NOT
work as a delimiter, but is useful for protocols such as POP3 when you want to
read as much as you can, but know what should be at the end of what you read.
The sole advantage of this is that it allows you to avoid the read_wait timeout
that would otherwise be required at the end of a data stream.

It takes two arguments - the first is a string or array reference of strings
containing the trailing string data.  The second is a scalar that will be set
to the data read.  For example, for POP3 you might use: C<"\n.\r\n">.  You can
optionally pass in a third argument, which is used during the first read - if
the result of the first read is equal to the string passed in, it's returned.
Using the POP3 example again, this might be C<".\r\n"> - to handle an empty
response.

=head2 select_time

[Non-blocking sockets only] This adjusts the number of seconds passed to
select() to poll the socket for available data.  The default value is 0.05,
which should work in most situations.

=head2 read_wait

[Non-blocking sockets only] This method is used to set the wait time for reads.
On a local or very fast connection, this can be set to a low value (i.e. 0.1
seconds), but on a typical slower internet connection, longer wait times for
reading are usually necessary.  Hence, the default is a wait time of 5 seconds.
In effect, an attempt to read all data will end after nothing has been received
for this many seconds.

=head2 write

Sends data to the server.  Takes the data to send.  This does The Right Thing
for either non-blocking or blocking sockets.

=head2 eol

This method takes one or more character, and uses it for the EOL character(s)
used by readline. If called without any argument, the EOL character for the
current object is returned.

=head2 error

If an error (such as connection, socket, etc.) occurs, you can access it via
the error() method. This can be called as either a class or instance method,
since open() return C<undef> instead of an object if the connection fails.

=head2 iaddr

Once a connection has been established, you can call this method to get the
iaddr value for the connection.  This value is as returned by
L<Socket.pm|Socket>'s inet_aton function.

=head2 port

Once a connection has been established, this method can be used to determine
the port connected to.  Note that this is not necessarily the same as the value
of the C<port> option passed to open() - the return value of this function will
always be numeric (e.g. C<25>), even if a service name (e.g. C<"smtp">) was
passed to open().

=head1 SEE ALSO

L<GT::Socket> - A socket module made for Links SQL.

=head1 MAINTAINER

Jason Rhinelander

=head1 COPYRIGHT

Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Client.pm,v 1.16 2005/09/19 23:06:25 brewt Exp $

=cut
