File Coverage

blib/lib/IO/Socket/Multicast.pm

Criterion	Covered	Total	%
statement	47	78	60.2
branch	3	32	9.3
condition	2	17	11.7
subroutine	15	19	78.9
pod	6	8	75.0
total	73	154	47.4

package IO::Socket::Multicast;

use 5.005;
use strict;
use Carp 'croak';
use Exporter   ();
use DynaLoader ();
use IO::Socket;
BEGIN {
  eval "use IO::Interface 0.94 'IFF_MULTICAST';";
}
use vars qw(@ISA @EXPORT_OK @EXPORT %EXPORT_TAGS $VERSION);
BEGIN {
  my @functions = qw(
    mcast_add
    mcast_drop
    mcast_if
    mcast_loopback
    mcast_ttl
    mcast_dest
    mcast_send
  );
  $VERSION = '1.12';
  @ISA = qw(
    Exporter
    DynaLoader
    IO::Socket::INET
  );
  @EXPORT = ( );
  %EXPORT_TAGS = (
    'all'       => \@functions,
    'functions' => \@functions,
  );
  @EXPORT_OK = @{ $EXPORT_TAGS{'all'} };
}

my $IP = '\d+\.\d+\.\d+\.\d+';

sub import {
  Socket->export_to_level(1,@_);
  IO::Socket::Multicast->export_to_level(1,@_);
}

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

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

sub mcast_add {
  my $sock = shift;
  my $group = shift || croak 'usage: $sock->mcast_add($mcast_addr [,$interface])';
  $group = inet_ntoa($group) unless $group =~ /^$IP$/o;
  my $interface = get_if_addr($sock,shift);
  return $sock->_mcast_add($group,$interface);
}

sub mcast_drop {
  my $sock = shift;
  my $group = shift || croak 'usage: $sock->mcast_add($mcast_addr [,$interface])';
  $group = inet_ntoa($group) unless $group =~ /^$IP$/o;
  my $interface = get_if_addr($sock,shift);
  return $sock->_mcast_drop($group,$interface);
}

sub mcast_if {
  my $sock = shift;

  my $previous = $sock->_mcast_if;
  $previous = $sock->addr_to_interface($previous)
    if $sock->can('addr_to_interface');
  return $previous unless @_;

  my $interface = get_if_addr($sock,shift);
  return $sock->_mcast_if($interface) ? $previous : undef;
}

sub get_if_addr {
  my $sock = shift;
  return '0.0.0.0' unless defined (my $interface = shift);
  return $interface if $interface =~ /^$IP$/;
  return $interface if length $interface == 16;
  croak "IO::Interface module not available; use IP addr for interface"
    unless $sock->can('if_addr');
  croak "unknown or unconfigured interace $interface"
    unless my $addr = $sock->if_addr($interface);
  croak "interface is not multicast capable"
    unless $interface eq 'any' or ($sock->if_flags($interface) & IFF_MULTICAST());
  return $addr;
}

sub mcast_dest {
  my $sock = shift;
  my $prev = ${*$sock}{'io_socket_mcast_dest'};
  if (my $dest = shift) {
    $dest = sockaddr_in($2,inet_aton($1)) if $dest =~ /^($IP):(\d+)$/;
    croak "invalid destination address" unless length($dest) == 16;
    ${*$sock}{'io_socket_mcast_dest'} = $dest;
  }
  return $prev;
}

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

bootstrap IO::Socket::Multicast $VERSION;

1;

__END__