This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade Socket to 2.002
[perl5.git] / cpan / Socket / Socket.xs
index 1e3eeb0..f22c1f3 100644 (file)
 #  include <netinet/tcp.h>
 #endif
 
+#ifdef WIN32
+# include <ws2tcpip.h>
+#endif
+
 #ifdef NETWARE
 NETDB_DEFINE_CONTEXT
 NETINET_DEFINE_CONTEXT
@@ -71,27 +75,145 @@ NETINET_DEFINE_CONTEXT
 # define INADDR_LOOPBACK        0x7F000001
 #endif /* INADDR_LOOPBACK */
 
+#ifndef C_ARRAY_LENGTH
+#define C_ARRAY_LENGTH(arr) (sizeof(arr) / sizeof(*(arr)))
+#endif /* !C_ARRAY_LENGTH */
+
+#ifndef PERL_UNUSED_VAR
+# define PERL_UNUSED_VAR(x) ((void)x)
+#endif /* !PERL_UNUSED_VAR */
+
+#ifndef PERL_UNUSED_ARG
+# define PERL_UNUSED_ARG(x) PERL_UNUSED_VAR(x)
+#endif /* !PERL_UNUSED_ARG */
+
+#ifndef Newx
+# define Newx(v,n,t) New(0,v,n,t)
+#endif /* !Newx */
+
 #ifndef croak_sv
 # define croak_sv(sv)  croak(SvPV_nolen(sv))
 #endif
 
-/* perl < 5.8.9 or == 5.10.0 lacks newSVpvn_flags */
-#if PERL_VERSION < 8
-# define NEED_newSVpvn_flags
-#elif PERL_VERSION == 8 && PERL_SUBVERSION < 9
-# define NEED_newSVpvn_flags
-#elif PERL_VERSION == 10 && PERL_SUBVERSION == 0
-# define NEED_newSVpvn_flags
-#endif
+#ifndef hv_stores
+# define hv_stores(hv, keystr, val) \
+       hv_store(hv, ""keystr"", sizeof(keystr)-1, val, 0)
+#endif /* !hv_stores */
 
-#ifdef NEED_newSVpvn_flags
-static SV *newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags)
+#ifndef newSVpvn_flags
+# define newSVpvn_flags(s,len,flags) my_newSVpvn_flags(aTHX_ s,len,flags)
+static SV *my_newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags)
 {
   SV *sv = newSVpvn(s, len);
   SvFLAGS(sv) |= (flags & SVf_UTF8);
   return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
 }
