#!/bin/sh
exec ${PERL-perl} -Swx $0 ${1+"$@"}
#!perl

# tcpconnect --- connect via TCP to a specified host and port

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

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

# $Id: tcpconnect,v 1.14 2002/07/03 08:15:04 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:

use 5.002;
use Getopt::Long;
use Symbol;
use Socket;
use Fcntl;
use POSIX qw(:errno_h);
use strict;

my $progname         = $0;
my $opt_no_intr      = 0;
my $opt_no_proctitle = 0;
my $opt_no_revres    = 0;
my @opt_stty;
my $opt_timeout;
my $opt_verbose   = 0;

sub verbose
{
  print join (": ", $progname, @_), "\n"
    if ($opt_verbose);
}

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


my $SHUTDOWN_RECEIVE = 0;
my $SHUTDOWN_SEND    = 1;
my $SHUTDOWN_BOTH    = 2;

my $h_errno = 0;
my %herrstr = (-1 => "Resolver internal error",
                0 => "Resolver Error 0 (no error)",
                1 => "Unknown host",
                2 => "Host name lookup failure",
                3 => "Unknown server error",
                4 => "No address associated with name");

my $ons_errstr = '';

sub ipaddrp ($)
{
  $_[0] =~ /^[\d.]+$/o;
}

sub herrstr (;$)
{
  my $null_if_no_error = shift;

  return undef if ($null_if_no_error && $h_errno == 0);
  return $herrstr{$h_errno};
}

sub netstream_gethostbyname ($)
{
  my $name = shift;

  $h_errno = $? = 0;
  my @data = gethostbyname ($name);
  return @data if (scalar @data > 0);
  $h_errno = $? if ($? != 0);
  return; # distinct from `return undef' in an array context.
}

sub netstream_gethostbyaddr ($;$)
{
  my ($addr, $type) = @_;

  $type = AF_INET unless (defined $type);
  $h_errno = $? = 0;
  my $name = gethostbyaddr ($addr, $type);
  $h_errno = $? if (!defined $name && $? != 0);

  return (defined $name && $name ne "") ? $name : inet_ntoa ($addr);
}

# mode 1 = blocking, 0 = non-blocking
sub set_blocking_mode ($$)
{
  my ($sock, $mode) = @_;
  my $flags = fcntl ($sock, F_GETFL, 0);
  my $newflags = ($mode
                  ? $flags & ~(O_NONBLOCK)
                  : $flags | O_NONBLOCK);

  fcntl ($sock, F_SETFL, $newflags)
    if ($flags != $newflags);
}

# Currently the timeout argument applies independently to each connection
# attempt for multiaddressed hosts.  Should this change?
sub open_network_stream ($$;$)
{
  my ($rhostname, $port, $timeout) = @_;

  $ons_errstr = '';

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

  my @rhostaddr;
  if (ipaddrp ($rhostname))
    {
      push @rhostaddr, inet_aton ($rhostname);
    }
  else
    {
      @rhostaddr = netstream_gethostbyname ($rhostname);
      return undef unless (scalar @rhostaddr > 0);
      # try to get fully-qualified name.
      $rhostname = $rhostaddr[0]
        if (length ($rhostaddr[0]) > length ($rhostname));
      splice (@rhostaddr, 0, 4);
    }

  my $sock = gensym;
  my $connected = 0;
  my $hinfo;
  while (!$connected && scalar @rhostaddr > 0)
    {
      close ($sock) if (defined fileno ($sock));
      unless (socket ($sock, AF_INET, SOCK_STREAM, $proto))
        {
          $ons_errstr = "socket";
          return undef;
        }

      $hinfo = $rhostname;
      $hinfo .= sprintf " [%s]", inet_ntoa ($rhostaddr[0])
        unless (ipaddrp ($rhostname));
      verbose ("trying $hinfo port $port...");

      # If a timeout is specified, put socket into non-blocking mode and
      # select on it; if the connection succeeds before the timer expires,
      # put the socket back in blocking mode and return it.
      if (defined $timeout)
        {
          set_blocking_mode ($sock, 0);
          my $status = connect ($sock, sockaddr_in ($port, shift @rhostaddr));
          if ((!defined $status || $status == -1) && $! == EINPROGRESS)
            {
              my ($wbits, $tmout) = ('', $timeout);
              vec ($wbits, fileno ($sock), 1) = 1;
              my $n = select (undef, $wbits, undef, $tmout);

              next if ($n == -1);

              if ($n != 1)
                {
                  $! = ETIMEDOUT;
                  next;
                }

              # We got an event before timeout, but don't know what kind.
              # Check to make sure the connection actually succeeded.
              my $so_error = getsockopt ($sock, SOL_SOCKET, SO_ERROR);
              if (defined $so_error && unpack ('i', $so_error) != 0)
                {
                  $! = unpack ('i', $so_error);
                  next;
                }

              set_blocking_mode ($sock, 1);
              $connected = 1;
            }
        }
      else
        {
          $connected = 1
            if connect ($sock, sockaddr_in ($port, shift @rhostaddr));
        }
    }

  if ($connected)
    {
      verbose ("$hinfo port $port", "connection established.");
      return $sock;
    }

  # Must save errno value and undefine sock handle, otherwise an implicit
  # destructor is called as this function exits with no remaining
  # references to the handle; that destructor can modify errno if the
  # handle does not contain a valid file descriptor (and it probably won't
  # if the connect failed.)
  my $errno = $!;
  undef $sock;
  $! = $errno;

  $ons_errstr = "connect";
  return undef;
}

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


