File Coverage

blib/lib/IO/Socket/Multicast6.pm

Criterion	Covered	Total	%
statement	107	157	68.1
branch	54	122	44.2
condition	16	34	47.0
subroutine	18	20	90.0
pod	10	10	100.0
total	205	343	59.7

package IO::Socket::Multicast6;

use strict;
use vars qw(@ISA $VERSION);

use IO::Socket::INET6;
use IO::Interface::Simple;
use Socket::Multicast6 qw/ :all /;
use Socket;
use Socket6;
use Carp 'croak';



@ISA = qw(IO::Socket::INET6);
$VERSION = '0.03';


# Regular expressions to match IP addresses
my $IPv4 = '\d+\.\d+\.\d+\.\d+';
my $IPv6 = '[\da-fA-F:]+';


sub new {
	my $class = shift;
	unshift @_,(Proto => 'udp') unless @_;
	$class->SUPER::new(@_);
}


sub configure {
	my($self,$arg) = @_;
	$arg->{Proto} ||= 'udp';
	$arg->{ReuseAddr} ||= 1;
	$self->SUPER::configure($arg);
}


sub mcast_add {
	my $sock = shift;
	my $group = shift || croak 'usage: $sock->mcast_add($mcast_addr [,$interface])';
	my $interface = shift;

	if ($sock->sockdomain() == AF_INET) {
		my $if_addr = _get_if_ipv4addr($interface);
		my $ip_mreq = pack_ip_mreq( inet_pton( AF_INET, $group ),
									inet_pton( AF_INET, $if_addr ) );

		setsockopt($sock, IPPROTO_IP, IP_ADD_MEMBERSHIP, $ip_mreq )
		or croak "Could not set IP_ADD_MEMBERSHIP socket option: $!";
	} elsif ($sock->sockdomain() == AF_INET6) {
		my $if_index = _get_if_index($interface);
		my $ipv6_mreq = pack_ipv6_mreq( inet_pton( AF_INET6, $group ),
										$if_index );

		setsockopt($sock, IPPROTO_IPV6, IPV6_JOIN_GROUP, $ipv6_mreq )
		or croak "Could not set IPV6_JOIN_GROUP socket option: $!";
	} else {
		croak("mcast_add failed, unsupported socket family." );
	}

	# Success
	return 1;
}

sub mcast_add_source {
	my $sock = shift;
	my $group = shift || croak 'usage: $sock->mcast_add_source($mcast_addr, $source_addr [,$interface])';
	my $source = shift || croak 'usage: $sock->mcast_add_source($mcast_addr, $source_addr [,$interface])';
	my $interface = shift;

	if ($sock->sockdomain() == AF_INET) {
		my $if_addr = _get_if_ipv4addr($interface);
		my $ip_mreq = pack_ip_mreq_source(
						inet_pton( AF_INET, $group ),
						inet_pton( AF_INET, $source ),
						inet_pton( AF_INET, $if_addr ) );

		setsockopt($sock, IPPROTO_IP, IP_ADD_SOURCE_MEMBERSHIP, $ip_mreq )
		or croak "Could not set IP_ADD_SOURCE_MEMBERSHIP socket option: $!";
	} elsif ($sock->sockdomain() == AF_INET6) {
		croak("mcast_add_source failed, IPv6 is currently unsupported." );
	} else {
		croak("mcast_add_source failed, unsupported socket family." );
	}

	# Success
	return 1;
}


sub mcast_drop {
	my $sock = shift;
	my $group = shift || croak 'usage: $sock->mcast_drop($mcast_addr [,$interface])';
	my $interface = shift;

	if ($sock->sockdomain() == AF_INET) {
		my $if_addr = _get_if_ipv4addr($interface);
		my $ip_mreq = pack_ip_mreq( inet_pton( AF_INET, $group ),
									inet_pton( AF_INET, $if_addr ) );

		setsockopt($sock, IPPROTO_IP, IP_DROP_MEMBERSHIP, $ip_mreq )
		or croak "Could not set IP_ADD_MEMBERSHIP socket option: $!";
	} elsif ($sock->sockdomain() == AF_INET6) {
		my $if_index = _get_if_index($interface);
		my $ipv6_mreq = pack_ipv6_mreq( inet_pton( AF_INET6, $group ),
										$if_index );

		setsockopt($sock, IPPROTO_IPV6, IPV6_LEAVE_GROUP, $ipv6_mreq )
		or croak "Could not set IPV6_LEAVE_GROUP socket option: $!";
	} else {
		croak("mcast_add failed, unsupported socket family." );
	}

	# Success
	return 1;
}


sub mcast_ttl {
	my $sock = shift;

	my $prev = undef;
	if ($sock->sockdomain() == AF_INET) {
		my $packed = getsockopt($sock, IPPROTO_IP, IP_MULTICAST_TTL)
		or croak "Could not get IP_MULTICAST_TTL socket option: $!";
		$prev=unpack("I", $packed);
		if (my $ttl = shift) {
			setsockopt($sock, IPPROTO_IP, IP_MULTICAST_TTL, pack("I", $ttl ) )
			or croak "Could not set IP_MULTICAST_TTL socket option: $!";
		}
	} elsif ($sock->sockdomain() == AF_INET6) {
		my $packed = getsockopt($sock, IPPROTO_IPV6, IPV6_MULTICAST_HOPS)
		or croak "Could not get IPV6_MULTICAST_HOPS socket option: $!";
		$prev=unpack("I", $packed);
		if (my $ttl = shift) {
			setsockopt($sock, IPPROTO_IPV6, IPV6_MULTICAST_HOPS, pack("I", $ttl ) )
			or croak "Could not set IPV6_MULTICAST_HOPS socket option: $!";
		}
	} else {
		croak("mcast_ttl failed, unsupported socket family." );
	}

	return $prev;
}


