#!/usr/local/bin/perl
use Net::UPnP::ControlPoint;
my $obj = Net::UPnP::ControlPoint->new();
my @dev_list = $obj->search();
my $nodevs = @dev_list;
print "Found $nodevs\n";

##</code><code>##

package Net::UPnP::ControlPoint;

#-----------------------------------------------------------------
# Net::UPnP::ControlPoint
#-----------------------------------------------------------------

use strict;
use warnings;

use IO::Select;
use IO::Socket::INET;

use Net::UPnP;
use Net::UPnP::HTTP;
use Net::UPnP::Device;

#------------------------------
# new
#------------------------------

sub new {
	my($class) = shift;
	my($this) = {};
	bless $this, $class;
}

#------------------------------
# search
#------------------------------

sub search {
	my($this) = shift;
	my %args = (
		st => 'upnp:rootdevice',	
		mx =>3,
		@_,
	);
	my(
		@dev_list,
		$ssdp_header,
		$ssdp_mcast,
		$rin,
		$rout,
		$ssdp_res_msg,
		$dev_location,
		$dev_addr,
		$dev_port,
		$dev_path,
		$dev_friendly_name,
		$http_req,
		$post_res,
		$post_content,
		$key,
		$dev,
		);
my $mcast_addr = $Net::UPnP::SSDP_ADDR . ':' . $Net::UPnP::SSDP_PORT;
		
$ssdp_header = <<"SSDP_SEARCH_MSG";
M-SEARCH * HTTP/1.1
Host: $mcast_addr
Man: "ssdp:discover"
ST: $args{st}
MX: $args{mx}

SSDP_SEARCH_MSG

	$ssdp_header =~ s/\r//g;
	$ssdp_header =~ s/\n/\r\n/g;

	my $sock = IO::Socket::INET->new(
		LocalPort => $Net::UPnP::SSDP_PORT,
		Proto     => 'udp',
	) or die "Cannot create socket to send multicast $@\n";
	
	# add the socket to the correct IGMP multicast group
	_mcast_add( $sock, $mcast_addr );
	
	# send the search query
	_mcast_send( $sock, $ssdp_header, $mcast_addr );
 
	my $sel = IO::Select->new($sock);

	@dev_list = ();
	
	while ( $sel->can_read( $args{mx} ) ) {
		recv ($sock, $ssdp_res_msg, 4096, 0);
		print "$ssdp_res_msg";
		unless ($ssdp_res_msg =~ m/LOCATION[ :]+(.*)\r/i) {
			next;
		}		
		$dev_location = $1;
		unless ($dev_location =~ m/http:\/\/([0-9a-z.]+)[:]*([0-9]*)\/(.*)/i) {
			next;
		}
		$dev_addr = $1;
		$dev_port = $2;
		$dev_path = '/' . $3;
	
		$http_req = Net::UPnP::HTTP->new();
		$post_res = $http_req->post($dev_addr, $dev_port, "GET", $dev_path, "", "");

		if ($Net::UPnP::DEBUG) {
			print $post_res->getstatus() . "\n";
			print $post_res->getheader() . "\n";
			print $post_res->getcontent() . "\n";
		}

 		$post_content = $post_res->getcontent();

		$dev = Net::UPnP::Device->new();
 		$dev->setssdp($ssdp_res_msg);
		$dev->setdescription($post_content);
	
		if ($Net::UPnP::DEBUG) {
	 		print "friendlyName = $dev_friendly_name\n";
	 		print "ssdp = $ssdp_res_msg\n";
	 		print "description = $post_content\n";
	 	}

		push(@dev_list, $dev);
	}

	close $sock;
	
	@dev_list;
}

sub _mcast_add {
	my ( $sock, $host ) = @_;
	my ( $addr, $port ) = split /:/, $host;
	my $ip_mreq = inet_aton( $addr ) . INADDR_ANY;
	
	setsockopt(
		$sock,
		getprotobyname('ip') || 0,
		_constant('IP_ADD_MEMBERSHIP'),
		$ip_mreq
	) || warn "Unable to add IGMP membership: $!\n";
}

sub _mcast_send {
	my ( $sock, $msg, $host ) = @_;
	my ( $addr, $port ) = split /:/, $host;
	
	# Set a TTL of 4 as per UPnP spec
	setsockopt(
		$sock,
		getprotobyname('ip') || 0,
		_constant('IP_MULTICAST_TTL'),
		pack 'I', 4,
	) || do {
		warn "Error setting multicast TTL to 4: $!\n";
		return;
	};
	
	
	my $dest_addr = sockaddr_in( $port, inet_aton( $addr ) );
	my $bytes = send( $sock, $msg, 0, $dest_addr );
	print "Sent $bytes bytes\n";
}

sub _constant {
	my $name = shift;
	my %names = (
		IP_MULTICAST_TTL  => 0,
		IP_ADD_MEMBERSHIP => 1,
		IP_MULTICAST_LOOP => 0,
	);
	
	my %constants = (
		MSWin32 => [10,12],
		cygwin  => [3,5],
		darwin  => [10,12],
		default => [33,35],
	);
	
	my $index = $names{$name};
	my $ref = $constants{ $^O } || $constants{default};
	return $ref->[ $index ];
}
1;

##</code><code>##

while ( $sel->can_read( $args{mx} ) ) {
		recv ($sock, $ssdp_res_msg, 4096, 0);
		print "$ssdp_res_msg";
                ...
}