-#endif
+#endif /* !newSVpvn_flags */
+
+#ifndef SvRV_set
+# define SvRV_set(sv, val) (SvRV(sv) = (val))
+#endif /* !SvRV_set */
+
+#ifndef SvPV_nomg
+# define SvPV_nomg SvPV
+#endif /* !SvPV_nomg */
+
+#ifndef HEK_FLAGS
+# define HEK_FLAGS(hek) 0
+# define HVhek_UTF8 1
+#endif /* !HEK_FLAGS */
+
+#ifndef hv_common
+/* These magic numbers are arbitrarily chosen (copied from perl core in fact)
+ * and only have to match between this definition and the code that uses them
+ */
+# define HV_FETCH_ISSTORE 0x04
+# define HV_FETCH_LVALUE  0x10
+# define hv_common(hv, keysv, key, klen, flags, act, val, hash) \
+       my_hv_common(aTHX_ hv, keysv, key, klen, flags, act, val, hash)
+static void *my_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
+       int flags, int act, SV *val, U32 hash)
+{
+       /*
+        * This only handles the usage actually made by the code
+        * generated by ExtUtils::Constant.  EU:C really ought to arrange
+        * portability of its generated code itself.
+        */
+       if (!keysv) {
+               keysv = sv_2mortal(newSVpvn(key, klen));
+               if (flags & HVhek_UTF8)
+                       SvUTF8_on(keysv);
+       }
+       if (act == HV_FETCH_LVALUE) {
+               return (void*)hv_fetch_ent(hv, keysv, 1, hash);
+       } else if (act == HV_FETCH_ISSTORE) {
+               return (void*)hv_store_ent(hv, keysv, val, hash);
+       } else {
+               croak("panic: my_hv_common: act=0x%x", act);
+       }
+}
+#endif /* !hv_common */
+
+#ifndef hv_common_key_len
+# define hv_common_key_len(hv, key, kl, act, val, hash) \
+       my_hv_common_key_len(aTHX_ hv, key, kl, act, val, hash)
+static void *my_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 kl,
+       int act, SV *val, U32 hash)
+{
+       STRLEN klen;
+       int flags;
+       if (kl < 0) {
+               klen = -kl;
+               flags = HVhek_UTF8;
+       } else {
+               klen = kl;
+               flags = 0;
+       }
+       return hv_common(hv, NULL, key, klen, flags, act, val, hash);
+}
+#endif /* !hv_common_key_len */
+
+#ifndef mPUSHi
+# define mPUSHi(i) sv_setiv_mg(PUSHs(sv_newmortal()), (IV)(i))
+#endif /* !mPUSHi */
+#ifndef mPUSHp
+# define mPUSHp(p,l) sv_setpvn_mg(PUSHs(sv_newmortal()), (p), (l))
+#endif /* !mPUSHp */
+
+#ifndef CvCONST_on
+# undef newCONSTSUB
+# define newCONSTSUB(stash, name, val) my_newCONSTSUB(aTHX_ stash, name, val)
+static CV *my_newCONSTSUB(pTHX_ HV *stash, char *name, SV *val)
+{
+       /*
+        * This has to satisfy code generated by ExtUtils::Constant.
+        * It depends on the 5.8+ layout of constant subs.  It has
+        * two calls to newCONSTSUB(): one for real constants, and one
+        * for undefined constants.  In the latter case, it turns the
+        * initially-generated constant subs into something else, and
+        * it needs the return value from newCONSTSUB() which Perl 5.6
+        * doesn't provide.
+        */
+       GV *gv;
+       CV *cv;
+       Perl_newCONSTSUB(aTHX_ stash, name, val);
+       ENTER;
+       SAVESPTR(PL_curstash);
+       PL_curstash = stash;
+       gv = gv_fetchpv(name, 0, SVt_PVCV);
+       cv = GvCV(gv);
+       LEAVE;
+       CvXSUBANY(cv).any_ptr = &PL_sv_undef;
+       return cv;
+}
+# define CvCONST_off(cv) my_CvCONST_off(aTHX_ cv)
+static void my_CvCONST_off(pTHX_ CV *cv)
+{
+       op_free(CvROOT(cv));
+       CvROOT(cv) = NULL;
+       CvSTART(cv) = NULL;
+}
+#endif /* !CvCONST_on */
 
 #ifndef HAS_INET_ATON
 
@@ -247,7 +369,7 @@ not_here(const char *s)
 static SV *err_to_SV(pTHX_ int err)
 {
        SV *ret = sv_newmortal();
-       SvUPGRADE(ret, SVt_PVNV);
+       (void) SvUPGRADE(ret, SVt_PVNV);
 
        if(err) {
                const char *error = gai_strerror(err);
@@ -279,6 +401,7 @@ static void xs_getaddrinfo(pTHX_ CV *cv)
        int err;
        int n_res;
 
+       PERL_UNUSED_ARG(cv);
        if(items > 3)
                croak("Usage: Socket::getaddrinfo(host, service, hints)");
 
@@ -325,13 +448,13 @@ static void xs_getaddrinfo(pTHX_ CV *cv)
 
                hintshash = (HV*)SvRV(hints);
 
-               if((valp = hv_fetch(hintshash, "flags", 5, 0)) != NULL)
+               if((valp = hv_fetch(hintshash, "flags", 5, 0)) != NULL && SvOK(*valp))
                        hints_s.ai_flags = SvIV(*valp);
-               if((valp = hv_fetch(hintshash, "family", 6, 0)) != NULL)
+               if((valp = hv_fetch(hintshash, "family", 6, 0)) != NULL && SvOK(*valp))
                        hints_s.ai_family = SvIV(*valp);
-               if((valp = hv_fetch(hintshash, "socktype", 8, 0)) != NULL)
+               if((valp = hv_fetch(hintshash, "socktype", 8, 0)) != NULL && SvOK(*valp))
                        hints_s.ai_socktype = SvIV(*valp);
-               if((valp = hv_fetch(hintshash, "protocol", 8, 0)) != NULL)
+               if((valp = hv_fetch(hintshash, "protocol", 8, 0)) != NULL && SvOK(*valp))
                        hints_s.ai_protocol = SvIV(*valp);
        }
 
@@ -384,6 +507,7 @@ static void xs_getnameinfo(pTHX_ CV *cv)
 
        int want_host, want_serv;
 
+       PERL_UNUSED_ARG(cv);
        if(items < 1 || items > 3)
                croak("Usage: Socket::getnameinfo(addr, flags=0, xflags=0)");
 
@@ -488,8 +612,8 @@ inet_ntoa(ip_address_sv)
                    (ip_address[2] & 0xFF) <<  8 |
                    (ip_address[3] & 0xFF);
        else
-               croak("Bad arg length for %s, length is %d, should be %d",
-                     "Socket::inet_ntoa", addrlen, sizeof(addr));
+               croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf,
+                     "Socket::inet_ntoa", (UV)addrlen, (UV)sizeof(addr));
        /* We could use inet_ntoa() but that is broken
         * in HP-UX + GCC + 64bitint (returns "0.0.0.0"),
         * so let's use this sprintf() workaround everywhere.
@@ -509,9 +633,9 @@ sockaddr_family(sockaddr)
        char *sockaddr_pv = SvPVbyte(sockaddr, sockaddr_len);
        CODE:
        if (sockaddr_len < offsetof(struct sockaddr, sa_data))
-               croak("Bad arg length for %s, length is %d, should be at least %d",
-                     "Socket::sockaddr_family", sockaddr_len,
-                     offsetof(struct sockaddr, sa_data));
+               croak("Bad arg length for %s, length is %"UVuf", should be at least %"UVuf,
+                     "Socket::sockaddr_family", (UV)sockaddr_len,
+                     (UV)offsetof(struct sockaddr, sa_data));
        ST(0) = sv_2mortal(newSViv(((struct sockaddr*)sockaddr_pv)->sa_family));
 
 void
@@ -587,15 +711,21 @@ unpack_sockaddr_un(sun_sv)
        STRLEN sockaddrlen;
        char * sun_ad = SvPVbyte(sun_sv,sockaddrlen);
        int addr_len;
-#   ifndef __linux__
+#   ifdef __linux__
        /* On Linux sockaddrlen on sockets returned by accept, recvfrom,
           getpeername and getsockname is not equal to sizeof(addr). */
