view release on metacpan or  search on metacpan

lib/NET/MitM.pm  view on Meta::CPAN

=item * Returns --none--

=back

=head4 Usage

This method is automatically called when needed. It only needs to be called directly if you want to be sure that the connection to server succeeds before proceeding.

=cut

sub connect_to_server()
{
  my $this=shift;
  return if $this->{SERVER};
  socket($this->{SERVER}, PF_INET, SOCK_STREAM, $protocol) or die "Can't create socket: $!";
  confess "remote_ip_address unexpectedly not known" if !$this->{remote_ip_address};
  my $remote_ip_aton = inet_aton( $this->{remote_ip_address} ) or croak "Fatal: Cannot resolve internet address: '$this->{remote_ip_address}'\n";
  my $remote_port_address = sockaddr_in($this->{remote_port_num}, $remote_ip_aton ) or die "Fatal: Can't get port address: $!"; # TODO Is die the way to go here? Not sure it isn't. Not sure it is.
  $this->echo("Connecting to $this->{remote_ip_address}\:$this->{remote_port_num} [verbose=$this->{verbose}]\n");
  connect($this->{SERVER}, $remote_port_address) or confess "Fatal: Can't connect to $this->{remote_ip_address}:$this->{remote_port_num} using $this->{SERVER}. $!"; # TODO Is die the way to go here? Not sure it isn't. Not sure it is.  TODO document e...
  $this->{SERVER}->autoflush(1);
  binmode($this->{SERVER});
  return undef;
}

=head2 disconnect_from_server( )

Disconnects from the server

=head4 Parameters

=over

=item * --none--

=item * Returns --none--

=back

=head4 Usage

Disconnection is normally triggered by the other party disconnecting, not by us. disconnect_from_server() is only useful with new_client(), and not otherwise supported.

=cut

sub disconnect_from_server()
{
  my $this=shift;
  $this->log("initiating disconnect");
  $this->_destroy();
  return undef;
}

sub _pause($){
  select undef,undef,undef,shift;
  return undef;
}

sub _message_from_client_to_server(){ # TODO Too many too similar sub names, some of which maybe should be public
  my $this=shift;
  # optional sleep to reduce risk of split messages
  _pause($this->{defrag_delay}) if $this->{defrag_delay};
  # It would be possible to be more agressive by repeatedly waiting until there is a break, but that would probably err too much towards concatenating seperate messages - especially under load.
  my $msg;
  sysread($this->{CLIENT},$msg,10000);
  # (0 length message means connection closed)
  if(length($msg) == 0) { 
    $this->echo("Client disconnected\n");
    $this->_destroy();
    return;
  }
  # Send message to server, if any. Else 'send' to callback function and return result to client.
  if($this->{SERVER}){
    $this->send_to_server($msg);
  }elsif($this->{server_callback}){
    $this->send_to_client( $this->{server_callback}($msg) );
  }else{
    confess "$this->{name}: Did not expect to have neither a connection to a SERVER nor a server_callback";
  }
  return undef;
}

sub _message_from_server_to_client(){ # TODO Too many too similar sub names
  my $this=shift;
# sleep to avoid splitting messages
  _pause($this->{defrag_delay}) if $this->{defrag_delay};
# Read from SERVER and copy to CLIENT
  my $msg = $this->read_from_server();
  if(!defined $msg){
    $this->echo("Server disconnected\n");
    $this->_destroy();
    return;
  }
  $this->send_to_client($msg);
  return undef;
}

sub _cull_child()
{
  my $this=shift or die;
  my $child=shift or die;
  for my $i (0 .. @{$this->{children}}){
    if($child==$this->{children}[$i]){
      $this->echo("Child $child->{name} is done, cleaning it up") if $this->{verbose}>1;
      splice @{$this->{children}}, $i,1;
      return;
    }
  }
  confess "Child $child->{name} is finished, but I can't find it to clean it up";
}

# _main_loop is called by listeners and by their 'leave-home' children both. When called by listeners, it also includes stay at home children

sub _main_loop()
{
  my $this=shift;
  my $last_time;
  my $target_time;
  if($this->{timer_interval}&&$this->{timer_callback}){
    $last_time=time();
    $target_time=$last_time+$this->{timer_interval};