my $stty_saveparm;

sub stty ($)
{
  my $stty_args = shift;
  return undef unless (defined $stty_args && scalar @$stty_args > 0);

  unless (defined $stty_saveparm)
    {
      $stty_saveparm = `stty -g`;
      chop $stty_saveparm;

      for my $sig (qw(HUP INT QUIT TERM))
        {
          $SIG{$sig} = \&stty_restore;
        }
    }

  system ("stty", @$stty_args);
}

sub stty_restore (;$)
{
  return undef unless (defined $stty_saveparm);
  system ("stty", $stty_saveparm);

  my $sig = shift;
  if (defined $sig)
    {
      my %sigval = ( HUP  => 1,
                     INT  => 2,
                     QUIT => 3,
                     TERM => 15,
                   );
      exit (127 + $sigval{$sig});
    }
}


sub rhost_setproctitle ($$;$)
{
  my ($host, $port, $sock) = @_;

  if (defined $sock)
    {
      my $rsockaddr = getpeername ($sock);
      ($port, my $raddr) = unpack_sockaddr_in ($rsockaddr);

      unless ($opt_no_revres || ipaddrp ($host))
        {
          my $fqdn = netstream_gethostbyaddr ($raddr);
          $host = $fqdn if (defined $fqdn && $fqdn ne $raddr);
        }
      $host .= sprintf "[%s]", inet_ntoa ($raddr)
        unless (ipaddrp ($host));
    }
  $0 = "$progname ($host:$port)";
}

sub usage ()
{
  print "Usage: $progname {options} [host] [port]

Options are:
-h, --help            You're looking at it.
-i, --no-intr         Ignore interrupts (SIGINT).
-R, --no-resolve      Do not attempt to reverse-resolve numeric IP
                      addresses if specified on the command line.
-s, --stty     FLAGS  Run with arbitrary terminal settings,
                      e.g. \`raw', \`-echo', etc.  All flags will
                      be restored on exit.
-v, --verbose         Report on status of connection.\n";
  exit (1);
}

sub parse_options ()
{
  $progname =~ s|.*/||o;

  Getopt::Long::config ('bundling', 'autoabbrev');
  GetOptions ("h|help",                          \&usage,
              "i|no-intr",                       \$opt_no_intr,
              "P|no-proctitle",                  \$opt_no_proctitle,
              "R|no-reverse-resolve|no-resolve", \$opt_no_revres,
              "s|stty=s@",                       \@opt_stty,
              "t|timeout=i",                     \$opt_timeout,
              "v|verbose",                       \$opt_verbose,
              );

  @opt_stty = split (/\s*,\s*/o, join (",", @opt_stty));
}

sub main ()
{
  parse_options ();
  usage () unless (scalar @ARGV == 2);
  stty (\@opt_stty);

  rhost_setproctitle ($ARGV[0], $ARGV[1]) unless ($opt_no_proctitle);
  my $sock = open_network_stream ($ARGV[0], $ARGV[1], $opt_timeout);
  unless (defined $sock)
    {
      my $h = herrstr (1);
      err ($ARGV[0], $h . ".") if (defined $h);
      err ("$ARGV[0] port $ARGV[1]", $ons_errstr, $! . ".") if (!defined $h);
      exit (2);
    }

  # This is not done until now so that the program is interruptible until
  # the conection is established.
  $SIG{INT} = 'IGNORE' if ($opt_no_intr);
  rhost_setproctitle ($ARGV[0], $ARGV[1], $sock) unless ($opt_no_proctitle);
  copy_io_until_close (*STDIN{IO}, *STDOUT{IO}, $sock);
  stty_restore ();
}

main ();

# local variables:
# mode: perl
# eval: (auto-fill-mode 1)
# end:

# tcpconnect ends here.