+       if (sockaddrlen < sizeof(addr)) {
+         Copy(sun_ad, &addr, sockaddrlen, char);
+         Zero(((char*)&addr) + sockaddrlen, sizeof(addr) - sockaddrlen, char);
+       } else {
+         Copy(sun_ad, &addr, sizeof(addr), char);
+       }
+#   else
        if (sockaddrlen != sizeof(addr))
-               croak("Bad arg length for %s, length is %d, should be %d",
-                     "Socket::unpack_sockaddr_un", sockaddrlen, sizeof(addr));
-#   endif
-
+               croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf,
+                     "Socket::unpack_sockaddr_un", (UV)sockaddrlen, (UV)sizeof(addr));
        Copy(sun_ad, &addr, sizeof(addr), char);
+#   endif
 
        if (addr.sun_family != AF_UNIX)
                croak("Bad address family for %s, got %d, should be %d",
@@ -636,9 +766,9 @@ pack_sockaddr_in(port, ip_address_sv)
                    (ip_address[2] & 0xFF) <<  8 |
                    (ip_address[3] & 0xFF);
        else
-               croak("Bad arg length for %s, length is %d, should be %d",
+               croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf,
                      "Socket::pack_sockaddr_in",
-                     addrlen, sizeof(addr));
+                     (UV)addrlen, (UV)sizeof(addr));
        Zero(&sin, sizeof(sin), char);
        sin.sin_family = AF_INET;
        sin.sin_port = htons(port);
@@ -660,7 +790,7 @@ unpack_sockaddr_in(sin_sv)
        struct in_addr  ip_address;
        char *  sin = SvPVbyte(sin_sv,sockaddrlen);
        if (sockaddrlen != sizeof(addr)) {
-           croak("Bad arg length for %s, length is %d, should be %d",
+           croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf,
                  "Socket::unpack_sockaddr_in", sockaddrlen, sizeof(addr));
        }
        Copy(sin, &addr, sizeof(addr), char);
