package Pitonyak::SocketUtil;

require Exporter;
$LogFile::VERSION = '1.01';

#************************************************************

=head1 NAME

Pitonyak::SocketUtil - Automates the process of using sockets.

=head1 SYNOPSIS

Automates the process of using sockets.

=head1 DESCRIPTION

Automates the process of using sockets.

=cut

#************************************************************

@ISA       = qw(Exporter);
#@EXPORT    = qw(is_ok is_connected local_port local_host remote_host remote_port socket_type is_open open close is_ready read_socket write_socket);

use Carp;
use strict;
use IO::Select;
use Sys::Hostname;
use IO::Socket;

my %initial_attributes = (
   'local_port'  => 0,        # Port on my end
   'local_host'  => '',       # My host
   'remote_host' => '',       # Host to which I am connected (if any)
   'remote_port' => 0,        # Port on out side host on which I am connected (if any)
   'socket_type' => 'tcp',    # Connection type such as udp (for datagrams)
   'last_host_ip'=> '0.0.0.0',
   'last_host'   => '',       # From whom did I last recieve a message (remote host)
   'last_port'   => 0,        # From where did I last receive a message (remote port)
   'is_connected'=> 0,        # Is this socket currently connected
   'is_ok'       => 0,        #
   'is_open'     => 0,        #
   'stack_trace' => 1,        # Include a stack trace with errors
);

#************************************************************
#**
#**  Input : connection type such as tcp or udp
#**          local port (0 for no local port specified)
#**          optional remote host port (0 for none or skip)
#**          optional remote host name (defaults to local host)
#**
#**  Output: A new Object
#**
#**  Notes : Note that this is written in such a manner
#**          that it can be inherited. Also note that it
#**          is written such that $obj2 = $obj1->new()
#**          is valid, although in general this means
#**          little in practice.
#**
#************************************************************

sub new
{
   my $self   = shift;
   my $objref = bless {}, ref($self) || $self;
   $objref->initialize();
   if (ref($self))
   {
       $objref->copy($self);
   }
   $objref->{'socket_type'} = shift if $#_ >= 0;
   $objref->{'local_port'} = shift if $#_ >= 0;
   $objref->{'remote_port'} = shift if $#_ >= 0;
   $objref->{'remote_host'} = shift if $#_ >= 0;
   if (defined($objref->{'remote_host'}) && $objref->{'remote_host'} ne '')
   {
      my $ip_addr = inet_aton($objref->{'remote_host'});
      if (defined($ip_addr))
      {
         $objref->{'remote_host_packed_ip'} = $ip_addr;
         $objref->{'remote_host_ip'} = join('.', unpack('C4', $ip_addr));
      }
   }
   return $objref;
}


#************************************************************
#**                                                        **
#**  Input : None.                                         **
#**                                                        **
#**  Output: None.                                         **
#**                                                        **
#**  Notes : Not really needed since the destructor for    **
#**          the file handle will cleanup after itself!    **
#**                                                        **
#************************************************************

sub DESTROY
{
   $_[0]->close();
}

sub copy
{
   my ($obj, $obj2) = @_;
   foreach (keys %initial_attributes)
   {
      $obj->{$_} = $obj2->{$_};
   }
   $obj->{'is_connected'} = 0;
   $obj->{'is_ok'} = 0;
   $obj->{'is_open'} = 0;
}

#************************************************************
#**                                                        **
#**  Input : None.                                         **
#**                                                        **
#**  Output: None.                                         **
#**                                                        **
#**  Notes : Initialize the data structure.                **
#**                                                        **
#************************************************************

sub initialize
{
   my $obj = shift;
   foreach (keys %initial_attributes)
   {
      $obj->{$_} = $initial_attributes{$_};
   }
   $obj->{'socket'} = 0;
   $obj->{'local_host'} = hostname();
}

#************************************************************
#**                                                        **
#**  Input : None                                          **
#**                                                        **
#**  Output: Value of is_ok                                **
#**                                                        **
#**  Notes : This verifies that the type is ok             **
#**          and nothing more. You probably really want to **
#**          check and see if an error occurred.            **
#**                                                        **
#************************************************************

sub is_ok
{
   $_[0]->{'is_ok'} = 0 if $_[0]->{'is_ok'} && exists($_[0]->{'socket'}) && defined($_[0]->{'socket'}) && !UNIVERSAL::isa($_[0]->{'socket'}, 'IO::Socket');
   return $_[0]->{'is_ok'};
}

