package TCP::Base;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;
@ISA = qw(Exporter);

@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = '0.50';

use Carp;
use FileHandle;
use Socket;
use POSIX (:errno_h);

=head1 NAME

TCP::Base - manage a TCP connection

=head1 SYNOPSIS

  package TCP::DerivedClass;
  require TCP::Base;
  use vars qw( @ISA );
  @ISA = qw( TCP::Base );

  # override the method which says TCP::Base should not be used to
  # create objects directly
  sub abstract_class { 0; }

  sub open {   # define a method for opening this type of a connection
    ...
  }

  [add other code required for this TCP subclass]

=head1 DESCRIPTION

This package provides a number of functions useful in managing a TCP
connection.  This is not meant to be a stand-alone package, but is
instead intended to provide a common source base for other packages
derived from it.

Any derived package must provide its own open() method, as well as
any other methods not provided by the B<TCP::Base> package.

=head1 METHODS

=over 4

=cut

use vars qw( %Debug );
%Debug = ();

### class stuff

=item C<TCP::>I<class>C<-E<gt>abstract_class()>

Returns true if the class is abstract, ie. should never be
instantiated in an object.  This method should be overriden by all
non-abstract descendants of TCP::Base to return false.

=cut

sub abstract_class { 1; }

=item C<new TCP::>I<class>C< OPEN_ARGS>

=item C<new TCP::>I<class>

Creates a new instance of the specified class.  (Derived classes are
encouraged to inherit the constructor.)  With arguments, also calls
C<$object-E<gt>open(OPEN_ARGS)> after the object is created.  Returns
the created object, or undef on failure.

=cut

sub new {
  my $class = shift;
  croak "Can't create an object for abstract class $class"
    if $class->abstract_class;

  print STDERR "! creating connection for $host:$port, class $class\n"
    if $class->_debug('class');

  my ($self) = bless {}, $class;
  $self->{'Debug'} = eval "\\\%${class}::Debug";

  if (@_) {
    $self->open(@_) || return undef;
  }
  $self;
}

=item C<DESTROY $self>

Destructs the specified object instance, closing the socket in the process.

=cut

sub DESTROY {
  my ($self) = @_;
  print STDERR "! destroying connection for $self->{'host'}:$self->{'port'}\n"
    if $self->_debug('class');
  $self->close;
}

### debugging

sub _debug {
    my ($self, $key, $min) = @_;
    my ($class, $Debug) = ref($self);
    if ($class) {
      $Debug = $self->{'Debug'};
    } else {
      $Debug = eval "\\\%${self}::Debug";
    }
    $min = 1 unless defined($min);
    my ($val) = (exists($Debug->{$key})) ? $Debug->{$key} : $Debug->{'all'};
    defined($val) && ($val >= $min);
}

### read functions

=item C<$object-E<gt>read(LENGTH)>

Attempts to read LENGTH bytes of data from the TCP socket specified by
$object.  If there is no data to be read, and the socket hasn't been
set to nonblocking, process waits for the data to arrive.  Returns the
data read, or undef if the socket isn't open or an error occurs.

=cut

sub read {
    my ($self, $size) = @_;
    my ($sock) = $self->{'socket'} || return undef;

    my ($buf, $ret) = '';
    if (defined( $ret = sysread $sock, $buf, $size )) {
      $ret || $self->close;
    } else {
      carp ('sysread() for ' . ref($self) . ': ' . $!) unless ($! == EAGAIN);
      undef $buf;
    }

    print STDERR "* read $ret bytes (tried $size) for fd ".
      $sock->fileno .": $ret\n" if $self->_debug('read');
    $buf;
}

=item C<$object-E<gt>read_buf(LENGTH, BUF)>

Attempts to read LENGTH bytes of data from the TCP socket specified by
$object.  If there is no data to be read, and the socket hasn't been
set to nonblocking, process waits for the data to arrive.  BUF is a
reference to a scalar value to the end of which any input data will be
appended. Returns BUF, or undef if the socket isn't open or an error
occurs.

=cut

sub read_buf {
    my ($self, $size, $bufref) = @_;
    my ($sock) = $self->{'socket'} || return undef;

    (ref($bufref) eq 'SCALAR') || croak "Invalid reference to buffer variable";

    my ($ret) = '';
    if (defined( $ret = sysread $sock, $$bufref, $size, length($$bufref))) {
      $ret || $self->close;
    } else {
      carp ('sysread() for ' . ref($self) . ': ' . $!) unless ($! == EAGAIN);
      undef $bufref;
    }

    print STDERR "* read_buf $ret bytes (tried $size) for fd ".
      $sock->fileno .": $ret\n" if $self->_debug('read');
    $bufref;
  }

### write functions

sub write {
    my ($self, $data) = @_;
    my ($sock) = $self->{'socket'};
    my ($len, $ret) = length($data);

    if ($len != ($ret = syswrite $sock, $data, $len)) {
	carp ('syswrite() for ' . ref($self) . ": $ret vs $len: $!");
	return undef;
    }

    print STDERR "* wrote $ret bytes (tried $len) for fd ".
	$sock->fileno ."\n" if $self->_debug('write');

    $ret;
}

sub print {
    my ($self, @args) = @_;
    @args = $_ unless @args;

    $self->write( join('', @args ) );
}

sub printf {
    my ($self, $fmt, @args) = @_;
    @args = $_ unless @args;

    $self->write( sprintf $fmt, @args );
}

### is the socket still open?

sub closed {
  ! ($_[0]->{'socket'});
}

### select() and friends

sub select_mask {
  my ($self) = @_;
  my ($sock) = $self->{'socket'} || return undef;

  my ($mask) = '';
  vec($rin, $sock->fileno, 1) = 1;
  $mask;
}

sub readable {
    my ($self) = shift;
    my ($timeout) = @_ ? shift : 0;
    my ($xmask) = shift || 0;

    my ($mask) = $self->select_mask || return undef;
    $mask |= $xmask;

    print STDERR "# (select'ing: ". unpack("H*", $mask) .")\n"
      if $self->_debug('select', 2);

    my ($rout);
    my ($found) = select ($rout=$mask, undef, undef, $timeout);
    
    print STDERR "# select: $found ". unpack("H*", $rout) ."\n"
      if $self->_debug('select', 2);
    ($found >= 0) || carp "select(): $!";

    return ($found, $rout) if (wantarray);  # make this a list of values
    $found;
}



sub have_data {
    my ($self, $delay) = @_;

    if ($self->{buffer}) {
	print STDERR "# (have buffered data)\n" if $self->_debug('buffering');
	return 0x10;
    }
    $self->_pending($delay);
}

1;
__END__

=back

=head1 AUTHOR

Albert Dvornik, bert@mit.edu

=head1 SEE ALSO

=cut