File Coverage

blib/lib/Net/NBName.pm

Criterion	Covered	Total	%
statement	18	116	15.5
branch	0	22	0.0
condition	0	10	0.0
subroutine	6	14	42.8
pod	3	3	100.0
total	27	165	16.3

use strict;
use warnings;

package Net::NBName;

use Net::NBName::NodeStatus;
use Net::NBName::NameQuery;

use vars '$VERSION';
$VERSION = "0.26";

sub new
{
    my $class = shift;

    my $self = {};
    bless $self, $class;
    return $self;
}

sub node_status
{
    my $self = shift;
    my $host = shift;
    my $timeout = shift;

    my $req = Net::NBName::Request->new;
    $req->data(0, "*", "\x00", 0, 0x21);
    my $resp = $req->unicast($host, $timeout);
    if ($resp) {
        my $ns = Net::NBName::NodeStatus->new($resp);
        return $ns;
    } else {
        return undef;
    }
}

sub name_query
{
    my $self = shift;
    my $host = shift;
    my $name = shift;
    my $suffix = shift;
    my $flags = shift || 0x0100;
    my $timeout = shift;

    my $req = Net::NBName::Request->new;
    $req->data($flags, $name, ' ', $suffix, 0x20);
    my ($resp, $from_ip);
    if (defined($host)) {
        $resp = $req->unicast($host, $timeout);
    } else {
        ($resp, $from_ip) = $req->broadcast($timeout);
    }

    if ($resp) {
        my $nq = Net::NBName::NameQuery->new($resp);
        return $nq;
    } else {
        return undef;
    }
}

package Net::NBName::Request;

use Socket;

sub new
{
    my $class = shift;

    my $self = {};
    bless $self, $class;
    return $self;
}

sub data
{
    my $self = shift;
    my ($flags, $name, $pad, $suffix, $qtype) = @_;

    my $data = "";
    $data .= pack("n*", $$, $flags, 1, 0, 0, 0);
    $data .= _encode_name($name, $pad, $suffix);
    $data .= pack("n*", $qtype, 0x0001);

    $self->{data} = $data;
}

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 unicast
{
    my $self = shift;
    my $host = shift;
    # Timeout should be 250ms according to RFC1002
    my $timeout = shift || 0.25;

    my $data = $self->{data};

    my $protocol = getprotobyname('udp');
    my $port = 137;
    socket(SOCK, AF_INET, SOCK_DGRAM, $protocol) or return undef;
    my $to_saddr = sockaddr_in($port, inet_aton($host));

    send(SOCK, $data, 0, $to_saddr) or return undef;

    my $rin = "";
    my $rout;
    vec($rin, fileno(SOCK), 1) = 1;

    my ($nfound, $timeleft) = select($rout = $rin, undef, undef, $timeout);
    if ($nfound) {
        my $resp;
        if (my $from_saddr = recv(SOCK, $resp, 2000, 0)) {
            my ($from_port, $from_ip) = sockaddr_in($from_saddr);
            close(SOCKET);
            return $resp;
        } else { # socket error
            #printf "Errno %d %s\n", $!, $^E;
            close(SOCKET);
            return undef;
        }
    } else { # timed out
        close(SOCKET);
        return undef;
    }
}

sub broadcast
{
    my $self = shift;
    # Timeout should be 5s according to rfc1002 (but I've used 1s)
    my $timeout = shift || 1;

    my $host = "255.255.255.255";
    my $data = $self->{data};

    my $protocol = getprotobyname('udp');
    my $port = 137;
    socket(SOCK, AF_INET, SOCK_DGRAM, $protocol) or return undef;
    setsockopt(SOCK, SOL_SOCKET, SO_BROADCAST, 1);

    my $to_saddr = sockaddr_in($port, inet_aton($host));

    send(SOCK, $data, 0, $to_saddr) or return undef;
    my $rin = "";
    my $rout;
    vec($rin, fileno(SOCK), 1) = 1;

    my ($nfound, $timeleft) = select($rout = $rin, undef, undef, $timeout);
    if ($nfound) {
        my $resp;
        if (my $from_saddr = recv(SOCK, $resp, 2000, 0)) {
            my ($from_port, $from_ip) = sockaddr_in($from_saddr);
            close(SOCKET);
            return $resp, inet_ntoa($from_ip);
        } else { # socket error
            #printf "Errno %d %s\n", $!, $^E;
            close(SOCKET);
            return undef;
        }
    } else { # timed out
        close(SOCKET);
        return undef;
    }
}

1;

__END__