#************************************************************
#**                                                        **
#**  Input : None                                          **
#**                                                        **
#**  Output: Value of is_open                              **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub is_open
{
   return $_[0]->{'is_open'};
}

#************************************************************
#**                                                        **
#**  Input : Optional value to set for local_port          **
#**                                                        **
#**  Output: Value of local_port                           **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub local_port
{
   return get_attribute(@_, "local_port");
}

#************************************************************
#**                                                        **
#**  Input : Optional value to set for local_host          **
#**                                                        **
#**  Output: Value of local_host                           **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub local_host
{
   return get_attribute(@_, "local_host");
}

#************************************************************
#**                                                        **
#**  Input : Optional value to set for remote_host         **
#**                                                        **
#**  Output: Value of remote_host                          **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub remote_host
{
   if ($#_ > 0)
   {
      $_[0]->{'remote_host'} = $_[1];
      $_[0]->{'remote_host'} = shift if $#_ >= 0;
      delete $_[0]->{'remote_host_packed_ip'};
      delete $_[0]->{'remote_host_ip'};
      if (defined($_[0]->{'remote_host'}) && $_[0]->{'remote_host'} ne '')
      {
         my $ip_addr = inet_aton($_[0]->{'remote_host'});
         if (defined($ip_addr))
         {
            $_[0]->{'remote_host_packed_ip'} = $ip_addr;
            $_[0]->{'remote_host_ip'} = join('.', unpack('C4', $ip_addr));
         }
      }
   }
   return $_[0]->{'remote_host'};
}

#************************************************************
#**                                                        **
#**  Input : Optional value to set for remote_port         **
#**                                                        **
#**  Output: Value of remote_port                          **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub remote_port
{
   return get_attribute(@_, "remote_port");
}

#************************************************************
#**                                                        **
#**  Input : Optional value to set for socket_type         **
#**                                                        **
#**  Output: Value of socket_type                          **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub socket_type
{
   return get_attribute(@_, "socket_type");
}

#************************************************************
#**                                                        **
#**  Input : Optional value to set for last_host           **
#**                                                        **
#**  Output: Value of last_host                            **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub last_host
{
   return get_attribute(@_, "last_host");
}

#************************************************************
#**                                                        **
#**  Input : Optional value to set for last_host_ip        **
#**                                                        **
#**  Output: Value of last_host_ip                         **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub last_host_ip
{
   return get_attribute(@_, "last_host_ip");
}

#************************************************************
#**                                                        **
#**  Input : Optional value to set for last_port           **
#**                                                        **
#**  Output: Value of last_port                            **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub last_port
{
   return get_attribute(@_, "last_port");
}

#************************************************************
#**                                                        **
#**  Input : None                                          **
#**                                                        **
#**  Output: Value of is_connected                         **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub is_connected
{
   my $ok = 0;
   if ($_[0]->is_ok() && $_[0]->{'is_connected'})
   {
      if (defined($_[0]->{'socket'}) && UNIVERSAL::isa($_[0]->{'socket'}, 'IO::Socket') && defined($_[0]->{'socket'}->peername()))
      {
         $ok = 1;
      }
      else
      {
         $_[0]->{'is_connected'} = 0;
         close();
      }
   }
   return $ok;
}

#************************************************************
#**                                                        **
#**  Input : $name  : Name of the attribute to set         **
#**          $value : Optional value to set for $name      **
#**                                                        **
#**  Output: State of the mentioned attribute              **
#**                                                        **
#**  Notes : No value is required, in which case, only     **
#**          the value is returned and the value is not    **
#**          changed.                                      **
#**                                                        **
#************************************************************

sub get_attribute
{
   my $obj = shift;
   my ($name, $value);
   if (scalar(@_) == 2)
   {
      $value = shift;
      $name  = shift;
      $obj->{$name} = $value;
   }
   else
   {
      $name  = shift;
   }
   return $obj->{$name};
}

#************************************************************
#**                                                        **
#**  Input : None                                          **
#**                                                        **
#**  Output: 1 if the obj is open, 0 otherwise             **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub open()
{
   if (!$_[0]->{'is_open'})
   {
      $_[0]->{'last_host_ip'} = '0.0.0.0';
      $_[0]->{'last_host'}    = '';
      $_[0]->{'last_port'}    = '';
      $_[0]->{'is_connected'} = ($_[0]->{'remote_port'} > 0) ? 1 : 0;
      $_[0]->{'is_ok'}        =  1;
      $_[0]->{'is_open'}      =  0;
      $_[0]->{'errors'}       = ();
      $_[0]->{'socket'}       =  0;

      my $socket_type = $_[0]->{'socket_type'};
      my $local_port  = $_[0]->{'local_port'};
      my $remote_port = $_[0]->{'remote_port'};
      my $remote_host = $_[0]->{'remote_host'};
      $remote_host = $_[0]->{'local_host'} if $remote_host eq '';
      #
      # Build the command which is evaluated to create the handle
      #
      my $cmd = '$handle = IO::Socket::INET->new(Proto => $socket_type,';
      $cmd .= 'PeerAddr  => $remote_host, PeerPort  => $remote_port,' if $remote_port > 0;
      $cmd .= 'LocalPort => $local_port,' if $local_port > 0;
      $cmd .= ');';
      #
      # If creating the socket fails, then the program may die.
      # This is not acceptable so I use eval!
      # I do, however, use tricky code here!
      #
      my $handle;
      #
      # If An attempt is made to connect to a non-existant socket, then a warning
      # is issued. I will trap this warning by writing my own "warning" handler as done below.
      # This then pushed the warnings onto a local stack that I can check.
      #
      my @local_errors = ();
      local $SIG{__WARN__} = sub { push @local_errors, @_; };
      eval $cmd;
      #
      # Are there any other errors for which I should look?
      #
      if ($#local_errors >= 0 && $local_errors[0] =~ /connection\s+refused/i)
      {
         $_[0]->add_errors(@local_errors);
         $handle = 0;
      }
      $_[0]->{'socket'} = $handle;
      #
      # If an error occurred in the eval, then $@ was set.
      #
      if ($@)
      {
         $_[0]->add_errors("Unable to create a $socket_type socket on $local_port to $remote_host:$remote_port because $@");
         $handle = 0;
      }
      elsif (!$_[0]->is_ok())
      {
         $_[0]->add_errors(@local_errors) if $#local_errors >= 0;
         $_[0]->add_errors("Invalid $socket_type socket created on $local_port to $remote_host:$remote_port because $!");
         $handle = 0;
      }
      elsif ($remote_port > 0 && !$_[0]->is_connected())
      {
         $_[0]->add_errors(@local_errors) if $#local_errors >= 0;
         $_[0]->add_errors("Unconnected, but valid, $socket_type socket created on $local_port to $remote_host:$remote_port because $!");
         $handle = 0;
      }
      else
      {
         $handle->timeout(1);
         $handle->autoflush();     # in case using an older version of IO::Socket which does not do this
         select($handle); $| = 1;  # Turn off I/O buffering on the TCP handle.
         select(STDERR);  $| = 1;  # Turn off I/O buffering on STDERR.
         select(STDOUT);  $| = 1;  # Turn off I/O buffering on STDOUT.
         $_[0]->{'is_open'} = 1;
      }
      $_[0]->{'socket'} = $handle;
   }
   return $_[0]->{'is_open'};
}

#************************************************************
#**                                                        **
#**  Input : None                                          **
#**                                                        **
#**  Output: A stack trace to this point                   **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub get_stack_trace
{
   my $obj = shift;
   my $i = 1;
   my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask) = ('', '', '', '', '', '', '', '', '', '', '', '', '', '', '');

   my $rc = '';
   #
   # Crawl the stack. Note that if I made the call within a "Package DB" context
   # then I would also have the arg list. This would look something like
   # while (do { { package DB; @a = caller($i++) } } ) { process here }
   # but I just do not care about the parameters at this time.
   #
   while (($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller($i++))
   {
      #
      # Build a string, $subroutine, which names the sub-routine called.
      # This may also be "require ...", "eval '...' or "eval {...}"
      # So if things were done with an eval of sorts then make $subroutine
      # what we desire.
      #
      if (defined $evaltext)
      {
         #
         # Were we in a require statement?
         #
         if ($is_require)
         {
            $subroutine = "require $evaltext";
         }
         else
         {
            #
            # Render the eval string safe and then chop it if it is too long.
            #
            $evaltext =~ s/([\\\'])/\\$1/g;
            if (length($evaltext) > 20)
            {
               substr($evaltext, 20) = '...';
            }
            $subroutine = "eval '$evaltext'";
         }
      }
      elsif ($subroutine eq '(eval)')
      {
         $subroutine = 'eval {...}';
      }
      #
      # here's where the error message, $mess, is constructed
      #
      $rc .= "$subroutine called at $filename line $line";
      #
      # Was this multi-threaded?
      #
      if (defined &Thread::tid)
      {
         my $tid = Thread->self->tid;
         $rc .= " thread $tid" if $tid;
      }
      $rc .= "\n";
   }
   return $rc;
}

#************************************************************
#**                                                        **
#**  Input : None.                                         **
#**                                                        **
#**  Output: 1 if the file is open and ok, 0 otherwise.    **
#**                                                        **
#**  Notes:  This will open the socket if it can.          **
#**          Well, it will if auto_connect is true.        **
#**          In this case then you must manually open it.  **
#**                                                        **
#************************************************************

sub verify_open
{
   return ($_[0]->{'is_open'} || (!$_[0]->error_occurred() && $_[0]->{'auto_connect'} && $_[0]->open())) ? $_[0]->is_ok() : 0;
}

#************************************************************
#**                                                        **
#**  Input : None.                                         **
#**                                                        **
#**  Output: None.                                         **
#**                                                        **
#**  Notes:                                                **
#**                                                        **
#************************************************************

sub close
{
   if ($_[0]->is_open())
   {
      my $handle = $_[0]->{'socket'};
      if (defined($handle) && UNIVERSAL::can($handle, 'close'))
      {
         my $cmd = '$handle->close()';
         eval $cmd;
      }
      $_[0]->{'is_connected'} = 0;
      $_[0]->{'is_ok'}        = 0;
      $_[0]->{'is_open'}      = 0;
      $_[0]->{'socket'}       = 0;
   }
}

#************************************************************
#**                                                        **
#**  Input : Optional timeout value, defaults to one sec   **
#**                                                        **
#**  Output: None.                                         **
#**                                                        **
#**   Notes: Will connect automatically                    **
#**                                                        **
#************************************************************

sub read_socket
{
   my $obj = shift;
   my $line = '';
   my $time_out = ($#_ >= 0) ? $_[0] : 1;
   if ($obj->verify_open())
   {
      my $handle = $obj->{'socket'};
      my($rmask, $emask) = ('', '');
      vec($rmask, fileno($handle), 1) = 1;
      vec($emask, fileno($handle), 1) = 1;
      my ($nfound, $timeleft) = select($rmask, undef, $emask, $time_out);
      if ($nfound < 0)
      {
         $obj->add_errors("Socket error in read_socket(), socket probably closed by remote host: $!");
         $obj->close();
      }
      elsif ($nfound > 0)
      {
         #
         # Is this a Datagram?
         #
         if ($obj->{'socket_type'} eq 'udp')
         {
            my $from_addr = recv($handle, $line, 34096, 0);
            if ($from_addr)
            {
               my ($family, $fromport, $fromipaddr) = unpack('S n a4 x8',$from_addr);
               $obj->{'last_port'} = $fromport;
               $obj->{'last_host_ip'} = join('.', unpack('C4', $fromipaddr));
               $obj->{'last_host'} = gethostbyaddr($fromipaddr,AF_INET);
               $obj->{'last_host'} = $obj->{'last_host_ip'} if !defined($obj->{'last_host'});
            }
            else
            {
               $line = '';
            }
         }
         #
         # Standard tcp connection
         #
         elsif ($obj->{'socket_type'} eq 'tcp')
         {
            if (sysread($handle, $line, 4096))
            {
               $obj->{'last_host'} = $obj->{'remote_host'};
               $obj->{'last_port'} = $obj->{'remote_port'};
            }
            else
            {
               $obj->add_errors("Socket error in read_socket(), socket probably closed by remote host: $!");
               $obj->close();
            }
         }
      }
   }
   return $line;
}

#************************************************************
#**                                                        **
#**  Input : Arbitrary list of lines to print              **
#**                                                        **
#**  Output: 1 on success, 0 on failure                    **
#**                                                        **
#**  Notes : If the socket is not currently open and no    **
#**          errors have yet occurred, then the socket is   **
#**          opened automatically.                         **
#**                                                        **
#************************************************************

sub write_socket
{
   my $obj = shift;
   #
   # Make certain that I can open this thing
   #
   if ($obj->verify_open())
   {
      my $handle = $obj->{'socket'};
      if ($obj->{'socket_type'} eq 'udp')
      {
         if (!exists($obj->{'remote_host_packed_ip'}))
         {
            $obj->add_errors("Socket is type udp and remote_host_packed_ip is not set for host ".$obj->{'remote_host'});
            $obj->close();
         }
         else
         {
            my $hispaddr = sockaddr_in($obj->{'remote_port'}, $obj->{'remote_host_packed_ip'});
            while ($#_ >= 0 && $obj->is_ok())
            {
               my $line = shift;
               if (!defined(send($handle, $line, 0, $hispaddr)))
               {
                  $obj->add_errors("Error sending ($line) because:$!");
                  $obj->close();
               }
            }
         }
      }
      #
      # Standard tcp connection
      #
      elsif ($obj->{'socket_type'} eq 'tcp')
      {
         while ($#_ >= 0 && $obj->is_connected())
         {
            my $line = shift;
            #
            # If the $handle is not good then print may simply exit.
            # I have not been able to stop this even by using eval!
            #
            my $ret = print $handle $line;
            if ( $ret )
            {
               # No error occurred
            }
            else
            {
               $obj->add_errors("Error printing to handle in write_socket: $!");
               $obj->close();
            }
         }
      }
   }
   else
   {
      $obj->add_errors("Error, unable to open the socket");
   }
   return $obj->{'is_open'};
}

#************************************************************
#**                                                        **
#**  Input : List of error numbers desired                 **
#**                                                        **
#**  Output: Requested errors.                             **
#**                                                        **
#**  Notes : If a list of numbers is given then these      **
#**          errors are used as the desired list of errors.**
#**          If not, then the entire list of errors is     **
#**          used. If an array is desired for return then  **
#**          the entire list is returned. If a scalar is   **
#**          desired for return then only the last error   **
#**          is returned.                                  **
#**                                                        **
#************************************************************

sub get_errors
{
   my $obj = shift;
   my $num = $obj->num_errors_occurred();
   if ($#_ >= 0)
   {
      my @errors;
      foreach (@_)
      {
         push @errors, $obj->{'errors'}[$_] if $_ < $num;
      }
      return wantarray ? @errors : ($#errors >= 0) ? $errors[-1] : '';
   }
   else
   {
      return wantarray ? @{$obj->{'errors'}} : ($num > 0) ? $obj->{'errors'}->[$num-1] : '';
   }
}

sub get_errors_as_one_string
{
   return join("\n", @{$_[0]->{'errors'}});
}

#************************************************************
#**                                                        **
#**  Input : None                                          **
#**                                                        **
#**  Output: 1 if an error has occurred, 0 otherwise.       **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub error_occurred
{
   return $#{$_[0]->{'errors'}} >= 0 ? 1 : 0;
}

#************************************************************
#**                                                        **
#**  Input : None                                          **
#**                                                        **
#**  Output: Number of errors that have occurred.           **
#**                                                        **
#**  Notes :                                               **
#**                                                        **
#************************************************************

sub num_errors_occurred
{
   return $#{$_[0]->{'errors'}} + 1;
}

#************************************************************
#**                                                        **
#**  Input : List of errors to add                         **
#**                                                        **
#**  Output: None.                                         **
#**                                                        **
#**  Notes : Pushes errors onto the end of the list.       **
#**          If too many errors exist, then older errors   **
#**          are discarded.                                **
#**          If stack_trace is true then a stack trace     **
#**          will be added before the error.               **
#**                                                        **
#************************************************************

sub add_errors
{
   my $obj = shift;
   if ($#_ >= 0)
   {
      push(@{$obj->{'errors'}}, $obj->get_stack_trace()) if $obj->{'stack_trace'};
      push @{$obj->{'errors'}}, @_;
      splice(@{$obj->{'errors'}}, 0, $#{$obj->{'errors'}} - 20) if $#{$obj->{'errors'}} > 20;
   }
}

#************************************************************
#**                                                        **
#**  Input : Optional value to set                         **
#**                                                        **
#**  Output: Value for the attribute                       **
#**                                                        **
#**  Notes : If stack trace is set then all errors will    **
#**          include a complete stack trace to the error.  **
#**                                                        **
#************************************************************

sub stack_trace
{
   return get_attribute(@_, "stack_trace");
}

#************************************************************
#**                                                        **
#**  Input : Optional value to set                         **
#**                                                        **
#**  Output: Value for the attribute                       **
#**                                                        **
#**  Notes : If true, then will automatically connect when **
#**          an operation occurres such as write or read    **
#**                                                        **
#************************************************************

sub auto_connect
{
   return get_attribute(@_, "auto_connect");
}


#************************************************************

=pod

=head1 COPYRIGHT

Copyright 2000-2007, Andrew Pitonyak (andrew@pitonyak.org)

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 Modification History

=head2 Sept 14, 2000

Version 1.00 First release

=cut

#************************************************************

1;