#!/usr/bin/perl -w
# H.M
# refered as follow page
# http://www.bosuke.mine.nu/neta/upnp.shtml
# http://x68000.q-e-d.net/~68user/net/udp-1.html

use strict;

use Socket;
use Errno;

my $reqtimeout = 10;

my $port = 1900;
my $mcasaddr = "239.255.255.250";
my $iaddr = inet_aton($mcasaddr);

socket(SOCKET, PF_INET, SOCK_DGRAM, 0)
        or die "can not make socket\n";

bind(SOCKET, pack_sockaddr_in($port, INADDR_ANY))
	or die "bind error\n";

my $reqdata1 = "M-SEARCH * HTTP/1.1\r\n" . "MX: 3\r\n" . "HOST: 239.255.255.250:1900\r\n" . "MAN: \"ssdp:discover\"\r\n" . "ST: urn:schemas-upnp-org:service:WANPPPConnection:1\r\n" . "\r\n";
my $reqdata2 = "M-SEARCH * HTTP/1.1\r\n" . "MX: 3\r\n" . "HOST: 239.255.255.250:1900\r\n" . "MAN: \"ssdp:discover\"\r\n" . "ST: urn:schemas-upnp-org:service:WANIPConnection:1\r\n" . "\r\n";

my $rin = &set_bits(*SOCKET);


my $sock_addr = pack_sockaddr_in($port, $iaddr);
send(SOCKET, $reqdata1, 0, $sock_addr);
send(SOCKET, $reqdata2, 0, $sock_addr);

my $rout;
select($rout=$rin, undef, undef, $reqtimeout);
if ( vec($rout, fileno(SOCKET), 1) ){
        my $buf;
        recv(SOCKET, $buf, 10000, 0);

        print $buf . "\n";

} else {
        die "Can not get respose from IGD\n";
}

sub set_bits {
    my @sockets = @_;

    my($rin)="";
    my $sock;
    foreach $sock (@sockets){
        vec($rin, fileno($sock), 1)=1;
    }
    return $rin;
}

sub to_bin {
    return unpack "B*", $_[0];
}
