#=====================================================================
#   TCP.pm : Simple TCP Client and Socket I/O module
#
#   Copyright(c) N.Oishi (BSC CONSULTING CGI-Laboratory).
#
#   e-mail : bigstone@my.email.ne.jp
#   support: http://www.din.or.jp/~bigstone/cgilab/index.html
#
#   THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND
#   ANY EXPRESS OR IMPLIED WARRANTIES ARE DISCLAIMED.
#
#   ver 1.1.5 : updated last on 2001/12/20
#
#=====================================================================
package TCP;

use Socket;
use Symbol;
use strict;
use integer;
use vars qw($VERSION $TIMEOUT $MAXREAD $CRLF $CRLF_ANY);

$VERSION = '1.1.5';

$MAXREAD = 16384;   # set number of less than 32766 (bytes)
$TIMEOUT = 30;

$CRLF_ANY = "\015?\012";
$CRLF     = "\015\012";

sub new {
    my $class = shift;
    my $time  = shift || 0;
    my $sock  = Symbol::gensym();
    ${*$sock}{timeout} = $time > 0 && $time <= 300 ? $time : $TIMEOUT;
    return bless $sock, ref $class || $class;
}

sub connect {
    my $sock = shift;
    my($host, $port, $time, $sockopt) = @_;
    return undef unless($host && $port);
    if(!ref($sock)){
        $sock = $sock->new($time);
    }
    if($port =~ /\D/o){
        $port = getservebyname($port, 'tcp');
    }
    my($success, $addr);
    $port = _get_port($port) || return undef;
    $addr = _get_addr($host) || return undef;
    socket($sock, PF_INET, SOCK_STREAM, getprotobyname('tcp')) || return undef;
   USESOCK: {
        if($sockopt){
            setsockopt($sock, SOL_SOCKET, $sockopt, 1) or last;
        }
        connect($sock, sockaddr_in($port, $addr)) or last;
        $success = 1;
    }
    unless($success){
        $sock->close();
        return undef;
    }
    select((select($sock), $| = 1)[0]); binmode($sock);
    my $fileno = fileno($sock);
    my $bitset = "";
    vec($bitset, $fileno, 1) = 1;
    ${*$sock}{bitset} = $bitset;
    ${*$sock}{fileno} = $fileno;
    return $sock;
}

sub timeout {
    my $sock = shift;
    my $time = shift ;
    ${*$sock}{timeout} = $time if $time > 0 && $time <= 300;
}

sub _get_port {
    my($port) = @_;
    if($port =~ /\D/o){
        $port = getservebyname($port, 'tcp');
    }
    $port;
}

sub _get_addr {
    my $host = shift;
    if($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/o){
        return pack('C4', $1, $2, $3, $4);
    } else {
        return inet_aton($host);
    }
    return undef;
}

sub close {
    my $sock = shift;
    close($sock) if defined fileno($sock);
}

sub shutdown {
    my $sock = shift;
    my $how  = shift || 2;
    shutdown($sock, $how) if defined fileno($sock);
}

sub read {
    my($sock, $size) = @_;
    if($size > 0){
        my($buff, $len);
        while ($size){
            $len = $size >= $MAXREAD ? $MAXREAD : $size;
            $buff .= $sock->_read_buffer($len) || last;
            $size -= $len;
        }
        return $buff;
    } else {
        $sock->_read_buffer(0, $CRLF_ANY);
    }
}

sub read_until {
    shift->_read_buffer(0, @_);
}

sub read_until_dot {
    my $sock = shift;
    my $line = "";
    my $buff = "";
    while ($line = $sock->_read_buffer(0, $CRLF_ANY)){
        last if($line =~ /^\.$CRLF_ANY$/so);
        $line =~ s/^\.\././o;
        $buff .= $line;
    }
    $buff;
}

sub _read_buffer {
    my($sock, $len, $cond) = @_;
    while (1){
        return $1 if($cond ne "" && ${*$sock}{buffer} =~ s/^(.*?$cond)//s);
        return $1 if($len > 0    && ${*$sock}{buffer} =~ s/^(.{$len})//s);
        ${*$sock}{buffer} .= $sock->_read_stream($len) || last;
    }
    (defined ${*$sock}{buffer}) ? delete ${*$sock}{buffer} : undef;
}

sub _read_stream {
    my($sock, $len) = @_;
    return undef if $sock->status();
    $len ||= 4096;
    my $buff  = "";
    if($sock->can_read()){
        my $bytes_read = sysread($sock, $buff, $len, 0);
        if(!defined $bytes_read){
            $sock->status(2);
            return undef;
        } elsif($bytes_read == 0){
            return undef;
        }
    } else {
        $sock->status(8);
        return undef;
    }
    $buff;
}

sub print {
    my $fld_sep = (defined $,) ? $, : '';
    my $rec_sep = (defined $\) ? $\ : '';
    my $sock = shift;
    my $str  = join($fld_sep, @_, $rec_sep);
    $sock->write($str, 1);
}

sub printf {
    my $sock = shift;
    my $form = shift;
    my $str  = sprintf($form, @_);
    $sock->write($str, 1);
}

sub write {
    my $sock = shift;
    my $buff = shift;
    my($crlf) = @_;
    return undef if $sock->status();
    $buff =~ s/$CRLF_ANY/$CRLF/sgo unless $crlf;
    my $offset = 0;
    my $len = length($buff);
    while ($len){
        if($sock->can_write()){
            my $bytes_write = syswrite($sock, $buff, $len, $offset);
            if(!defined $bytes_write){
                $sock->status(4);
                return undef;
            }
            $len -= $bytes_write; $offset += $bytes_write;
        } else {
            $sock->status(8);
            return undef;
        }
    }
    $sock->status(0);
    $sock;
}

sub can_write {
    my $sock = shift;
    my $timeout = ${*$sock}{timeout};
    my $bitset  = ${*$sock}{bitset};
    select(undef, $bitset, undef, $timeout);
}

sub can_read {
    my $sock = shift;
    my $timeout = ${*$sock}{timeout};
    my $bitset  = ${*$sock}{bitset};
    select($bitset, undef, undef, $timeout);
}

sub status {
    my $sock = shift;
    @_ ? ${*$sock}{status} = shift : ${*$sock}{status};
}

sub DESTROY {
    shift->shutdown(2);
}

1;

__END__