=== lib/Net/UPnP/ControlPoint.pm
==================================================================
--- lib/Net/UPnP/ControlPoint.pm (revision 44776)
+++ lib/Net/UPnP/ControlPoint.pm (local)
@@ -7,7 +7,8 @@
use strict;
use warnings;
-use Socket;
+use IO::Select;
+use IO::Socket::INET;
use Net::UPnP;
use Net::UPnP::HTTP;
@@ -52,10 +53,12 @@
$key,
$dev,
);
+
+ my $mcast_addr = $Net::UPnP::SSDP_ADDR . ':' . $Net::UPnP::SSDP_PORT;
$ssdp_header = <<"SSDP_SEARCH_MSG";
M-SEARCH * HTTP/1.1
-Host: $Net::UPnP::SSDP_ADDR:$Net::UPnP::SSDP_PORT
+Host: $mcast_addr
Man: "ssdp:discover"
ST: $args{st}
MX: $args{mx}
@@ -64,22 +67,28 @@
$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',
+ );
+
+ # 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 );
- socket(SSDP_SOCK, AF_INET, SOCK_DGRAM, getprotobyname('udp'));
- $ssdp_mcast = sockaddr_in($Net::UPnP::SSDP_PORT, inet_aton($Net::UPnP::SSDP_ADDR));
-
- send(SSDP_SOCK, $ssdp_header, 0, $ssdp_mcast);
-
if ($Net::UPnP::DEBUG) {
print "$ssdp_header\n";
- }
+ }
+
+ my $sel = IO::Select->new($sock);
@dev_list = ();
- $rin = '';
- vec($rin, fileno(SSDP_SOCK), 1) = 1;
- while( select($rout = $rin, undef, undef, ($args{mx} * 2)) ) {
- recv(SSDP_SOCK, $ssdp_res_msg, 4096, 0);
+ while ( $sel->can_read( $args{mx} ) ) {
+ recv $sock, $ssdp_res_msg, 4096, 0;
print "$ssdp_res_msg" if ($Net::UPnP::DEBUG);
@@ -119,11 +128,68 @@
}
- close(SSDP_SOCK);
+ 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 ) );
+ send( $sock, $msg, 0, $dest_addr );
+}
+
+sub _constant {
+ my $name = shift;
+
+ my %names = (
+ IP_MULTICAST_TTL => 0,
+ IP_ADD_MEMBERSHIP => 1,
+ );
+
+ 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;
__END__
