view release on metacpan or  search on metacpan

lib/App/Netdisco/AnyEvent/Nbtstat.pm  view on Meta::CPAN

use AnyEvent (); BEGIN { AnyEvent::common_sense }
use AnyEvent::Util ();

sub new {
    my ( $class, %args ) = @_;

    my $interval = $args{interval};
    # This default should generate ~ 50 requests per second
    $interval = 0.2 unless defined $interval;

    my $timeout = $args{timeout};

    # Timeout should be 250ms according to RFC1002, but we're going to double
    $timeout = 0.5 unless defined $timeout;

    my $self = bless { interval => $interval, timeout => $timeout, %args },
        $class;

    Scalar::Util::weaken( my $wself = $self );

    socket my $fh4, AF_INET, Socket::SOCK_DGRAM(), 0
        or Carp::croak "Unable to create socket : $!";

    AnyEvent::Util::fh_nonblocking $fh4, 1;
    $self->{fh4} = $fh4;
    $self->{rw4} = AE::io $fh4, 0, sub {
        if ( my $peer = recv $fh4, my $resp, 2048, 0 ) {
            $wself->_on_read( $resp, $peer );
        }
    };

    # Nbtstat tasks
    $self->{_tasks} = {};

    return $self;
}

sub interval { @_ > 1 ? $_[0]->{interval} = $_[1] : $_[0]->{interval} }

sub timeout { @_ > 1 ? $_[0]->{timeout} = $_[1] : $_[0]->{timeout} }

sub nbtstat {
    my ( $self, $host, $cb ) = @_;

    my $ip   = inet_aton($host);
    my $port = 137;

    my $request = {
        host        => $host,
        results     => {},
        cb          => $cb,
        destination => scalar sockaddr_in( $port, $ip ),
    };

    $self->{_tasks}{ $request->{destination} } = $request;

    my $delay = $self->interval * scalar keys %{ $self->{_tasks} || {} };

    # There's probably a better way to throttle the sends
    # but this will work for now since we currently don't support retries
    my $w; $w = AE::timer $delay, 0, sub {
        undef $w;
        $self->_send_request($request);
    };

    return $self;
}

sub _on_read {
    my ( $self, $resp, $peer ) = @_;

    ($resp) = $resp =~ /^(.*)$/s
        if AnyEvent::TAINT && $self->{untaint};

    # Find our task
    my $request = $self->{_tasks}{$peer};

    return unless $request;

    $self->_store_result( $request, 'OK', $resp );

    return;
}

sub _store_result {
    my ( $self, $request, $status, $resp ) = @_;

    my $results = $request->{results};

    my @rr          = ();
    my $mac_address = "";

    if ( $status eq 'OK' && length($resp) > 56 ) {
        my $num_names = unpack( "C", substr( $resp, 56 ) );
        my $name_data = substr( $resp, 57 );

        for ( my $i = 0; $i < $num_names; $i++ ) {
            my $rr_data = substr( $name_data, 18 * $i, 18 );
            push @rr, _decode_rr($rr_data);
        }

        $mac_address = join "-",
            map { sprintf "%02X", $_ }
            unpack( "C*", substr( $name_data, 18 * $num_names, 6 ) );
        $results = {
            'status'      => 'OK',
            'names'       => \@rr,
            'mac_address' => $mac_address
        };
    }
    elsif ( $status eq 'OK' ) {
        $results = { 'status' => 'SHORT' };
    }
    else {
        $results = { 'status' => $status };
    }

    # Clear request specific data
    delete $request->{timer};

    # Cleanup
    delete $self->{_tasks}{ $request->{destination} };

    # Done
    $request->{cb}->($results);

    undef $request;

    return;
}

sub _send_request {
    my ( $self, $request ) = @_;

    my $msg = "";
    # We use process id as identifier field, since don't have a need to
    # unique responses beyond host / port queried 
    $msg .= pack( "n*", $$, 0, 1, 0, 0, 0 );
    $msg .= _encode_name( "*", "\x00", 0 );
    $msg .= pack( "n*", 0x21, 0x0001 );

    $request->{start} = time;

    $request->{timer} = AE::timer $self->timeout, 0, sub {
        $self->_store_result( $request, 'TIMEOUT' );
    };

    my $fh = $self->{fh4};

    send $fh, $msg, 0, $request->{destination}
        or $self->_store_result( $request, 'ERROR' );

    return;
}

sub _encode_name {
    my $name   = uc(shift);
    my $pad    = shift || "\x20";
    my $suffix = shift || 0x00;

    $name .= $pad x ( 16 - length($name) );
    substr( $name, 15, 1, chr( $suffix & 0xFF ) );

    my $encoded_name = "";
    for my $c ( unpack( "C16", $name ) ) {
        $encoded_name .= chr( ord('A') + ( ( $c & 0xF0 ) >> 4 ) );
        $encoded_name .= chr( ord('A') + ( $c & 0xF ) );
    }

    # Note that the _encode_name function doesn't add any scope,
    # nor does it calculate the length (32), it just prefixes it
    return "\x20" . $encoded_name . "\x00";
}

sub _decode_rr {
    my $rr_data = shift;

    my @nodetypes = qw/B-node P-node M-node H-node/;
    my ( $name, $suffix, $flags ) = unpack( "a15Cn", $rr_data );
    $name =~ tr/\x00-\x19/\./;    # replace ctrl chars with "."
    $name =~ s/\s+//g;

    my $rr = {};
    $rr->{'name'}   = $name;
    $rr->{'suffix'} = $suffix;
    $rr->{'G'}      = ( $flags & 2**15 ) ? "GROUP" : "UNIQUE";
    $rr->{'ONT'}    = $nodetypes[ ( $flags >> 13 ) & 3 ];
    $rr->{'DRG'}    = ( $flags & 2**12 ) ? "Deregistering" : "Registered";
    $rr->{'CNF'}    = ( $flags & 2**11 ) ? "Conflict" : "";
    $rr->{'ACT'}    = ( $flags & 2**10 ) ? "Active" : "Inactive";
    $rr->{'PRM'}    = ( $flags & 2**9 ) ? "Permanent" : "";

    return $rr;
}

1;
__END__

=head1 NAME

App::Netdisco::AnyEvent::Nbtstat - Request NetBIOS node status with AnyEvent

=head1 SYNOPSIS