1 #ifdef WIN32
2 #include <winsock2.h>
3 #include <ws2tcpip.h>
4 #endif
5 #include "EXTERN.h"
6 #include "perl.h"
7 #include "XSUB.h"
8 #include "config.h"
9
10 #include <stdio.h>
11 #include <errno.h>
12 #ifndef WIN32
13 #include <netinet/in.h>
14 #endif
15 #include <sys/socket.h>
16
17 #ifdef PerlIO
18 typedef PerlIO * InputStream;
19 #else
20 #define PERLIO_IS_STDIO 1
21 typedef FILE * InputStream;
22 #define PerlIO_fileno(f) fileno(f)
23 #endif
24
25 static int
not_here(char * s)26 not_here(char *s)
27 {
28 croak("%s not implemented on this architecture", s);
29 return -1;
30 }
31
32 /* Recent versions of Win32 platforms are confused about these constants due to
33 problems in the order of socket header file importation
34
35 #ifdef WIN32
36 #if (PERL_REVISION >=5) && (PERL_VERSION >= 8) && (PERL_SUBVERSION >= 6)
37 #undef IP_OPTIONS
38 #undef IP_HDRINCL
39 #undef IP_TOS
40 #undef IP_TTL
41 #undef IP_MULTICAST_IF
42 #undef IP_MULTICAST_TTL
43 #undef IP_MULTICAST_LOOP
44 #undef IP_ADD_MEMBERSHIP
45 #undef IP_DROP_MEMBERSHIP
46 #undef IP_DONTFRAGMENT
47
48 #define IP_OPTIONS 1
49 #define IP_HDRINCL 2
50 #define IP_TOS 3
51 #define IP_TTL 4
52 #define IP_MULTICAST_IF 9
53 #define IP_MULTICAST_TTL 10
54 #define IP_MULTICAST_LOOP 11
55 #define IP_ADD_MEMBERSHIP 12
56 #define IP_DROP_MEMBERSHIP 13
57 #define IP_DONTFRAGMENT 14
58 #endif
59 #endif
60
61 */
62
63 #ifndef HAS_INET_ATON
64 static int
my_inet_aton(register const char * cp,struct in_addr * addr)65 my_inet_aton(register const char *cp, struct in_addr *addr)
66 {
67 dTHX;
68 register U32 val;
69 register int base;
70 register char c;
71 int nparts;
72 const char *s;
73 unsigned int parts[4];
74 register unsigned int *pp = parts;
75
76 if (!cp || !*cp)
77 return 0;
78 for (;;) {
79 /*
80 * Collect number up to ``.''.
81 * Values are specified as for C:
82 * 0x=hex, 0=octal, other=decimal.
83 */
84 val = 0; base = 10;
85 if (*cp == '0') {
86 if (*++cp == 'x' || *cp == 'X')
87 base = 16, cp++;
88 else
89 base = 8;
90 }
91 while ((c = *cp) != '\0') {
92 if (isDIGIT(c)) {
93 val = (val * base) + (c - '0');
94 cp++;
95 continue;
96 }
97 if (base == 16 && (s=strchr(PL_hexdigit,c))) {
98 val = (val << 4) +
99 ((s - PL_hexdigit) & 15);
100 cp++;
101 continue;
102 }
103 break;
104 }
105 if (*cp == '.') {
106 /*
107 * Internet format:
108 * a.b.c.d
109 * a.b.c (with c treated as 16-bits)
110 * a.b (with b treated as 24 bits)
111 */
112 if (pp >= parts + 3 || val > 0xff)
113 return 0;
114 *pp++ = val, cp++;
115 } else
116 break;
117 }
118 /*
119 * Check for trailing characters.
120 */
121 if (*cp && !isSPACE(*cp))
122 return 0;
123 /*
124 * Concoct the address according to
125 * the number of parts specified.
126 */
127 nparts = pp - parts + 1; /* force to an int for switch() */
128 switch (nparts) {
129
130 case 1: /* a -- 32 bits */
131 break;
132
133 case 2: /* a.b -- 8.24 bits */
134 if (val > 0xffffff)
135 return 0;
136 val |= parts[0] << 24;
137 break;
138
139 case 3: /* a.b.c -- 8.8.16 bits */
140 if (val > 0xffff)
141 return 0;
142 val |= (parts[0] << 24) | (parts[1] << 16);
143 break;
144
145 case 4: /* a.b.c.d -- 8.8.8.8 bits */
146 if (val > 0xff)
147 return 0;
148 val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8);
149 break;
150 }
151 addr->s_addr = htonl(val);
152 return 1;
153 }
154
155 #undef inet_aton
156 #define inet_aton my_inet_aton
157
158 #endif
159
160
161 MODULE = IO::Socket::Multicast PACKAGE = IO::Socket::Multicast
162
163
164 void
165 _mcast_add(sock,mcast_group,interface_addr="")
166 InputStream sock
167 char* mcast_group
168 char* interface_addr
169 PROTOTYPE: $$;$
170 PREINIT:
171 int fd;
172 struct ip_mreq mreq;
173 PPCODE:
174 {
175 fd = PerlIO_fileno(sock);
176 if (!inet_aton(mcast_group,&mreq.imr_multiaddr))
177 croak("Invalid address used for mcast group");
178 if ((strlen(interface_addr) > 0)) {
179 if (!inet_aton(interface_addr,&mreq.imr_interface))
180 croak("Invalid address used for local interface");
181 } else {
182 mreq.imr_interface.s_addr = INADDR_ANY;
183 }
184 if (setsockopt(fd,IPPROTO_IP,IP_ADD_MEMBERSHIP,(void*) &mreq,sizeof(mreq)) < 0)
185 XSRETURN_EMPTY;
186 else
187 XSRETURN_YES;
188 }
189
190 void
191 _mcast_drop(sock,mcast_group,interface_addr="")
192 InputStream sock
193 char* mcast_group
194 char* interface_addr
195 PROTOTYPE: $$;$
196 PREINIT:
197 int fd;
198 struct ip_mreq mreq;
199 PPCODE:
200 {
201 fd = PerlIO_fileno(sock);
202 if (!inet_aton(mcast_group,&mreq.imr_multiaddr))
203 croak("Invalid address used for mcast group");
204 if ((strlen(interface_addr) > 0)) {
205 if (!inet_aton(interface_addr,&mreq.imr_interface))
206 croak("Invalid address used for local interface");
207 } else {
208 mreq.imr_interface.s_addr = htonl(INADDR_ANY);
209 }
210 if (setsockopt(fd,IPPROTO_IP,IP_DROP_MEMBERSHIP,(void*)&mreq,sizeof(mreq)) < 0)
211 XSRETURN_EMPTY;
212 else
213 XSRETURN_YES;
214 }
215
216 int
217 mcast_loopback(sock,...)
218 InputStream sock
219 PROTOTYPE: $;$
220 PREINIT:
221 int fd;
222 int len;
223 char previous,loopback;
224 CODE:
225 {
226 fd = PerlIO_fileno(sock);
227 /* get previous value of flag */
228 len = sizeof(previous);
229 if (getsockopt(fd,IPPROTO_IP,IP_MULTICAST_LOOP,(void*)&previous,&len) < 0)
230 XSRETURN_UNDEF;
231
232 if (items > 1) { /* set value */
233 loopback = SvIV(ST(1));
234 if (setsockopt(fd,IPPROTO_IP,IP_MULTICAST_LOOP,(void*)&loopback,sizeof(loopback)) < 0)
235 XSRETURN_UNDEF;
236 }
237 RETVAL = previous;
238 }
239 OUTPUT:
240 RETVAL
241
242 int
243 mcast_ttl(sock,...)
244 InputStream sock
245 PROTOTYPE: $;$
246 PREINIT:
247 int fd;
248 int len;
249 char previous,ttl;
250 CODE:
251 {
252 fd = PerlIO_fileno(sock);
253 /* get previous value of flag */
254 len = sizeof(previous);
255 if (getsockopt(fd,IPPROTO_IP,IP_MULTICAST_TTL,(void*)&previous,&len) < 0)
256 XSRETURN_UNDEF;
257
258 if (items > 1) { /* set value */
259 ttl = SvIV(ST(1));
260 if (setsockopt(fd,IPPROTO_IP,IP_MULTICAST_TTL,(void*)&ttl,sizeof(ttl)) < 0)
261 XSRETURN_UNDEF;
262 }
263 RETVAL = previous;
264 }
265 OUTPUT:
266 RETVAL
267
268 void
269 _mcast_if(sock,...)
270 InputStream sock
271 PROTOTYPE: $;$
272 PREINIT:
273 int fd,len;
274 STRLEN slen;
275 char* addr;
276 struct in_addr ifaddr;
277 struct ip_mreq mreq;
278 PPCODE:
279 {
280 fd = PerlIO_fileno(sock);
281 if (items > 1) { /* setting interface */
282 addr = SvPV(ST(1),slen);
283 if (inet_aton(addr,&ifaddr) == 0 )
284 XSRETURN_EMPTY;
285 if (setsockopt(fd,IPPROTO_IP,IP_MULTICAST_IF,(void*)&ifaddr,sizeof(ifaddr)) == 0)
286 XSRETURN_YES;
287 else
288 XSRETURN_NO;
289 } else { /* getting interface address */
290
291 /* freakin' bug in Linux -- IP_MULTICAST_IF returns a struct mreqn rather than
292 an in_addr (contrary to Stevens and the setsockopt()!
293 We work around this by looking at size of returned thing and doing a
294 ugly cast */
295
296 len = sizeof(mreq);
297 if (getsockopt(fd,IPPROTO_IP,IP_MULTICAST_IF,(void*) &mreq,&len) != 0)
298 XSRETURN_EMPTY;
299
300 if (len == sizeof(mreq)) {
301 XPUSHs(sv_2mortal(newSVpv(inet_ntoa(mreq.imr_interface),0)));
302 } else if (len == sizeof (struct in_addr)) {
303 XPUSHs(sv_2mortal(newSVpv(inet_ntoa(*(struct in_addr*)&mreq),0)));
304 } else {
305 croak("getsockopt() returned a data type I don't understand");
306 }
307
308 }
309 }
310
311