File Coverage

blib/lib/Net/Dropbear/SSHd.pm

Criterion	Covered	Total	%
statement	45	60	75.0
branch	3	10	30.0
condition	1	3	33.3
subroutine	14	16	87.5
pod	4	5	80.0
total	67	94	71.2

package Net::Dropbear::SSHd;

use strict;
use v5.8;
our $VERSION = '0.04';

use Child;

use autodie;
use Carp;
use Moo;
use Types::Standard qw/ArrayRef HashRef GlobRef Str Int Bool InstanceOf/;

has addrs => (
  is => 'rw',
  isa => ArrayRef[Str],
  coerce => sub { ref $_[0] ? $_[0] : [ $_[0] ] },
);

has keys => (
  is => 'rw',
  isa => ArrayRef[Str],
  coerce => sub {
    my $value = shift;
    $value = ref $value ? $value : [ $value ];
    foreach my $key ( @$value )
    {
      carp "Key file does not exist: $key"
        if !-e $key;
    }
    return $value;
  },
);

has hooks => (
  is => 'ro',
  isa => HashRef,
  default => sub { {} },
);

has debug          => ( is => "rw", isa => Bool, default => 0, );
has forkbg         => ( is => "rw", isa => Bool, default => 0, );
has usingsyslog    => ( is => "rw", isa => Bool, default => 0, );
has inetdmode      => ( is => "rw", isa => Bool, default => 0, );
has norootlogin    => ( is => "rw", isa => Bool, default => 1, );
has noauthpass     => ( is => "rw", isa => Bool, default => 1, );
has norootpass     => ( is => "rw", isa => Bool, default => 1, );
has allowblankpass => ( is => "rw", isa => Bool, default => 0, );
has delay_hostkey  => ( is => "rw", isa => Bool, default => 0, );
has domotd         => ( is => "rw", isa => Bool, default => 0, );
has noremotetcp    => ( is => "rw", isa => Bool, default => 1, );
has nolocaltcp     => ( is => "rw", isa => Bool, default => 1, );

has child => (
  is => 'rwp',
  isa => InstanceOf['Child::Link::Proc'],
);

has comm => (
  is => 'rwp',
  isa => GlobRef,
);

sub is_running
{
  my $self = shift;
  return defined $self->child;
}

sub run
{
  my $self = shift;
  my $child_hook = shift;

  if (defined $child_hook && ref $child_hook ne 'CODE')
  {
    croak '$child_hook was not a code ref when calling run';
  }

  use Socket;
  use IO::Handle;
  socketpair(my $child_comm, my $parent_comm, AF_UNIX, SOCK_STREAM, PF_UNSPEC);

  my $child = Child->new(sub {
    my $parent = shift;
    $0 .= " [Net::Dropbear Child]";

    $parent_comm->close;
    $self->_set_comm($child_comm);

    require Net::Dropbear::XS;

    Net::Dropbear::XS->setup_svr_opts($self);

    $child_hook->($parent)
      if defined $child_hook;

    Net::Dropbear::XS->svr_main();

    # Should never return
    croak 'Unexpected return from dropbear';
  });

  $self->_set_child($child->start);
  $child_comm->close;
  $self->_set_comm($parent_comm);

  return;
}

sub stop
{
  my $self = shift;
  if ($self->is_running)
  {
    $self->child->kill(15);
  }
}

sub wait
{
  my $self = shift;
  if ($self->is_running)
  {
    $self->child->wait;
  }
}

sub auto_hook
{
  my $self = shift;
  my $hook = shift;

  if (exists $self->hooks->{$hook})
  {
    return $self->hooks->{$hook}->(@_);
  }

  return Net::Dropbear::XS::HOOK_CONTINUE();
}

sub import
{
  require Net::Dropbear::XS;
  Net::Dropbear::XS->export_to_level(1, @_);
}

1;
__END__