@@ -684,7 +814,7 @@ pack_sockaddr_in6(port, sin6_addr, scope_id=0, flowinfo=0)
        unsigned long   flowinfo
        CODE:
        {
-#ifdef AF_INET6
+#ifdef HAS_SOCKADDR_IN6
        struct sockaddr_in6 sin6;
        char * addrbytes;
        STRLEN addrlen;
@@ -692,8 +822,8 @@ pack_sockaddr_in6(port, sin6_addr, scope_id=0, flowinfo=0)
                croak("Wide character in %s", "Socket::pack_sockaddr_in6");
        addrbytes = SvPVbyte(sin6_addr, addrlen);
        if (addrlen != sizeof(sin6.sin6_addr))
-               croak("Bad arg length %s, length is %d, should be %d",
-                     "Socket::pack_sockaddr_in6", addrlen, sizeof(sin6.sin6_addr));
+               croak("Bad arg length %s, length is %"UVuf", should be %"UVuf,
+                     "Socket::pack_sockaddr_in6", (UV)addrlen, (UV)sizeof(sin6.sin6_addr));
        Zero(&sin6, sizeof(sin6), char);
        sin6.sin6_family = AF_INET6;
        sin6.sin6_port = htons(port);
@@ -720,13 +850,13 @@ unpack_sockaddr_in6(sin6_sv)
        SV *    sin6_sv
        PPCODE:
        {
-#ifdef AF_INET6
+#ifdef HAS_SOCKADDR_IN6
        STRLEN addrlen;
        struct sockaddr_in6 sin6;
        char * addrbytes = SvPVbyte(sin6_sv, addrlen);
        if (addrlen != sizeof(sin6))
-               croak("Bad arg length for %s, length is %d, should be %d",
-                     "Socket::unpack_sockaddr_in6", addrlen, sizeof(sin6));
+               croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf,
+                     "Socket::unpack_sockaddr_in6", (UV)addrlen, (UV)sizeof(sin6));
        Copy(addrbytes, &sin6, sizeof(sin6), char);
        if (sin6.sin6_family != AF_INET6)
                croak("Bad address family for %s, got %d, should be %d",
@@ -759,7 +889,12 @@ inet_ntop(af, ip_address_sv)
        struct in_addr addr;
        char str[INET_ADDRSTRLEN];
 #endif
-       char *ip_address = SvPV(ip_address_sv, addrlen);
+       char *ip_address;
+
+       if (DO_UTF8(ip_address_sv) && !sv_utf8_downgrade(ip_address_sv, 1))
+               croak("Wide character in %s", "Socket::inet_ntop");
+
+       ip_address = SvPV(ip_address_sv, addrlen);
 
        struct_size = sizeof(addr);
 
@@ -792,17 +927,23 @@ inet_pton(af, host)
        CODE:
 #ifdef HAS_INETPTON
        int ok;
+       int addrlen = 0;
 #ifdef AF_INET6
        struct in6_addr ip_address;
 #else
        struct in_addr ip_address;
 #endif
 
-       if (af != AF_INET
+       switch(af) {
+         case AF_INET:
+           addrlen = 4;
+           break;
 #ifdef AF_INET6
-           && af != AF_INET6
+         case AF_INET6:
+           addrlen = 16;
+           break;
 #endif
-          ) {
+         default:
                croak("Bad address family for %s, got %d, should be"
 #ifdef AF_INET6
                      " either AF_INET or AF_INET6",
@@ -815,34 +956,91 @@ inet_pton(af, host)
 
        ST(0) = sv_newmortal();
        if (ok) {
-               sv_setpvn( ST(0), (char *)&ip_address, sizeof(ip_address) );
+               sv_setpvn( ST(0), (char *)&ip_address, addrlen);
        }
 #else
        ST(0) = (SV*)not_here("inet_pton");
 #endif
 
 void
-pack_ipv6_mreq(addr, interface)
-       SV *    addr
+pack_ip_mreq(multiaddr, interface=&PL_sv_undef)
+       SV *    multiaddr
+       SV *    interface
+       CODE:
+       {
+#ifdef HAS_IP_MREQ
+       struct ip_mreq mreq;
+       char * multiaddrbytes;
+       char * interfacebytes;
+       STRLEN len;
+       if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1))
+               croak("Wide character in %s", "Socket::pack_ip_mreq");
+       multiaddrbytes = SvPVbyte(multiaddr, len);
+       if (len != sizeof(mreq.imr_multiaddr))
+               croak("Bad arg length %s, length is %"UVuf", should be %"UVuf,
+                     "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_multiaddr));
+       Zero(&mreq, sizeof(mreq), char);
+       Copy(multiaddrbytes, &mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr), char);
+       if(SvOK(interface)) {
+               if (DO_UTF8(interface) && !sv_utf8_downgrade(interface, 1))
+                       croak("Wide character in %s", "Socket::pack_ip_mreq");
+               interfacebytes = SvPVbyte(interface, len);
+               if (len != sizeof(mreq.imr_interface))
+                       croak("Bad arg length %s, length is %"UVuf", should be %"UVuf,
+                             "Socket::pack_ip_mreq", (UV)len, (UV)sizeof(mreq.imr_interface));
+               Copy(interfacebytes, &mreq.imr_interface, sizeof(mreq.imr_interface), char);
+       }
+       else
+               mreq.imr_interface.s_addr = INADDR_ANY;
+       ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq)));
+#else
+       not_here("pack_ip_mreq");
+#endif
+       }
+
+void
+unpack_ip_mreq(mreq_sv)
+       SV * mreq_sv
+       PPCODE:
+       {
+#ifdef HAS_IP_MREQ
+       struct ip_mreq mreq;
+       STRLEN mreqlen;
+       char * mreqbytes = SvPVbyte(mreq_sv, mreqlen);
+       if (mreqlen != sizeof(mreq))
+               croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf,
+                     "Socket::unpack_ip_mreq", (UV)mreqlen, (UV)sizeof(mreq));
+       Copy(mreqbytes, &mreq, sizeof(mreq), char);
+       EXTEND(SP, 2);
+       mPUSHp((char *)&mreq.imr_multiaddr, sizeof(mreq.imr_multiaddr));
+       mPUSHp((char *)&mreq.imr_interface, sizeof(mreq.imr_interface));
+#else
+       not_here("unpack_ip_mreq");
+#endif
+       }
+
+void
+pack_ipv6_mreq(multiaddr, interface)
+       SV *    multiaddr
        unsigned int    interface
        CODE:
        {
-#ifdef AF_INET6
+#ifdef HAS_IPV6_MREQ
        struct ipv6_mreq mreq;
-       char * addrbytes;
-       STRLEN addrlen;
-       if (DO_UTF8(addr) && !sv_utf8_downgrade(addr, 1))
+       char * multiaddrbytes;
+       STRLEN len;
+       if (DO_UTF8(multiaddr) && !sv_utf8_downgrade(multiaddr, 1))
                croak("Wide character in %s", "Socket::pack_ipv6_mreq");
-       addrbytes = SvPVbyte(addr, addrlen);
-       if (addrlen != sizeof(mreq.ipv6mr_multiaddr))
-               croak("Bad arg length %s, length is %d, should be %d",
-                     "Socket::pack_ipv6_mreq", addrlen, sizeof(mreq.ipv6mr_multiaddr));
+       multiaddrbytes = SvPVbyte(multiaddr, len);
+       if (len != sizeof(mreq.ipv6mr_multiaddr))
+               croak("Bad arg length %s, length is %"UVuf", should be %"UVuf,
+                     "Socket::pack_ipv6_mreq", (UV)len, (UV)sizeof(mreq.ipv6mr_multiaddr));
        Zero(&mreq, sizeof(mreq), char);
-       Copy(addrbytes, &mreq.ipv6mr_multiaddr, sizeof(mreq.ipv6mr_multiaddr), char);
+       Copy(multiaddrbytes, &mreq.ipv6mr_multiaddr, sizeof(mreq.ipv6mr_multiaddr), char);
        mreq.ipv6mr_interface = interface;
        ST(0) = sv_2mortal(newSVpvn((char *)&mreq, sizeof(mreq)));
 #else
-       ST(0) = (SV*)not_here("pack_ipv6_mreq");
+       not_here("pack_ipv6_mreq");
 #endif
        }
 
@@ -851,13 +1049,13 @@ unpack_ipv6_mreq(mreq_sv)
        SV * mreq_sv
        PPCODE:
        {
-#ifdef AF_INET6
+#ifdef HAS_IPV6_MREQ
        struct ipv6_mreq mreq;
        STRLEN mreqlen;
        char * mreqbytes = SvPVbyte(mreq_sv, mreqlen);
        if (mreqlen != sizeof(mreq))
-               croak("Bad arg length for %s, length is %d, should be %d",
-                     "Socket::unpack_ipv6_mreq", mreqlen, sizeof(mreq));
+               croak("Bad arg length for %s, length is %"UVuf", should be %"UVuf,
+                     "Socket::unpack_ipv6_mreq", (UV)mreqlen, (UV)sizeof(mreq));
        Copy(mreqbytes, &mreq, sizeof(mreq), char);
        EXTEND(SP, 2);
        mPUSHp((char *)&mreq.ipv6mr_multiaddr, sizeof(mreq.ipv6mr_multiaddr));