# Netstream.pm --- create tcp network streams and perform i/o

# Copyright (C) 1995, 1996, 1999 Noah S. Friedman

# Author: Noah Friedman <friedman@splode.com>
# Created: 1995-04-15

# $Id: Netstream.pm,v 1.5 2000/02/11 11:34:36 friedman Exp $

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, you can either send email to this
# program's maintainer or write to: The Free Software Foundation,
# Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.

# Commentary:
# Code:

package NF::Netstream;

use Socket;
use Symbol;

use strict;

use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
$VERSION     = 1.00;
@ISA         = qw(Exporter);
@EXPORT_OK   = qw(netstream_gethostbyname ipaddr_aton ipaddr_ntoa flush);
@EXPORT      = qw(open_network_stream copy_io_until_close);

# Constants for shutdown(2)
use vars qw($SHUTDOWN_RECEIVE $SHUTDOWN_SEND $SHUTDOWN_BOTH);
$SHUTDOWN_RECEIVE = 0;
$SHUTDOWN_SEND    = 1;
$SHUTDOWN_BOTH    = 2;


# Private routines

# Convert integers from host byte order to network byte order.
# Network byte order is big-endian.
sub htonl ($)
{
  return $_[0] unless (unpack ("c2", pack ("i", 1)));
  return pack ('C4', reverse unpack ('C4', $_[0]));
}

sub ipaddr_aton ($)
{
  my $addr = shift;

  return $addr unless ($addr =~ /^\d+$/o);

  # String is in 255.255.255.255 format
  return pack ('C4', split (/\./, $addr))
    if (index ($addr, ".") >= 0);

  # If string is not in octet form but instead is a flat ascii IP,
  # then just convert it to network byte order.
  # Convert addr to the dotted decimal representation for it.
  #
  # source IP addresses are specified in this flat format in the
  # IRC DCC protocol; I don't know if it's common anywhere else.
  htonl (pack ("I", $addr));
}

sub ipaddr_ntoa ($)
{
  join (".", unpack ("C4", $_[0]));
}

sub netstream_gethostbyaddr ($$)
{
  my ($addrstring, $type) = @_;
  my $addr = ipaddr_aton ($addrstring);
  my $name = gethostbyaddr ($addr, $type);
  return ($name eq "") ? $name : ipaddr_ntoa ($addr);
}

sub err
{
  print STDERR join (": ", $0, @_), "\n";
  return undef;
}

# Pseudo-public.  Not exported by default, but may be useful to callers
# using stdio to force a buffer to be sent to the server.
sub flush
{
  my $handle;
  foreach $handle (@_)
    {
      my $orig_handle = select ($handle);
      my $orig_buffered_state = $|;
      $| = 1;
      $| = $orig_buffered_state;
      select ($orig_handle);
    }
}


# Public routines

sub open_network_stream ($$)
{
  my ($rhostname, $port) = @_;

  my $proto = getprotobyname ("tcp");
  (undef, undef, $port) = getservbyname ($port, "tcp") if ($port !~ /^\d+$/o);

  my @rhostaddr;
  if ($rhostname =~ /^[0-9.]+$/o)
    {
      push @rhostaddr, ipaddr_aton ($rhostname);
    }
  else
    {
      @rhostaddr = gethostbyname ($rhostname);
      return err ($rhostname, "cannot resolve host name.")
        unless (defined $rhostaddr[0] && $rhostaddr[0] ne "");
      splice (@rhostaddr, 0, 4);
    }

  my $sock = gensym;
  socket ($sock, AF_INET, SOCK_STREAM, $proto) || return err ("socket", $!);
  while ($#rhostaddr >= 0)
    {
      connect ($sock, sockaddr_in ($port, shift @rhostaddr)) && return $sock;
    }
  return err ("socket", $!);
}

sub copy_io_until_close ($$$)
{
  my ($inh, $outh, $remh) = @_;
  my $inbits = '';
  my $outbits = '';
  my $bufsize = 4096;

  vec ($inbits, fileno ($inh),  1) = 1;
  vec ($inbits, fileno ($remh), 1) = 1;

  while (1)
    {
      select ($outbits = $inbits, undef, undef, undef);

      if (vec ($outbits, fileno ($inh), 1) == 1)
        {
          if (my $len = sysread ($inh, $_, $bufsize))
            {
              syswrite ($remh, $_, $len);
            }
          else
            {
              # Shut down sending, but don't return; allow remaining output
              # to drain.
              vec ($inbits, fileno ($inh), 1) = 0;
              shutdown ($remh, $SHUTDOWN_SEND);
            }
        }

      if (vec ($outbits, fileno ($remh), 1) == 1)
        {
          if (my $len = sysread ($remh, $_, $bufsize))
            {
              syswrite ($outh, $_, $len);
            }
          else
            {
              shutdown ($remh, $SHUTDOWN_BOTH);
              return;
            }
        }
   }
}

1;