Multicast.xs

#ifdef WIN32
#include <winsock2.h>
#include <ws2tcpip.h>
#endif
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "config.h"

#include <stdio.h>
#include <errno.h>
#ifndef WIN32
#include <netinet/in.h>
#endif
#include <sys/socket.h>

#ifdef PerlIO
typedef PerlIO * InputStream;
#else
#define PERLIO_IS_STDIO 1
typedef FILE * InputStream;
#define PerlIO_fileno(f) fileno(f)
#endif

static int
not_here(char *s)
{
    croak("%s not implemented on this architecture", s);
    return -1;
}

/* Recent versions of Win32 platforms are confused about these constants due to 
 problems in the order of socket header file importation 

#ifdef WIN32
#if (PERL_REVISION >=5) && (PERL_VERSION >= 8) && (PERL_SUBVERSION >= 6)
#undef  IP_OPTIONS
#undef  IP_HDRINCL
#undef  IP_TOS
#undef  IP_TTL
#undef  IP_MULTICAST_IF
#undef  IP_MULTICAST_TTL
#undef  IP_MULTICAST_LOOP
#undef  IP_ADD_MEMBERSHIP
#undef  IP_DROP_MEMBERSHIP
#undef  IP_DONTFRAGMENT

#define IP_OPTIONS          1 
#define IP_HDRINCL          2
#define IP_TOS              3
#define IP_TTL              4
#define IP_MULTICAST_IF     9 
#define IP_MULTICAST_TTL   10
#define IP_MULTICAST_LOOP  11
#define IP_ADD_MEMBERSHIP  12
#define IP_DROP_MEMBERSHIP 13
#define IP_DONTFRAGMENT    14
#endif
#endif

*/

#ifndef HAS_INET_ATON
static int
my_inet_aton(register const char *cp, struct in_addr *addr)
{
	dTHX;
	register U32 val;
	register int base;
	register char c;
	int nparts;
	const char *s;
	unsigned int parts[4];
	register unsigned int *pp = parts;

       if (!cp || !*cp)
		return 0;
	for (;;) {
		/*
		 * Collect number up to ``.''.
		 * Values are specified as for C:
		 * 0x=hex, 0=octal, other=decimal.
		 */
		val = 0; base = 10;
		if (*cp == '0') {
			if (*++cp == 'x' || *cp == 'X')
				base = 16, cp++;
			else
				base = 8;
		}
		while ((c = *cp) != '\0') {
			if (isDIGIT(c)) {
				val = (val * base) + (c - '0');
				cp++;
				continue;
			}
			if (base == 16 && (s=strchr(PL_hexdigit,c))) {
				val = (val << 4) +
					((s - PL_hexdigit) & 15);
				cp++;
				continue;
			}
			break;
		}
		if (*cp == '.') {
			/*
			 * Internet format:
			 *	a.b.c.d
			 *	a.b.c	(with c treated as 16-bits)
			 *	a.b	(with b treated as 24 bits)
			 */
			if (pp >= parts + 3 || val > 0xff)
				return 0;
			*pp++ = val, cp++;
		} else
			break;
	}
	/*
	 * Check for trailing characters.
	 */
	if (*cp && !isSPACE(*cp))
		return 0;
	/*
	 * Concoct the address according to
	 * the number of parts specified.
	 */
	nparts = pp - parts + 1;	/* force to an int for switch() */
	switch (nparts) {

	case 1:				/* a -- 32 bits */
		break;

	case 2:				/* a.b -- 8.24 bits */
		if (val > 0xffffff)
			return 0;
		val |= parts[0] << 24;
		break;

	case 3:				/* a.b.c -- 8.8.16 bits */
		if (val > 0xffff)
			return 0;
		val |= (parts[0] << 24) | (parts[1] << 16);
		break;

	case 4:				/* a.b.c.d -- 8.8.8.8 bits */
		if (val > 0xff)
			return 0;
		val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8);
		break;
	}
	addr->s_addr = htonl(val);
	return 1;
}

#undef inet_aton
#define inet_aton my_inet_aton

#endif


MODULE = IO::Socket::Multicast	PACKAGE = IO::Socket::Multicast


void
_mcast_add(sock,mcast_group,interface_addr="")
     InputStream sock
     char* mcast_group
     char* interface_addr
     PROTOTYPE: $$;$
     PREINIT:
     int fd;
     struct ip_mreq mreq;
     PPCODE:
     {
       fd = PerlIO_fileno(sock);
       if (!inet_aton(mcast_group,&mreq.imr_multiaddr))
         croak("Invalid address used for mcast group");
       if ((strlen(interface_addr) > 0)) {
	 if (!inet_aton(interface_addr,&mreq.imr_interface))
	   croak("Invalid address used for local interface");
       } else {
	 mreq.imr_interface.s_addr = INADDR_ANY;
       }
       if (setsockopt(fd,IPPROTO_IP,IP_ADD_MEMBERSHIP,(void*) &mreq,sizeof(mreq)) < 0)
	 XSRETURN_EMPTY;
       else
	 XSRETURN_YES;
     }

