view release on metacpan or  search on metacpan

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

  binmode($this->{CLIENT});
  my ($client_port, $client_iaddr) = sockaddr_in( $client_paddr );
  $this->log("Connection accepted from", inet_ntoa($client_iaddr).":$client_port\n"); 
  $this->connect_to_server() if $this->{remote_ip_address};
  return undef;
}

sub _new_child(){
  my $parent=shift;
  my $child=_new();
  my $all_good=1;
  foreach my $key (keys %{$parent}){
    if($key=~m/^(LISTEN|children|connections|name|timer_interval|timer_callback)$/){
      # do nothing - these parameters are not inherited
    }elsif($key =~ m/^(parallel|log_file|verbose|mydate|.*callback|(local|remote)_(port_num|ip_address))$/){
      $child->{$key}=$parent->{$key};
    }elsif($key eq "LOGFILE"){
      # TODO might want to have a different logfile for each child, or at least, an option to do so.
      $child->{$key}=$parent->{$key};
    }else{
      warn "internal error - unexpected attribute: $key = {$parent->$key}\n";
      $all_good=0;
    }
  }
  die "Internal error in _new_child()" unless $all_good;
  return bless $child;
}

sub _spawn_child(){
  my $this=shift;
  my $child = $this->_new_child();
  $child->_accept($this->{LISTEN});
  confess "We have a child with no CLIENT\n" if !$child->{CLIENT};
  # hand-off the connection
  $this->echo("starting connection:",++$this->{connections});
  if(!$this->{parallel}){
    return $child;
  }
  my $pid = fork();
  if(!defined $pid){
    # Error
    $this->echo("Cannot fork!: $!\nNew connection will run in the current thread\n");
    return $child;
  }elsif(!$pid){
    # This is the child process
    $child->echo(sprintf"Running %u",$$) if $child->{verbose}>1;
    confess "We have a child with no CLIENT\n" if !$child->{CLIENT};
    # The active instanct of the parent is in a different process
    # Ideally, we would have the parent go out of scope, but all we can do is clean up the bits that matter
    close $this->{LISTEN};
    $child->_main_loop();
    $child->echo(sprintf"Exiting %u",$$) if $child->{verbose}>1;
    exit;
  }else{
    # This is the parent process.  The active child instance is in its own process, we clean up what we can
    $child->_destroy();
    return undef;
  }
}

sub go()
{
  my $this=shift;
  $this->listen();
  $this->_main_loop();
  return undef;
}

sub _destroy()
{
  my $this=shift;
  close $this->{CLIENT} if($this->{CLIENT});
  close $this->{SERVER} if($this->{SERVER});
  $this->{SERVER}=$this->{CLIENT}=undef;
  return undef;
}

=head1 Exports

MitM does not export any functions or variables.  
If parallel() is turned on, which by default it is not, MitM sets SIGCHD to IGNORE, and as advertised, it calls fork() once for each new connection.

=head1 AUTHOR

Ben AVELING, C<< <ben dot aveling at optusnet dot com dot au> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-NET-MitM at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=NET-MitM>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc NET::MitM

You can also look for information at:

=over

=item * RT: CPAN's request tracker (report bugs here)

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=NET-MitM>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/NET-MitM>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/NET-MitM>

=item * Search CPAN

L<http://search.cpan.org/dist/NET-MitM/>

=back

=head1 ACKNOWLEDGEMENTS