#!/usr/local/bin/perl
use Socket;

$debug = 0;
my $ip = '255.255.255.255';
#my $ip = '192.168.0.1';
my @nwg, @wan, @lan, $name;

&nwg_open($ip, \@nwg);
&nwg_search(\@nwg, \@wan, \@lan, \$name);
&nwg_close(\@nwg);

printf("WAN %s %s %s\n", $wan[0], $wan[1], $wan[3]);
printf("LAN %s %s %s\n", $lan[0], $lan[1], $lan[3]);
printf("NAME \"%s\"\n", $name);

exit 0;

sub nwg_open
{
	my $ipaddr = inet_aton($_[0]);
	my $r_nwg = $_[1];
	my $port = 69;
	my $that = sockaddr_in($port, $ipaddr) || &error("sockaddr_in:$!");
	my $proto = getprotobyname('udp');

	socket(S, AF_INET, SOCK_DGRAM, $proto) || &error("socket:$!");
	binmode S;
	setsockopt(S,SOL_SOCKET,SO_BROADCAST,1);

	$$r_nwg[0] = S;
	$$r_nwg[1] = $that;

	return 0;
}

sub nwg_close
{
	my @nwg = @{$_[0]};

	close($nwg[0]) || &error("close:$!");

	return 0;
}

sub nwg_search
{
	my ($r_nwg, $r_wan, $r_lan, $r_name) = @_;
	my $packet = "\x00\x01" . "search///" . "\x00" . "octet" . "\x00";
	my @wan = ('0.0.0.0', '0.0.0.0', '00:00:00:00:00:00', '00:00:00:00:00:00');
	my @lan = ('0.0.0.0', '0.0.0.0', '00:00:00:00:00:00', '00:00:00:00:00:00');
	my $name;

	&nwg_send($r_nwg, $packet);
	#$dat = &nwg_recv($r_nwg, 0x62);
	$dat = &nwg_recv($r_nwg, 256);

	if( substr($dat, 0x04, 2) eq "\x00\x00" ) {
		$lan[0] = sprintf("%d.%d.%d.%d", unpack("xxxCXXCXXCXXC", substr($dat, 0x2E, 4)));
		$lan[1] = sprintf("%d.%d.%d.%d", unpack("xxxCXXCXXCXXC", substr($dat, 0x32, 4)));
		$lan[2] = sprintf("%02X:%02X:%02X:%02X:%02X:%02X", unpack("C6", substr($dat, 0x36, 6)));
		$lan[3] = sprintf("%02X:%02X:%02X:%02X:%02X:%02X", unpack("C6", substr($dat, 0x3C, 6)));
		$wan[0] = sprintf("%d.%d.%d.%d", unpack("xxxCXXCXXCXXC", substr($dat, 0x42, 4)));
		$wan[1] = sprintf("%d.%d.%d.%d", unpack("xxxCXXCXXCXXC", substr($dat, 0x46, 4)));
		$wan[2] = sprintf("%02X:%02X:%02X:%02X:%02X:%02X", unpack("C6", substr($dat, 0x4A, 6)));
		$wan[3] = sprintf("%02X:%02X:%02X:%02X:%02X:%02X", unpack("C6", substr($dat, 0x50, 6)));
		$name = unpack("A*", substr($dat, 0x0C, 32));
	}

	@$r_wan = @wan;
	@$r_lan = @lan;
	$$r_name = $name;

	return 0;
}

sub nwg_send
{
	my @nwg = @{$_[0]};
	my $packet = $_[1];

	send($nwg[0], $packet, 0, $nwg[1]) || &error("send:$!");
	print "send\n" . &dump($packet) . "\n"  if($debug);

	return 0;
}

sub nwg_recv
{
	my @nwg = @{$_[0]};
	my $size = $_[1];
	my $data;

	recv($nwg[0], $data, $size, 0) || &error("recv:$!");
	print "recv\n" . &dump($data) . "\n"  if($debug);

	return $data;
}

sub dump
{
	my @data = unpack( "C*", $_[0] );
	my $line;
	my $i = 0;
	my $msg = '';

	foreach ( @data ) {
		if( ($i % 0x10)==0 ) {
			$msg = $msg . sprintf( "%05X : " , $i );
			$line = '';
		}
		$msg = $msg . "- "  if( ($i % 0x10) && ($i % 0x08)==0 );
		$msg = $msg . sprintf( "%02X ", $_ );
		if( $_ >= 0x20 && $_ <= 0x7E ) {
			$line = sprintf( "%s%c", $line, $_ );
		} else {
			$line = "$line.";
		}
		$i++;
		$msg = $msg . "  $line\n"  if( ($i % 0x10)==0 );
	}

	if( $i % 0x10 ) {
		$msg = $msg . ' 'x ( (16-($i % 0x10)) * 3);
		$msg = $msg . '  '  if( ($i % 0x10) < 9 );
		$msg = $msg . "  $line\n";
	}
	return $msg;
}

sub error
{
	print "error:$_[0]\n";
	exit 1;
}