NetIO.pm

#!/usr/bin/perl
package LaBrea::NetIO;
use strict;
#use diagnostics;
use vars qw($VERSION @ISA @EXPORT_OK );

$VERSION = do { my @r = (q$Revision: 0.01 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

use Socket;
use AutoLoader 'AUTOLOAD';
require Exporter;
@ISA = qw(Exporter);

@EXPORT_OK = (@Socket::EXPORT, @Socket::EXPORT_OK, qw(
	TARPIT_PORT
	open_listen_sock
	open_tcp
	alarm_wrap
	daemon_handler
	read_daemon
	fetch
	reap_kids
	set_so_linger
));

# autoload declarations

sub open_listen_sock;
sub open_tcp;
sub alarm_wrap;
sub daemon_handler;
sub fetch;
sub read_daemon;
sub reap_kids;
sub set_so_linger;
sub TARPIT_PORT { 8686; };
#
sub _fetch;
sub _want_daemon;
sub DESTROY {};

1;
__END__

=head1 NAME

  LaBrea::Tarpit::NetIO

=head1 SYNOPSIS

  use LaBrea::Tarpit::NetIO qw (
	TARPIT_PORT
	open_listen_sock
	open_tcp
	alarm_wrap
	daemon_handler
	read_daemon
	fetch
	reap_kids
	set_so_linger
    [plus any Socket.pm variable]
  );

  $error=open_listen_sock(HANDLE,address,port);
  $error=open_tcp(*S,$host,$port);
  *rv = alarm_wrap($timeout,$subref,@args);
  $subref=daemon_handler(*HANDLE,$target);
  read_daemon($subref,\@response);
  $err=fetch($target,\@response,$command);
  $alive = reap_kids(\%kids);
  $rv = set_so_linger(*HANDLE,$seconds);

=head1 DESCRIPTION

B<NetIO> contains TCP client and server modules used by Tarpit modules.

B<NetIO> has available for EXPORT, any variable from the standard Socket.pm
module.

=over 4

=item $error=open_listen_sock(HANDLE,address,port);

Opens a server listening socket on HANDLE

  input:	HANDLE,
		address,  name or ip
			defaults to all 
			interfaces if false 
		port	  defaults to 8686

  returns:	false on success
		or error message

=cut

sub open_listen_sock {
  my ($S,$host,$port) = @_;
# default connection is to ANY interface
  my $iaddr = INADDR_ANY;
  return 'interface address not found'
	if $host && ! ($iaddr = inet_aton($host));
  my $proto = getprotobyname('tcp');
  $port = TARPIT_PORT unless $port && $port !~ /[\D]/;

  return 'failed to create socket'
	unless socket($S,PF_INET,SOCK_STREAM,$proto);

  unless (setsockopt($S,SOL_SOCKET,SO_REUSEADDR,1)) {
    close $S;
    return 'failed to set socket options';
  }

  unless (bind($S,sockaddr_in($port,$iaddr))) {
    close $S;
    return 'failed to bind socket';
  }
  unless (listen($S,SOMAXCONN)) {
    close $S;
    return "failed to set listen queue";
  }
  $_ = select $S;
  $| = 1;
  select $_;
  return undef;
}

=item $error=open_tcp(*S,$host,$port);

Open a tcp connection on port to host.

  input:	*S,hostname, port
  returns:	false on success
		error message on failure

=cut

sub open_tcp {
  my ($S,$host,$port) = @_;
  my $iaddr;
  return 'port is not numeric'
	if !$port || $port =~ /\D/;
  return 'hostname not found'
	unless ($iaddr = inet_aton($host));
  my $proto = getprotobyname('tcp');
  return 'unable to open socket'
	unless socket($S, PF_INET, SOCK_STREAM, $proto );
  my $paddr = sockaddr_in($port, $iaddr);
  unless (connect($S, $paddr)) {
    close $S;
    return 'could not connect to host';
  }
  $host = select $S;	# temp save old selection
  $| = 1;
  select $host;		# restore selection
  return undef;
}

=item $rv = alarm_wrap($timeout,$subref,@args);

Provides an alarm wrapper for subroutines that may time out or B<die>.

  input:	timeout,
		$subref,
		arguments for $subref

  returns:	$subref return value(s)
		  on error
		undef or () on error
	$@ is set with error value
	which will contain the string
	'alarm_wrap timeout' if
	the fault was timeout only

	timeout is ignored if false

=cut

sub alarm_wrap {
  my ($timeout,$subref,@args) = @_;
  local $SIG{ALRM} = sub { die 'alarm_wrap timeout' };
  my @rv;
  alarm $timeout if $timeout;
  eval { @rv = &$subref(@args) };
  alarm 0;
  @rv = () if $@;
  return (wantarray) ? @rv : "@rv";
}

=item $subref=daemon_handler(*HANDLE,$target);

Opens a handle *HANDLE pointing to the Tarpit daemon, pipe or file
and returns a CODEREF to a subroutine that will read full
lines of data from the HANDLE. Do not try to read the handle directly.

  input:   *HANDLE
	   file name/path
	    or
	   hash	->{d_host} [optional]
	  	->{d_port} [optional]

If B<target> is a HASH and d_host and/or d_port are not specified,
they default to localhost:8686

  returns: subref or undef on open fail

  usage:  $present = daemon_handler(*H,$t);
	  while ( $data = &$present ) {
	    do something with $data;
	  }
	  close H;

=cut

sub daemon_handler {
  my ($S,$target) = @_;
  if ( &_want_daemon(\$target) ) {
    my $d_port = $target->{d_port} || TARPIT_PORT;
    my $d_host = $target->{d_host} || 'localhost';
    return undef if open_tcp($S,$d_host,$d_port);
    return sub { readline($S) };
  } else {
    return undef unless open($S,$target);
    return sub { return scalar <$S> };
  }
  return undef;
}

# input:	pointer to target
# returns:	true if daemon
#		false if file
#		target is modified in place
#		to point to file if HASH->{file}
#
sub _want_daemon {
  my ($tgp) = @_;
  return undef unless $tgp;
  return undef unless ref $$tgp eq 'HASH';
  if ( exists ${$tgp}->{file} ) {
    $$tgp = ${$tgp}->{file};		# replace with file name
    return undef;
  }
  1;
}

=item read_daemon($subref,\@response);

B<read_daemon> retrieves the response text from a 
file or daemon and places the lines in array.

  input:	$subref to execute
		pointer to @response

  returns:	number of lines
		fills @response

  Note:	use 'alarm_wrap' with this routine

=cut

sub read_daemon {
  my ($subref,$ary) = @_;
  while ($_ = &$subref) {
    push @$ary, $_;		# recover report from daemon
  }
  $ary = @$ary;			# return number of lines
}

=item $error=fetch($target,\@response,$command);

B<fetch> a response from B<target> using B<args>. Essentially a combination
of B<daemon_handler> and B<read_daemon> wrapped with B<alarm_wrap>.
Retrieves data from the host or file specified by B<target>. The B<args>
argument is ignored if B<target> is a file.

  input:  target, # hash->{host} [optional]
		  # hash->{port} [optional]
		  # hash->{d_timeout} [optional]
	  \@response,	# result lines
	  command,		# what to tell host

  returns:	error if fail
		false on success

=cut

sub fetch {
  my ($target,$ary,$command) = @_;
  local *DAEMON;
  my $subref = daemon_handler(*DAEMON,$target);
  return "failed to open target" unless $subref;
  my $timeout = (&_want_daemon(\$target) && $target->{d_timeout})
	? $target->{d_timeout}
	: 180;
  alarm_wrap($timeout,\&_fetch,*DAEMON,$target,$subref,$ary,$command);
  close DAEMON;
  return $@;
}

sub _fetch {
  my ($DAEMON,$target,$subref,$ary,$command) = @_;
  print $DAEMON $command,"\n"
	if $command && &_want_daemon(\$target);
  read_daemon($subref,$ary);
}

=item $alive = reap_kids(\%kids);

Non-blocking reaper for PID's in (keys %kids). Deletes zombie children from
%kids and returns the number of kids remaining.

  input:	\%kids	# hash of child PID's
  returns:	number of kids remaining

=cut

sub reap_kids {
  my ($kp) = @_;
  return 0 unless (@_ = keys %$kp);
  require POSIX;
  $_ = &POSIX::WNOHANG;
  foreach my $pid (@_) {
    delete $kp->{$pid} if waitpid($pid,$_);
  }
  return scalar keys %$kp;
}

=item $rv = set_so_linger(*HANDLE,$seconds);

  Set SO_LINGER on top level socket

  input:	*HANDLE, seconds
  returns:	true = success, false = fail

=back

=cut

sub set_so_linger {
  my ($FH,$sec) = @_;
  setsockopt($FH,SOL_SOCKET,SO_LINGER,pack("ll",1,$sec));
}

=head1 EXPORT_OK

	TARPIT_PORT
	open_listen_sock
	open_tcp
	alarm_wrap
	daemon_handler
	read_daemon
	fetch
	reap_kids
	set_so_linger
    [plus any Socket.pm variable]

=head1 COPYRIGHT

Copyright 2002, Michael Robinton & BizSystems
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 of the License, 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, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

=head1 AUTHOR

Michael Robinton, michael@bizsystems.com

=head1 SEE ALSO

perl(1), Socket(3), LaBrea::Tarpit(3), LaBrea::Tarpit::Get(3), LaBrea::Tarpit::Report(3),
LaBrea::Tarpit::Util(3), LaBrea::Tarpit::DShield(3), LaBrea::Tarpit::Codes(3)

=cut

1;