This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In Socket.xs, convert 3 croak()s to use %s and a constant string for the name.
[perl5.git] / ext / Socket / Socket.xs
1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5
6 #include <stddef.h>
7
8 #ifndef VMS
9 # ifdef I_SYS_TYPES
10 #  include <sys/types.h>
11 # endif
12 # if !defined(ultrix) /* Avoid double definition. */
13 #   include <sys/socket.h>
14 # endif
15 # if defined(USE_SOCKS) && defined(I_SOCKS)
16 #   include <socks.h>
17 # endif
18 # ifdef MPE
19 #  define PF_INET AF_INET
20 #  define PF_UNIX AF_UNIX
21 #  define SOCK_RAW 3
22 # endif
23 # ifdef I_SYS_UN
24 #  include <sys/un.h>
25 # endif
26 /* XXX Configure test for <netinet/in_systm.h needed XXX */
27 # if defined(NeXT) || defined(__NeXT__)
28 #  include <netinet/in_systm.h>
29 # endif
30 # if defined(__sgi) && !defined(AF_LINK) && defined(PF_LINK) && PF_LINK == AF_LNK
31 #  undef PF_LINK
32 # endif
33 # if defined(I_NETINET_IN) || defined(__ultrix__)
34 #  include <netinet/in.h>
35 # endif
36 # ifdef I_NETDB
37 #  if !defined(ultrix)  /* Avoid double definition. */
38 #   include <netdb.h>
39 #  endif
40 # endif
41 # ifdef I_ARPA_INET
42 #  include <arpa/inet.h>
43 # endif
44 # ifdef I_NETINET_TCP
45 #  include <netinet/tcp.h>
46 # endif
47 #else
48 # include "sockadapt.h"
49 #endif
50
51 #ifdef NETWARE
52 NETDB_DEFINE_CONTEXT
53 NETINET_DEFINE_CONTEXT
54 #endif
55
56 #ifdef I_SYSUIO
57 # include <sys/uio.h>
58 #endif
59
60 #ifndef AF_NBS
61 # undef PF_NBS
62 #endif
63
64 #ifndef AF_X25
65 # undef PF_X25
66 #endif
67
68 #ifndef INADDR_NONE
69 # define INADDR_NONE    0xffffffff
70 #endif /* INADDR_NONE */
71 #ifndef INADDR_BROADCAST
72 # define INADDR_BROADCAST       0xffffffff
73 #endif /* INADDR_BROADCAST */
74 #ifndef INADDR_LOOPBACK
75 # define INADDR_LOOPBACK         0x7F000001
76 #endif /* INADDR_LOOPBACK */
77
78 #ifndef HAS_INET_ATON
79
80 /*
81  * Check whether "cp" is a valid ascii representation
82  * of an Internet address and convert to a binary address.
83  * Returns 1 if the address is valid, 0 if not.
84  * This replaces inet_addr, the return value from which
85  * cannot distinguish between failure and a local broadcast address.
86  */
87 static int
88 my_inet_aton(register const char *cp, struct in_addr *addr)
89 {
90         dTHX;
91         register U32 val;
92         register int base;
93         register char c;
94         int nparts;
95         const char *s;
96         unsigned int parts[4];
97         register unsigned int *pp = parts;
98
99        if (!cp || !*cp)
100                 return 0;
101         for (;;) {
102                 /*
103                  * Collect number up to ``.''.
104                  * Values are specified as for C:
105                  * 0x=hex, 0=octal, other=decimal.
106                  */
107                 val = 0; base = 10;
108                 if (*cp == '0') {
109                         if (*++cp == 'x' || *cp == 'X')
110                                 base = 16, cp++;
111                         else
112                                 base = 8;
113                 }
114                 while ((c = *cp) != '\0') {
115                         if (isDIGIT(c)) {
116                                 val = (val * base) + (c - '0');
117                                 cp++;
118                                 continue;
119                         }
120                         if (base == 16 && (s=strchr(PL_hexdigit,c))) {
121                                 val = (val << 4) +
122                                         ((s - PL_hexdigit) & 15);
123                                 cp++;
124                                 continue;
125                         }
126                         break;
127                 }
128                 if (*cp == '.') {
129                         /*
130                          * Internet format:
131                          *      a.b.c.d
132                          *      a.b.c   (with c treated as 16-bits)
133                          *      a.b     (with b treated as 24 bits)
134                          */
135                         if (pp >= parts + 3 || val > 0xff)
136                                 return 0;
137                         *pp++ = val, cp++;
138                 } else
139                         break;
140         }
141         /*
142          * Check for trailing characters.
143          */
144         if (*cp && !isSPACE(*cp))
145                 return 0;
146         /*
147          * Concoct the address according to
148          * the number of parts specified.
149          */
150         nparts = pp - parts + 1;        /* force to an int for switch() */
151         switch (nparts) {
152
153         case 1:                         /* a -- 32 bits */
154                 break;
155
156         case 2:                         /* a.b -- 8.24 bits */
157                 if (val > 0xffffff)
158                         return 0;
159                 val |= parts[0] << 24;
160                 break;
161
162         case 3:                         /* a.b.c -- 8.8.16 bits */
163                 if (val > 0xffff)
164                         return 0;
165                 val |= (parts[0] << 24) | (parts[1] << 16);
166                 break;
167
168         case 4:                         /* a.b.c.d -- 8.8.8.8 bits */
169                 if (val > 0xff)
170                         return 0;
171                 val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8);
172                 break;
173         }
174         addr->s_addr = htonl(val);
175         return 1;
176 }
177
178 #undef inet_aton
179 #define inet_aton my_inet_aton
180
181 #endif /* ! HAS_INET_ATON */
182
183
184 static int
185 not_here(const char *s)
186 {
187     croak("Socket::%s not implemented on this architecture", s);
188     return -1;
189 }
190
191 #define PERL_IN_ADDR_S_ADDR_SIZE 4
192
193 /*
194 * Bad assumptions possible here.
195 *
196 * Bad Assumption 1: struct in_addr has no other fields
197 * than the s_addr (which is the field we care about
198 * in here, really). However, we can be fed either 4-byte
199 * addresses (from pack("N", ...), or va.b.c.d, or ...),
200 * or full struct in_addrs (from e.g. pack_sockaddr_in()),
201 * which may or may not be 4 bytes in size.
202 *
203 * Bad Assumption 2: the s_addr field is a simple type
204 * (such as an int, u_int32_t).  It can be a bit field,
205 * in which case using & (address-of) on it or taking sizeof()
206 * wouldn't go over too well.  (Those are not attempted
207 * now but in case someone thinks to change the below code
208 * to use addr.s_addr instead of addr, you have been warned.)
209 *
210 * Bad Assumption 3: the s_addr is the first field in
211 * an in_addr, or that its bytes are the first bytes in
212 * an in_addr.
213 *
214 * These bad assumptions are wrong in UNICOS which has
215 * struct in_addr { struct { u_long  st_addr:32; } s_da };
216 * #define s_addr s_da.st_addr
217 * and u_long is 64 bits.
218 *
219 * --jhi */
220
221 #include "const-c.inc"
222
223 MODULE = Socket         PACKAGE = Socket
224
225 INCLUDE: const-xs.inc
226
227 void
228 inet_aton(host)
229         char *  host
230         CODE:
231         {
232         struct in_addr ip_address;
233         struct hostent * phe;
234         int ok = (*host != '\0') && inet_aton(host, &ip_address);
235
236         if (!ok && (phe = gethostbyname(host)) &&
237                         phe->h_addrtype == AF_INET && phe->h_length == 4) {
238                 Copy( phe->h_addr, &ip_address, phe->h_length, char );
239                 ok = 1;
240         }
241
242         ST(0) = sv_newmortal();
243         if (ok)
244                 sv_setpvn( ST(0), (char *)&ip_address, sizeof ip_address );
245         }
246
247 void
248 inet_ntoa(ip_address_sv)
249         SV *    ip_address_sv
250         CODE:
251         {
252         STRLEN addrlen;
253         struct in_addr addr;
254         char * addr_str;
255         char * ip_address;
256         if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1))
257              croak("Wide character in %s", "Socket::inet_ntoa");
258         ip_address = SvPVbyte(ip_address_sv, addrlen);
259         if (addrlen == sizeof(addr) || addrlen == 4)
260                 addr.s_addr =
261                     (ip_address[0] & 0xFF) << 24 |
262                     (ip_address[1] & 0xFF) << 16 |
263                     (ip_address[2] & 0xFF) <<  8 |
264                     (ip_address[3] & 0xFF);
265         else
266                 croak("Bad arg length for %s, length is %d, should be %d",
267                       "Socket::inet_ntoa",
268                       addrlen, sizeof(addr));
269         /* We could use inet_ntoa() but that is broken
270          * in HP-UX + GCC + 64bitint (returns "0.0.0.0"),
271          * so let's use this sprintf() workaround everywhere.
272          * This is also more threadsafe than using inet_ntoa(). */
273         Newx(addr_str, 4 * 3 + 3 + 1, char); /* IPv6? */
274         sprintf(addr_str, "%d.%d.%d.%d",
275                 ((addr.s_addr >> 24) & 0xFF),
276                 ((addr.s_addr >> 16) & 0xFF),
277                 ((addr.s_addr >>  8) & 0xFF),
278                 ( addr.s_addr        & 0xFF));
279         ST(0) = newSVpvn_flags(addr_str, strlen(addr_str), SVs_TEMP);
280         Safefree(addr_str);
281         }
282
283 void
284 sockaddr_family(sockaddr)
285         SV *    sockaddr
286         PREINIT:
287         STRLEN sockaddr_len;
288         char *sockaddr_pv = SvPVbyte(sockaddr, sockaddr_len);
289         CODE:
290         if (sockaddr_len < offsetof(struct sockaddr, sa_data)) {
291             croak("Bad arg length for %s, length is %d, should be at least %d",
292                   "Socket::sockaddr_family", sockaddr_len,
293                   offsetof(struct sockaddr, sa_data));
294         }
295         ST(0) = sv_2mortal(newSViv(((struct sockaddr*)sockaddr_pv)->sa_family));
296
297 void
298 pack_sockaddr_un(pathname)
299         SV *    pathname
300         CODE:
301         {
302 #ifdef I_SYS_UN
303         struct sockaddr_un sun_ad; /* fear using sun */
304         STRLEN len;
305         char * pathname_pv;
306         int addr_len;
307
308         Zero( &sun_ad, sizeof sun_ad, char );
309         sun_ad.sun_family = AF_UNIX;
310         pathname_pv = SvPV(pathname,len);
311         if (len > sizeof(sun_ad.sun_path))
312             len = sizeof(sun_ad.sun_path);
313 #  ifdef OS2    /* Name should start with \socket\ and contain backslashes! */
314         {
315             int off;
316             char *s, *e;
317
318             if (pathname_pv[0] != '/' && pathname_pv[0] != '\\')
319                 croak("Relative UNIX domain socket name '%s' unsupported",
320                         pathname_pv);
321             else if (len < 8
322                      || pathname_pv[7] != '/' && pathname_pv[7] != '\\'
323                      || !strnicmp(pathname_pv + 1, "socket", 6))
324                 off = 7;
325             else
326                 off = 0;                /* Preserve names starting with \socket\ */
327             Copy( "\\socket", sun_ad.sun_path, off, char);
328             Copy( pathname_pv, sun_ad.sun_path + off, len, char );
329
330             s = sun_ad.sun_path + off - 1;
331             e = s + len + 1;
332             while (++s < e)
333                 if (*s = '/')
334                     *s = '\\';
335         }
336 #  else /* !( defined OS2 ) */
337         Copy( pathname_pv, sun_ad.sun_path, len, char );
338 #  endif
339         if (0) not_here("dummy");
340         if (len > 1 && sun_ad.sun_path[0] == '\0') {
341                 /* Linux-style abstract-namespace socket.
342                  * The name is not a file name, but an array of arbitrary
343                  * character, starting with \0 and possibly including \0s,
344                  * therefore the length of the structure must denote the
345                  * end of that character array */
346                 addr_len = (char *)&(sun_ad.sun_path) - (char *)&sun_ad + len;
347         } else {
348                 addr_len = sizeof sun_ad;
349         }
350         ST(0) = newSVpvn_flags((char *)&sun_ad, addr_len, SVs_TEMP);
351 #else
352         ST(0) = (SV *) not_here("pack_sockaddr_un");
353 #endif
354         
355         }
356
357 void
358 unpack_sockaddr_un(sun_sv)
359         SV *    sun_sv
360         CODE:
361         {
362 #ifdef I_SYS_UN
363         struct sockaddr_un addr;
364         STRLEN sockaddrlen;
365         char * sun_ad = SvPVbyte(sun_sv,sockaddrlen);
366         int addr_len;
367 #   ifndef __linux__
368         /* On Linux sockaddrlen on sockets returned by accept, recvfrom,
369            getpeername and getsockname is not equal to sizeof(addr). */
370         if (sockaddrlen != sizeof(addr)) {
371             croak("Bad arg length for %s, length is %d, should be %d",
372                         "Socket::unpack_sockaddr_un",
373                         sockaddrlen, sizeof(addr));
374         }
375 #   endif
376
377         Copy( sun_ad, &addr, sizeof addr, char );
378
379         if ( addr.sun_family != AF_UNIX ) {
380             croak("Bad address family for %s, got %d, should be %d",
381                         "Socket::unpack_sockaddr_un",
382                         addr.sun_family,
383                         AF_UNIX);
384         }
385
386         if (addr.sun_path[0] == '\0') {
387                 /* Linux-style abstract socket address begins with a nul
388                  * and can contain nuls. */
389                 addr_len = (char *)&addr - (char *)&(addr.sun_path) + sockaddrlen;
390         } else {
391                 for (addr_len = 0; addr.sun_path[addr_len]
392                      && addr_len < sizeof addr.sun_path; addr_len++);
393         }
394
395         ST(0) = newSVpvn_flags(addr.sun_path, addr_len, SVs_TEMP);
396 #else
397         ST(0) = (SV *) not_here("unpack_sockaddr_un");
398 #endif
399         }
400
401 void
402 pack_sockaddr_in(port, ip_address_sv)
403         unsigned short  port
404         SV *    ip_address_sv
405         CODE:
406         {
407         struct sockaddr_in sin;
408         struct in_addr addr;
409         STRLEN addrlen;
410         char * ip_address;
411         if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1))
412              croak("Wide character in %s", "Socket::pack_sockaddr_in");
413         ip_address = SvPVbyte(ip_address_sv, addrlen);
414         if (addrlen == sizeof(addr) || addrlen == 4)
415                 addr.s_addr =
416                     (ip_address[0] & 0xFF) << 24 |
417                     (ip_address[1] & 0xFF) << 16 |
418                     (ip_address[2] & 0xFF) <<  8 |
419                     (ip_address[3] & 0xFF);
420         else
421                 croak("Bad arg length for %s, length is %d, should be %d",
422                       "Socket::pack_sockaddr_in",
423                       addrlen, sizeof(addr));
424         Zero( &sin, sizeof sin, char );
425         sin.sin_family = AF_INET;
426         sin.sin_port = htons(port);
427         sin.sin_addr.s_addr = htonl(addr.s_addr);
428         ST(0) = newSVpvn_flags((char *)&sin, sizeof (sin), SVs_TEMP);
429         }
430
431 void
432 unpack_sockaddr_in(sin_sv)
433         SV *    sin_sv
434         PPCODE:
435         {
436         STRLEN sockaddrlen;
437         struct sockaddr_in addr;
438         unsigned short  port;
439         struct in_addr  ip_address;
440         char *  sin = SvPVbyte(sin_sv,sockaddrlen);
441         if (sockaddrlen != sizeof(addr)) {
442             croak("Bad arg length for %s, length is %d, should be %d",
443                         "Socket::unpack_sockaddr_in",
444                         sockaddrlen, sizeof(addr));
445         }
446         Copy( sin, &addr,sizeof addr, char );
447         if ( addr.sin_family != AF_INET ) {
448             croak("Bad address family for %s, got %d, should be %d",
449                         "Socket::unpack_sockaddr_in",
450                         addr.sin_family,
451                         AF_INET);
452         }
453         port = ntohs(addr.sin_port);
454         ip_address = addr.sin_addr;
455
456         EXTEND(SP, 2);
457         PUSHs(sv_2mortal(newSViv((IV) port)));
458         PUSHs(newSVpvn_flags((char *)&ip_address, sizeof(ip_address), SVs_TEMP));
459         }
460
461 void
462 inet_ntop(af, ip_address_sv)
463         int     af
464         SV *    ip_address_sv
465         CODE:
466 #ifdef HAS_INETNTOP
467         STRLEN addrlen, struct_size;
468         struct in6_addr addr;
469         char str[INET6_ADDRSTRLEN];
470         char *ip_address = SvPV(ip_address_sv, addrlen);
471
472         if(af == AF_INET) {
473             struct_size = sizeof(struct in_addr);
474         } else if(af == AF_INET6) {
475             struct_size = sizeof(struct in6_addr);
476         } else {
477            croak("Bad address family for %s, got %d, should be either AF_INET or AF_INET6",
478                "Socket::inet_ntop",
479                af);
480         }
481
482         Copy( ip_address, &addr, sizeof addr, char );
483         inet_ntop(af, &addr, str, INET6_ADDRSTRLEN);
484
485         ST(0) = newSVpvn_flags(str, strlen(str), SVs_TEMP);
486 #else
487         ST(0) = (SV *)not_here("inet_ntop");
488 #endif
489
490 void
491 inet_pton(af, host)
492         int           af
493         const char *  host
494         CODE:
495 #ifdef HAS_INETPTON
496         int ok;
497         struct in6_addr ip_address;
498         if(af != AF_INET && af != AF_INET6) {
499            croak("Bad address family for %s, got %d, should be either AF_INET or AF_INET6",
500                         "Socket::inet_pton",
501                         af);
502         }
503         ok = (*host != '\0') && inet_pton(af, host, &ip_address);
504
505         ST(0) = sv_newmortal();
506         if (ok) {
507                 sv_setpvn( ST(0), (char *)&ip_address,
508                            af == AF_INET6 ? sizeof(ip_address) : sizeof(struct in_addr) );
509         }
510 #else
511         ST(0) = (SV *)not_here("inet_pton");
512 #endif