UPnP/DLNA multicast relay server

ssdp-relay.pl

#!/usr/bin/perl
################################################################################
# DLNA multicast relay			(C)2015/11/13 nabe@abk / GPLv2 or later
################################################################################
use strict;
use Socket;
use IO::Select;
use IO::Interface::Simple;
use IO::Socket::Multicast;

my $DLNA_only = 1;
my $CAST = '239.255.255.250';
my $PORT = 1900;
my $DUMP  = $ARGV[0] eq '-dump';
my $DEBUG = $DUMP || $ARGV[0] eq '-d' ||  $ARGV[0] eq '-debug';

################################################################################
# Create Server socks
################################################################################
my @ifs;
my %if_addr;
my %if_name;
#-----------------------------------------------------
# multicast server
#-----------------------------------------------------
my $m_sock = IO::Socket::Multicast->new (
	Proto    => 'udp', 
	LocalAddr => $CAST,
	LocalPort => $PORT,
	ReuseAddr => 1
) or die;
$m_sock->mcast_loopback(0);
$m_sock->mcast_dest("$CAST:$PORT");

foreach (IO::Interface::Simple->interfaces) {
	if (!$_->is_multicast) { next; }

	my $addr = $_->address;
	my $name = $_->name;
	my $mask = $_->netmask;
	my %h = (
		addr => $addr,
		name => $name,
		mask => $mask
	);
	push(@ifs, \%h);
	$if_addr{$addr} = \%h;
	$if_name{$name} = \%h;

	$m_sock->mcast_add($CAST, $addr);
	$DEBUG and print "bind : $addr/$mask ($name)\n";
}

#-----------------------------------------------------
# unicast
#-----------------------------------------------------
my $u_sock;
socket($u_sock, AF_INET, SOCK_DGRAM, 0);
setsockopt($u_sock, SOL_SOCKET, SO_REUSEADDR, 1);
bind($u_sock, pack_sockaddr_in( $PORT, INADDR_ANY ));

################################################################################
# $m_sock and $u_sock recieved multicast packet.
# $u_sock only recieved unicast packet.
################################################################################
# main loop
################################################################################
my $sel = IO::Select->new();
$sel->add($m_sock);
$sel->add($u_sock);

while(my @ready = $sel->can_read) {
	foreach my $sock (@ready) {
		my $msg;
		my $_addr = recv($sock, $msg, 4096, 0);
		my($s_port, $s_addr) = unpack_sockaddr_in($_addr);
		$s_addr = inet_ntoa($s_addr);

		# ignore m_sock packets (u_sock received  same packet).
		if ($sock eq $m_sock) { next; }

		# ignore local send packets
		# if ($if_addr{$s_addr}) { next; }

		#-----------------------------------------------------
		# Analyze interface
		#-----------------------------------------------------
		my $iface;
		foreach(@ifs) {
			if (! &same_network($s_addr, $_->{addr}, $_->{mask})) { next; }
			$iface = $_;
		}
		if (!$iface) { next; }	# unbind interface

		#-----------------------------------------------------
		# M-SEARCH relay
		#-----------------------------------------------------
		if ($msg =~ m|^M-SEARCH \* HTTP/1\.1|) {
			$DEBUG and print "M-SEARCH from $s_addr:$s_port ($iface->{name})\n";
			$DUMP  and print $msg,"\n";
			foreach(@ifs) {
				if ($_ eq $iface) { next; }
				$m_sock->mcast_if( $_->{name} );
				$m_sock->mcast_send($msg);
				$_->{s_addr} = $s_addr;
				$_->{s_port} = $s_port;
			}
			next;
		}

		#-----------------------------------------------------
		# Unicast replay relay
		#-----------------------------------------------------
		if ($msg =~ m|^HTTP/1.1 200 OK|) {
			my $addr = $iface->{s_addr};
			my $port = $iface->{s_port};
			if (!$addr || !$port) { next; }

			$DEBUG and print "Unicast relay to $addr:$port from $s_addr:$s_port ($iface->{name})\n";
			send($u_sock, $msg, 0, pack_sockaddr_in($port, inet_aton($addr)));
			$DUMP  and print $msg,"\n";
			next;
		}

		if ($DEBUG) {
			$DEBUG and print "Unknown packet from $s_addr:$s_port ($iface->{name})\n";
			$DUMP  and print $msg,"\n";
		}
	}
}
exit(0);

################################################################################
# network check
################################################################################
sub same_network {
	my @a    = split(/\./, shift);
	my @b    = split(/\./, shift);
	my @mask = split(/\./, shift);
	foreach(@mask) {
		my $a = shift(@a) & $_;
		my $b = shift(@b) & $_;
		if ($a != $b) { return 0; }
	}
	return 1;
}

How to use this script?