sub mcast_loopback {
	my $sock = shift;

	my $prev = undef;
	if ($sock->sockdomain() == AF_INET) {
		my $packed = getsockopt($sock, IPPROTO_IP, IP_MULTICAST_LOOP)
		or croak "Could not get IP_MULTICAST_LOOP socket option: $!";
		$prev=unpack("I", $packed);
		if (my $loopback = shift) {
			setsockopt($sock, IPPROTO_IP, IP_MULTICAST_LOOP, pack("I", $loopback ) )
			or croak "Could not set IP_MULTICAST_LOOP socket option: $!";
		}
	} elsif ($sock->sockdomain() == AF_INET6) {
		my $packed = getsockopt($sock, IPPROTO_IPV6, IPV6_MULTICAST_LOOP)
		or croak "Could not get IPV6_MULTICAST_LOOP socket option: $!";
		$prev=unpack("I", $packed);

		if (my $loopback = shift) {
			setsockopt($sock, IPPROTO_IPV6, IPV6_MULTICAST_LOOP, pack("I", $loopback ) )
			or croak "Could not set IPV6_MULTICAST_LOOP socket option: $!";
		}
	} else {
		croak("mcast_loopback failed, unsupported socket family." );
	}

	return $prev;
}


sub mcast_if {
	my $sock = shift;

	my $prev = undef;
	if ($sock->sockdomain() == AF_INET) {
		my $packed = getsockopt($sock, IPPROTO_IP, IP_MULTICAST_IF)
		or croak "Could not get IP_MULTICAST_IF socket option: $!";
		$prev=$sock->addr_to_interface( inet_ntop( AF_INET, $packed ) );

		if (my $interface = shift) {
			my $if_addr = _get_if_ipv4addr($interface);
			setsockopt($sock, IPPROTO_IP, IP_MULTICAST_IF, inet_pton( AF_INET, $if_addr ) )
			or croak "Could not set IP_MULTICAST_IF socket option: $!";
		}
	} elsif ($sock->sockdomain() == AF_INET6) {
		my $packed = getsockopt($sock, IPPROTO_IPV6, IPV6_MULTICAST_IF)
		or croak "Could not get IPV6_MULTICAST_IF socket option: $!";
		$prev = unpack("I", $packed);
		if ($prev==0) { $prev='any'; }
		else { $prev = $sock->if_indextoname($prev); }

		if (my $interface = shift) {
			my $if_index = _get_if_index($interface);
			setsockopt($sock, IPPROTO_IPV6, IPV6_MULTICAST_IF, pack("I", $if_index ) )
			or croak "Could not set IPV6_MULTICAST_IF socket option: $!";
		}
	} else {
		croak("mcast_if failed, unsupported socket family." );
	}

	return $prev;
}


sub mcast_dest {
	my $sock = shift;
	my ($addr, $port) = @_;

	my $prev = ${*$sock}{'io_socket_mcast_dest'};
	if (defined $addr) {
		if ($sock->sockdomain() == AF_INET) {
			if (!defined $port and $addr =~ /^($IPv4):(\d+)$/) {
				$addr = $1; $port = $2;
			}

			$addr = pack_sockaddr_in($port,inet_pton(AF_INET, $addr)) if (defined $port);
			croak "Invalid destination address" if (!defined $addr or length($addr)==0);
			croak "Destination isn't an IPv4 address" unless (sockaddr_family($addr)==AF_INET);

		} elsif ($sock->sockdomain() == AF_INET6) {
			if (!defined $port and $addr =~ /^\[($IPv6)\]:(\d+)$/) {
				$addr = $1; $port = $2;
			}

			$addr = pack_sockaddr_in6($port,inet_pton(AF_INET6, $addr)) if (defined $port);
			croak "Invalid destination address" if (!defined $addr or length($addr)==0);
			croak "Destination isn't an IPv6 address" unless (sockaddr_family($addr)==AF_INET6);

		} else {
			croak("mcast_dest failed, unsupported socket family." );
		}

		${*$sock}{'io_socket_mcast_dest'} = $addr;
	}

	return $prev;
}



sub mcast_send {
	my $sock = shift;
	my $data = shift || croak 'usage: $sock->mcast_send($data [,$address[,$port]])';
	$sock->mcast_dest(@_) if @_;
	my $dest = $sock->mcast_dest || croak "no destination specified with mcast_send() or mcast_dest()";

	return send($sock,$data,0,$dest);
}


## Returns the IPv4 address of an interface
#
sub _get_if_ipv4addr {
	my ($interface) = @_;

	return '0.0.0.0' unless (defined $interface);
	return '0.0.0.0' if ($interface eq 'any');
	return $interface if ($interface =~ /^$IPv4$/);

	my $if = new IO::Interface::Simple( $interface );
	croak "Unknown interface $interface" unless (defined $if);
	croak "Interface '$interface' is not multicast capable" unless ($if->is_multicast());
	my $address = $if->address();
	croak "Interface '$interface' does not have an IPv4 address" unless (defined $address);
	return $address;
}


## Returns the index of an interface
#
sub _get_if_index {
	my ($interface) = @_;

	return 0 unless defined $interface;
	return $interface if ($interface =~ /^\d+$/);
	return 0 if ($interface =~ /^any$/i);

	my $if = new IO::Interface::Simple( $interface );
	croak "Unknown interface $interface" unless (defined $if);
	croak "Interface '$interface' is not multicast capable" unless ($if->is_multicast());
	my $index = $if->index();
	croak "Can't get index of interface '$interface'." unless (defined $index);
	return $index;
}


1;
__END__