void
_mcast_drop(sock,mcast_group,interface_addr="")
     InputStream sock
     char* mcast_group
     char* interface_addr
     PROTOTYPE: $$;$
     PREINIT:
     int fd;
     struct ip_mreq mreq;
     PPCODE:
     {
       fd = PerlIO_fileno(sock);
       if (!inet_aton(mcast_group,&mreq.imr_multiaddr))
         croak("Invalid address used for mcast group");
       if ((strlen(interface_addr) > 0)) {
	 if (!inet_aton(interface_addr,&mreq.imr_interface))
	   croak("Invalid address used for local interface");
       } else {
	 mreq.imr_interface.s_addr = htonl(INADDR_ANY);
       }
       if (setsockopt(fd,IPPROTO_IP,IP_DROP_MEMBERSHIP,(void*)&mreq,sizeof(mreq)) < 0)
	 XSRETURN_EMPTY;
       else
	 XSRETURN_YES;
     }

int
mcast_loopback(sock,...)
     InputStream sock
     PROTOTYPE: $;$
     PREINIT:
     int fd;
     int len;
     char previous,loopback;
     CODE:
     {
       fd = PerlIO_fileno(sock);
       /* get previous value of flag */
       len = sizeof(previous);
       if (getsockopt(fd,IPPROTO_IP,IP_MULTICAST_LOOP,(void*)&previous,&len) < 0)
	 XSRETURN_UNDEF;
       
       if (items > 1) { /* set value */
	 loopback = SvIV(ST(1));
	 if (setsockopt(fd,IPPROTO_IP,IP_MULTICAST_LOOP,(void*)&loopback,sizeof(loopback)) < 0)
	   XSRETURN_UNDEF;
       }
       RETVAL = previous;
     }
     OUTPUT:
       RETVAL

int
mcast_ttl(sock,...)
     InputStream sock
     PROTOTYPE: $;$
     PREINIT:
     int fd;
     int len;
     char previous,ttl;
     CODE:
     {
       fd = PerlIO_fileno(sock);
       /* get previous value of flag */
       len = sizeof(previous);
       if (getsockopt(fd,IPPROTO_IP,IP_MULTICAST_TTL,(void*)&previous,&len) < 0)
	 XSRETURN_UNDEF;
       
       if (items > 1) { /* set value */
	 ttl = SvIV(ST(1));
	 if (setsockopt(fd,IPPROTO_IP,IP_MULTICAST_TTL,(void*)&ttl,sizeof(ttl)) < 0)
	   XSRETURN_UNDEF;
       }
       RETVAL = previous;
     }
     OUTPUT:
       RETVAL

void
_mcast_if(sock,...)
     InputStream sock
     PROTOTYPE: $;$
     PREINIT:
     int                fd,len;
     STRLEN             slen;
     char*              addr;
     struct in_addr     ifaddr;
     struct ip_mreq     mreq;
     PPCODE:
     {
       fd = PerlIO_fileno(sock);
       if (items > 1) { /* setting interface */
	 addr = SvPV(ST(1),slen);
	 if (inet_aton(addr,&ifaddr) == 0 )
	   XSRETURN_EMPTY;
	 if (setsockopt(fd,IPPROTO_IP,IP_MULTICAST_IF,(void*)&ifaddr,sizeof(ifaddr)) == 0)
	   XSRETURN_YES;
	 else
	   XSRETURN_NO;
       } else {  /* getting interface address */

	 /* freakin' bug in Linux -- IP_MULTICAST_IF returns a struct mreqn rather than
	    an in_addr (contrary to Stevens and the setsockopt()!  
	    We work around this by looking at size of returned thing and doing a 
	    ugly cast */

	 len = sizeof(mreq);
	 if (getsockopt(fd,IPPROTO_IP,IP_MULTICAST_IF,(void*) &mreq,&len) != 0)
	   XSRETURN_EMPTY;
	 
	 if (len == sizeof(mreq)) {
	   XPUSHs(sv_2mortal(newSVpv(inet_ntoa(mreq.imr_interface),0)));
	 } else if (len == sizeof (struct in_addr)) {
	   XPUSHs(sv_2mortal(newSVpv(inet_ntoa(*(struct in_addr*)&mreq),0)));
	 } else {
	   croak("getsockopt() returned a data type I don't understand");
	 }

       }
     }