package Mojo::SNMP::Dispatcher;

=head1 NAME

Mojo::SNMP::Dispatcher - Instead of Net::SNMP::Dispatcher

=head1 DESCRIPTION

This module works better with L<Mojo::IOLoop> since it register the
L<IO::Socket::INET> sockets in with the mojo reactor.

=cut

use Errno;
use Mojo::Base -base;
use Mojo::IOLoop::Stream;
use Net::SNMP::MessageProcessing ();
use Net::SNMP::Message qw( TRUE FALSE );
use Scalar::Util ();
use constant DEBUG => $ENV{MOJO_SNMP_DEBUG} ? 1 : 0;

=head1 ATTRIBUTES

=head2 ioloop

Holds a L<Mojo::IOLoop> object. Same as L<Mojo::SNMP/ioloop>.

=head2 message_processing

Holds an instance of L<Net::SNMP::MessageProcessing>.

=head2 debug

Does nothing. Use C<MOJO_SNMP_DEBUG=1> instead to get debug information.

=head2 error

Holds the last error.

=cut

has ioloop             => sub { Mojo::IOLoop->singleton };
has message_processing => sub { Net::SNMP::MessageProcessing->instance };
has debug => 0;    # Use MOJO_SNMP_DEBUG=1 instead

=head2 connections

Holds the number of active sockets.

=cut

sub connections { int values %{$_[0]->{descriptors}} }

sub error {
  my ($self, $format, @args) = @_;

  return $self->{error} if @_ == 1;
  $self->{error} = defined $format ? sprintf $format, @args : undef;
  warn "[DISPATCHER] $self->{error}\n" if DEBUG and defined $format;
  return $self;
}

=head1 METHODS

=head2 send_pdu

This method will send a PDU to the SNMP server.

=cut

sub send_pdu {
  my ($self, $pdu, $delay) = @_;

  unless (ref $pdu) {
    $self->error('The required PDU object is missing or invalid');
    return FALSE;
  }

  $self->error(undef);
  $self->schedule($delay, [_send_pdu => $pdu, $pdu->retries]);

  return TRUE;
}

=head2 return_response_pdu

No idea what this does (?)

=cut

sub return_response_pdu {
  $_[0]->send_pdu($_[1], -1);
}

=head2 msg_handle_alloc

No idea what this does (?)

=cut

sub msg_handle_alloc {
  $_[0]->message_processing->msg_handle_alloc;
}

=head2 schedule

Used to schedule events at a given time. Use L<Mojo::IOLoop/timer> to
do the heavy lifting.

=cut

sub schedule {
  my ($self, $time, $callback) = @_;
  my $code = shift @$callback;

  warn "[DISPATCHER] Schedule $time $code(@$callback)\n" if DEBUG;

  if ($time) {
    Scalar::Util::weaken($self);
    $self->ioloop->timer($time => sub { $self->$code(@$callback) });
  }
  else {
    $self->$code(@$callback);
  }
}

=head2 register

Register a new transport object with L<Mojo::IOLoop::Reactor>.

=cut

sub register {
  my ($self, $transport) = @_;
  my $reactor = $self->ioloop->reactor;
  my $fileno;

  unless (defined $transport and defined($fileno = $transport->fileno)) {
    $self->error('The Transport Domain object is invalid');
    return FALSE;
  }

  if ($self->{descriptors}{$fileno}++) {
    return $transport;
  }

  Scalar::Util::weaken($self);
  $reactor->io(
    $transport->socket,
    sub {
      $self->_transport_response_received($transport);
    }
  );

  $reactor->watch($transport->socket, 1, 0);
  warn "[DISPATCHER] Add handler for descriptor $fileno\n" if DEBUG;
  return $transport;
}

=head2 deregister

The opposite of L</register>.

=cut

sub deregister {
  my ($self, $transport) = @_;
  my $fileno = $transport->fileno;
  return if --$self->{descriptors}{$fileno} > 0;
  delete $self->{descriptors}{$fileno};
  warn "[DISPATCHER] Remove handler for descriptor $fileno\n" if DEBUG;
  $self->ioloop->reactor->remove($transport->socket);
}

sub _send_pdu {
  my ($self, $pdu, $retries) = @_;
  my $mp  = $self->message_processing;
  my $msg = $mp->prepare_outgoing_msg($pdu);

  unless (defined $msg) {
    warn "[DISPATCHER] prepare_outgoing_msg: @{[$mp->error]}\n" if DEBUG;
    $pdu->status_information($mp->error);
    return;
  }
  unless (defined $msg->send) {
    if ($pdu->expect_response) {
      $mp->msg_handle_delete($msg->msg_id);
    }
    if ($retries-- > 0 and $!{EAGAIN} or $!{EWOULDBLOCK}) {
      warn "[DISPATCHER] Attempt to recover from temporary failure: $!\n" if DEBUG;
      $self->schedule($pdu->timeout, [_send_pdu => $pdu, $retries]);
      return FALSE;
    }

    $pdu->status_information($msg->error);
    return;
  }

  if ($pdu->expect_response) {
    $self->register($msg->transport);
    $msg->timeout_id($self->schedule($pdu->timeout, ['_transport_timeout', $pdu, $retries, $msg->msg_id,]));
  }

  return TRUE;
}

sub _transport_timeout {
  my ($self, $pdu, $retries, $handle) = @_;

  $self->deregister($pdu->transport);
  $self->message_processing->msg_handle_delete($handle);

  if ($retries-- > 0) {
    warn "[DISPATCHER] Retries left: $retries\n" if DEBUG;
    return $self->_send_pdu($pdu, $retries);
  }
  else {
    warn "[DISPATCHER] No response from remote host @{[ $pdu->hostname ]}\n" if DEBUG;
    $pdu->status_information(q{No response from remote host "%s"}, $pdu->hostname);
    return;
  }
}

sub _transport_response_received {
  my ($self, $transport) = @_;
  my $mp = $self->message_processing;
  my ($msg, $error) = Net::SNMP::Message->new(-transport => $transport);

  $self->error(undef);

  if (not defined $msg) {
    die sprintf 'Failed to create Message object: %s', $error;
  }
  if (not defined $msg->recv) {
    $self->error($msg->error);
    $self->deregister($transport) unless $transport->connectionless;
    return;
  }
  if (not $msg->length) {
    warn "[DISPATCHER] Ignoring zero length message\n" if DEBUG;
    return;
  }
  if (not $mp->prepare_data_elements($msg)) {
    $self->error($mp->error);
    return;
  }
  if ($mp->error) {
    $msg->error($mp->error);
  }

  warn "[DISPATCHER] Processing pdu\n" if DEBUG;
  $self->ioloop->remove($msg->timeout_id);
  $self->deregister($transport);
  $msg->process_response_pdu;
}

=head1 COPYRIGHT & LICENSE

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

=head1 AUTHOR

Jan Henning Thorsen - C<jhthorsen@cpan.org>

=cut

1;