This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix creation of libperl519s.a on Win32 with MinGW
[perl5.git] / win32 / win32sck.c
index 49d38f3..3773f40 100644 (file)
@@ -1,7 +1,7 @@
 /* win32sck.c
  *
  * (c) 1995 Microsoft Corporation. All rights reserved. 
- *             Developed by hip communications inc., http://info.hip.com/info/
+ *             Developed by hip communications inc.
  * Portions (c) 1993 Intergraph Corporation. All rights reserved.
  *
  *    You may distribute under the terms of either the GNU General Public
 #define WIN32IO_IS_STDIO
 #define WIN32SCK_IS_STDSCK
 #define WIN32_LEAN_AND_MEAN
+#define PERLIO_NOT_STDIO 0
 #ifdef __GNUC__
 #define Win32_Winsock
 #endif
 #include <windows.h>
+#include <ws2spi.h>
+
 #include "EXTERN.h"
 #include "perl.h"
 
-#if defined(PERL_OBJECT)
-#define NO_XSLOCKS
-#include "XSUB.h"
-#endif
-
 #include "Win32iop.h"
 #include <sys/socket.h>
 #include <fcntl.h>
 #include <io.h>
 
 /* thanks to Beverly Brown     (beverly@datacube.com) */
-#ifdef USE_SOCKETS_AS_HANDLES
-#      define OPEN_SOCKET(x)   win32_open_osfhandle(x,O_RDWR|O_BINARY)
-#      define TO_SOCKET(x)     _get_osfhandle(x)
-#else
-#      define OPEN_SOCKET(x)   (x)
-#      define TO_SOCKET(x)     (x)
-#endif /* USE_SOCKETS_AS_HANDLES */
-
-#ifdef USE_THREADS
+#define OPEN_SOCKET(x) win32_open_osfhandle(x,O_RDWR|O_BINARY)
+#define TO_SOCKET(x)   _get_osfhandle(x)
+
 #define StartSockets() \
     STMT_START {                                       \
        if (!wsock_started)                             \
            start_sockets();                            \
-       set_socktype();                         \
-    } STMT_END
-#else
-#define StartSockets() \
-    STMT_START {                                       \
-       if (!wsock_started) {                           \
-           start_sockets();                            \
-           set_socktype();                             \
-       }                                               \
-    } STMT_END
-#endif
-
-#define EndSockets() \
-    STMT_START {                                       \
-       if (wsock_started)                              \
-           WSACleanup();                               \
     } STMT_END
 
 #define SOCKET_TEST(x, y) \
@@ -75,24 +51,18 @@ static struct servent* win32_savecopyservent(struct servent*d,
                                              struct servent*s,
                                              const char *proto);
 
-#ifdef USE_THREADS
-#ifdef USE_DECLSPEC_THREAD
-__declspec(thread) struct servent myservent;
-__declspec(thread) int init_socktype;
-#else
-#define myservent (thr->i.Wservent)
-#define init_socktype (thr->i.Winit_socktype)
-#endif
-#else
-static struct servent myservent;
-#endif
-
 static int wsock_started = 0;
 
+EXTERN_C void
+EndSockets(void)
+{
+    if (wsock_started)
+       WSACleanup();
+}
+
 void
 start_sockets(void) 
 {
-    dTHXo;
     unsigned short version;
     WSADATA retdata;
     int ret;
@@ -101,101 +71,52 @@ start_sockets(void)
      * initalize the winsock interface and insure that it is
      * cleaned up at exit.
      */
-    version = 0x101;
+    version = 0x2;
     if(ret = WSAStartup(version, &retdata))
        Perl_croak_nocontext("Unable to locate winsock library!\n");
     if(retdata.wVersion != version)
-       Perl_croak_nocontext("Could not find version 1.1 of winsock dll\n");
+       Perl_croak_nocontext("Could not find version 2.0 of winsock dll\n");
 
     /* atexit((void (*)(void)) EndSockets); */
     wsock_started = 1;
 }
 
-void
-set_socktype(void)
-{
-#ifdef USE_SOCKETS_AS_HANDLES
-#ifdef USE_THREADS
-    dTHX;
-    if(!init_socktype) {
-#endif
-    int iSockOpt = SO_SYNCHRONOUS_NONALERT;
-    /*
-     * Enable the use of sockets as filehandles
-     */
-    setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-               (char *)&iSockOpt, sizeof(iSockOpt));
-#ifdef USE_THREADS
-    init_socktype = 1;
-    }
-#endif
-#endif /* USE_SOCKETS_AS_HANDLES */
-}
-
-
-#ifndef USE_SOCKETS_AS_HANDLES
-#undef fdopen
-FILE *
-my_fdopen(int fd, char *mode)
-{
-    FILE *fp;
-    char sockbuf[256];
-    int optlen = sizeof(sockbuf);
-    int retval;
-
-    if (!wsock_started)
-       return(fdopen(fd, mode));
-
-    retval = getsockopt((SOCKET)fd, SOL_SOCKET, SO_TYPE, sockbuf, &optlen);
-    if(retval == SOCKET_ERROR && WSAGetLastError() == WSAENOTSOCK) {
-       return(fdopen(fd, mode));
-    }
-
-    /*
-     * If we get here, then fd is actually a socket.
-     */
-    Newz(1310, fp, 1, FILE);
-    if(fp == NULL) {
-       errno = ENOMEM;
-       return NULL;
-    }
-
-    fp->_file = fd;
-    if(*mode == 'r')
-       fp->_flag = _IOREAD;
-    else
-       fp->_flag = _IOWRT;
-   
-    return fp;
-}
-#endif /* USE_SOCKETS_AS_HANDLES */
-
-
+/* in no sockets Win32 builds, these use the inline functions defined in
+ * perl.h
+ */
 u_long
 win32_htonl(u_long hostlong)
 {
+#ifndef WIN32_NO_SOCKETS
     StartSockets();
+#endif
     return htonl(hostlong);
 }
 
 u_short
 win32_htons(u_short hostshort)
 {
+#ifndef WIN32_NO_SOCKETS
     StartSockets();
+#endif
     return htons(hostshort);
 }
 
 u_long
 win32_ntohl(u_long netlong)
 {
+#ifndef WIN32_NO_SOCKETS
     StartSockets();
+#endif
     return ntohl(netlong);
 }
 
 u_short
 win32_ntohs(u_short netshort)
 {
+#ifndef WIN32_NO_SOCKETS
     StartSockets();
+#endif
     return ntohs(netshort);
 }
 
@@ -304,15 +225,37 @@ int
 win32_select(int nfds, Perl_fd_set* rd, Perl_fd_set* wr, Perl_fd_set* ex, const struct timeval* timeout)
 {
     int r;
-#ifdef USE_SOCKETS_AS_HANDLES
-    Perl_fd_set dummy;
-    int i, fd, bit, offset;
-    FD_SET nrd, nwr, nex, *prd, *pwr, *pex;
+    int i, fd, save_errno = errno;
+    FD_SET nrd, nwr, nex;
+    bool just_sleep = TRUE;
+
+    StartSockets();
+
+    FD_ZERO(&nrd);
+    FD_ZERO(&nwr);
+    FD_ZERO(&nex);
+    for (i = 0; i < nfds; i++) {
+       if (rd && PERL_FD_ISSET(i,rd)) {
+           fd = TO_SOCKET(i);
+           FD_SET((unsigned)fd, &nrd);
+            just_sleep = FALSE;
+       }
+       if (wr && PERL_FD_ISSET(i,wr)) {
+           fd = TO_SOCKET(i);
+           FD_SET((unsigned)fd, &nwr);
+            just_sleep = FALSE;
+       }
+       if (ex && PERL_FD_ISSET(i,ex)) {
+           fd = TO_SOCKET(i);
+           FD_SET((unsigned)fd, &nex);
+            just_sleep = FALSE;
+       }
+    }
 
-    /* winsock seems incapable of dealing with all three null fd_sets,
+    /* winsock seems incapable of dealing with all three fd_sets being empty,
      * so do the (millisecond) sleep as a special case
      */
-    if (!(rd || wr || ex)) {
+    if (just_sleep) {
        if (timeout)
            Sleep(timeout->tv_sec  * 1000 +
                  timeout->tv_usec / 1000);     /* do the best we can */
@@ -320,48 +263,29 @@ win32_select(int nfds, Perl_fd_set* rd, Perl_fd_set* wr, Perl_fd_set* ex, const
            Sleep(UINT_MAX);
        return 0;
     }
-    StartSockets();
-    PERL_FD_ZERO(&dummy);
-    if (!rd)
-       rd = &dummy, prd = NULL;
-    else
-       prd = &nrd;
-    if (!wr)
-       wr = &dummy, pwr = NULL;
-    else
-       pwr = &nwr;
-    if (!ex)
-       ex = &dummy, pex = NULL;
-    else
-       pex = &nex;
 
-    FD_ZERO(&nrd);
-    FD_ZERO(&nwr);
-    FD_ZERO(&nex);
-    for (i = 0; i < nfds; i++) {
-       fd = TO_SOCKET(i);
-       if (PERL_FD_ISSET(i,rd))
-           FD_SET(fd, &nrd);
-       if (PERL_FD_ISSET(i,wr))
-           FD_SET(fd, &nwr);
-       if (PERL_FD_ISSET(i,ex))
-           FD_SET(fd, &nex);
-    }
-
-    SOCKET_TEST_ERROR(r = select(nfds, prd, pwr, pex, timeout));
+    errno = save_errno;
+    SOCKET_TEST_ERROR(r = select(nfds, &nrd, &nwr, &nex, timeout));
+    save_errno = errno;
 
     for (i = 0; i < nfds; i++) {
-       fd = TO_SOCKET(i);
-       if (PERL_FD_ISSET(i,rd) && !FD_ISSET(fd, &nrd))
-           PERL_FD_CLR(i,rd);
-       if (PERL_FD_ISSET(i,wr) && !FD_ISSET(fd, &nwr))
-           PERL_FD_CLR(i,wr);
-       if (PERL_FD_ISSET(i,ex) && !FD_ISSET(fd, &nex))
-           PERL_FD_CLR(i,ex);
+       if (rd && PERL_FD_ISSET(i,rd)) {
+           fd = TO_SOCKET(i);
+           if (!FD_ISSET(fd, &nrd))
+               PERL_FD_CLR(i,rd);
+       }
+       if (wr && PERL_FD_ISSET(i,wr)) {
+           fd = TO_SOCKET(i);
+           if (!FD_ISSET(fd, &nwr))
+               PERL_FD_CLR(i,wr);
+       }
+       if (ex && PERL_FD_ISSET(i,ex)) {
+           fd = TO_SOCKET(i);
+           if (!FD_ISSET(fd, &nex))
+               PERL_FD_CLR(i,ex);
+       }
     }
-#else
-    SOCKET_TEST_ERROR(r = select(nfds, rd, wr, ex, timeout));
-#endif
+    errno = save_errno;
     return r;
 }
 
@@ -411,40 +335,137 @@ win32_closesocket(SOCKET s)
     return r;
 }
 
+void
+convert_proto_info_w2a(WSAPROTOCOL_INFOW *in, WSAPROTOCOL_INFOA *out)
+{
+    Copy(in, out, 1, WSAPROTOCOL_INFOA);
+    wcstombs(out->szProtocol, in->szProtocol, sizeof(out->szProtocol));
+}
+
+SOCKET
+open_ifs_socket(int af, int type, int protocol)
+{
+    dTHX;
+    char *s;
+    unsigned long proto_buffers_len = 0;
+    int error_code;
+    SOCKET out = INVALID_SOCKET;
+
+    if ((s = PerlEnv_getenv("PERL_ALLOW_NON_IFS_LSP")) && atoi(s))
+        return WSASocket(af, type, protocol, NULL, 0, 0);
+
+    if (WSCEnumProtocols(NULL, NULL, &proto_buffers_len, &error_code) == SOCKET_ERROR
+        && error_code == WSAENOBUFS)
+    {
+       WSAPROTOCOL_INFOW *proto_buffers;
+        int protocols_available = 0;       
+        Newx(proto_buffers, proto_buffers_len / sizeof(WSAPROTOCOL_INFOW),
+            WSAPROTOCOL_INFOW);
+
+        if ((protocols_available = WSCEnumProtocols(NULL, proto_buffers, 
+            &proto_buffers_len, &error_code)) != SOCKET_ERROR)
+        {
+            int i;
+            for (i = 0; i < protocols_available; i++)
+            {
+                WSAPROTOCOL_INFOA proto_info;
+
+                if ((af != AF_UNSPEC && af != proto_buffers[i].iAddressFamily)
+                    || (type != proto_buffers[i].iSocketType)
+                    || (protocol != 0 && proto_buffers[i].iProtocol != 0 &&
+                        protocol != proto_buffers[i].iProtocol))
+                    continue;
+
+                if ((proto_buffers[i].dwServiceFlags1 & XP1_IFS_HANDLES) == 0)
+                    continue;
+
+                convert_proto_info_w2a(&(proto_buffers[i]), &proto_info);
+
+                out = WSASocket(af, type, protocol, &proto_info, 0, 0);
+                break;
+            }
+        }
+
+        Safefree(proto_buffers);
+    }
+
+    return out;
+}
+
 SOCKET
 win32_socket(int af, int type, int protocol)
 {
     SOCKET s;
 
-#ifndef USE_SOCKETS_AS_HANDLES
-    SOCKET_TEST(s = socket(af, type, protocol), INVALID_SOCKET);
-#else
     StartSockets();
-    if((s = socket(af, type, protocol)) == INVALID_SOCKET)
+
+    if((s = open_ifs_socket(af, type, protocol)) == INVALID_SOCKET)
        errno = WSAGetLastError();
     else
        s = OPEN_SOCKET(s);
-#endif /* USE_SOCKETS_AS_HANDLES */
 
     return s;
 }
 
+/*
+ * close RTL fd while respecting sockets
+ * added as temporary measure until PerlIO has real
+ * Win32 native layer
+ *   -- BKS, 11-11-2000
+*/
+
+int my_close(int fd)
+{
+    int osf;
+    if (!wsock_started)                /* No WinSock? */
+       return(close(fd));      /* Then not a socket. */
+    osf = TO_SOCKET(fd);/* Get it now before it's gone! */
+    if (osf != -1) {
+       int err;
+       err = closesocket(osf);
+       if (err == 0) {
+           (void)close(fd);    /* handle already closed, ignore error */
+           return 0;
+       }
+       else if (err == SOCKET_ERROR) {
+           err = WSAGetLastError();
+           if (err != WSAENOTSOCK) {
+               (void)close(fd);
+               errno = err;
+               return EOF;
+           }
+       }
+    }
+    return close(fd);
+}
+
 #undef fclose
 int
 my_fclose (FILE *pf)
 {
-    int osf, retval;
+    int osf;
     if (!wsock_started)                /* No WinSock? */
        return(fclose(pf));     /* Then not a socket. */
-    osf = TO_SOCKET(fileno(pf));/* Get it now before it's gone! */
-    retval = fclose(pf);       /* Must fclose() before closesocket() */
-    if (osf != -1
-       && closesocket(osf) == SOCKET_ERROR
-       && WSAGetLastError() != WSAENOTSOCK)
-    {
-       return EOF;
+    osf = TO_SOCKET(win32_fileno(pf));/* Get it now before it's gone! */
+    if (osf != -1) {
+       int err;
+       win32_fflush(pf);
+       err = closesocket(osf);
+       if (err == 0) {
+           (void)fclose(pf);   /* handle already closed, ignore error */
+           return 0;
+       }
+       else if (err == SOCKET_ERROR) {
+           err = WSAGetLastError();
+           if (err != WSAENOTSOCK) {
+               (void)fclose(pf);
+               errno = err;
+               return EOF;
+           }
+       }
     }
-    return retval;
+    return fclose(pf);
 }
 
 struct hostent *
@@ -495,12 +516,13 @@ win32_getprotobynumber(int num)
 struct servent *
 win32_getservbyname(const char *name, const char *proto)
 {
-    dTHXo;    
+    dTHXa(NULL);    
     struct servent *r;
 
     SOCKET_TEST(r = getservbyname(name, proto), NULL);
     if (r) {
-       r = win32_savecopyservent(&myservent, r, proto);
+        aTHXa(PERL_GET_THX);
+       r = win32_savecopyservent(&w32_servent, r, proto);
     }
     return r;
 }
@@ -508,12 +530,13 @@ win32_getservbyname(const char *name, const char *proto)
 struct servent *
 win32_getservbyport(int port, const char *proto)
 {
-    dTHXo
+    dTHXa(NULL)
     struct servent *r;
 
     SOCKET_TEST(r = getservbyport(port, proto), NULL);
     if (r) {
-       r = win32_savecopyservent(&myservent, r, proto);
+        aTHXa(PERL_GET_THX);
+       r = win32_savecopyservent(&w32_servent, r, proto);
     }
     return r;
 }
@@ -521,16 +544,19 @@ win32_getservbyport(int port, const char *proto)
 int
 win32_ioctl(int i, unsigned int u, char *data)
 {
-    dTHXo;
-    u_long argp = (u_long)data;
+    u_long u_long_arg; 
     int retval;
-
+    
     if (!wsock_started) {
        Perl_croak_nocontext("ioctl implemented only on sockets");
        /* NOTREACHED */
     }
 
-    retval = ioctlsocket(TO_SOCKET(i), (long)u, &argp);
+    /* mauke says using memcpy avoids alignment issues */
+    memcpy(&u_long_arg, data, sizeof u_long_arg); 
+    retval = ioctlsocket(TO_SOCKET(i), (long)u, &u_long_arg);
+    memcpy(data, &u_long_arg, sizeof u_long_arg);
+    
     if (retval == SOCKET_ERROR) {
        if (WSAGetLastError() == WSAENOTSOCK) {
            Perl_croak_nocontext("ioctl implemented only on sockets");
@@ -562,101 +588,88 @@ win32_inet_addr(const char FAR *cp)
 void
 win32_endhostent() 
 {
-    dTHXo;
-    Perl_croak_nocontext("endhostent not implemented!\n");
+    win32_croak_not_implemented("endhostent");
 }
 
 void
 win32_endnetent()
 {
-    dTHXo;
-    Perl_croak_nocontext("endnetent not implemented!\n");
+    win32_croak_not_implemented("endnetent");
 }
 
 void
 win32_endprotoent()
 {
-    dTHXo;
-    Perl_croak_nocontext("endprotoent not implemented!\n");
+    win32_croak_not_implemented("endprotoent");
 }
 
 void
 win32_endservent()
 {
-    dTHXo;
-    Perl_croak_nocontext("endservent not implemented!\n");
+    win32_croak_not_implemented("endservent");
 }
 
 
 struct netent *
 win32_getnetent(void) 
 {
-    dTHXo;
-    Perl_croak_nocontext("getnetent not implemented!\n");
+    win32_croak_not_implemented("getnetent");
     return (struct netent *) NULL;
 }
 
 struct netent *
 win32_getnetbyname(char *name) 
 {
-    dTHXo;
-    Perl_croak_nocontext("getnetbyname not implemented!\n");
+    win32_croak_not_implemented("getnetbyname");
     return (struct netent *)NULL;
 }
 
 struct netent *
 win32_getnetbyaddr(long net, int type) 
 {
-    dTHXo;
-    Perl_croak_nocontext("getnetbyaddr not implemented!\n");
+    win32_croak_not_implemented("getnetbyaddr");
     return (struct netent *)NULL;
 }
 
 struct protoent *
 win32_getprotoent(void) 
 {
-    dTHXo;
-    Perl_croak_nocontext("getprotoent not implemented!\n");
+    win32_croak_not_implemented("getprotoent");
     return (struct protoent *) NULL;
 }
 
 struct servent *
 win32_getservent(void) 
 {
-    dTHXo;
-    Perl_croak_nocontext("getservent not implemented!\n");
+    win32_croak_not_implemented("getservent");
     return (struct servent *) NULL;
 }
 
 void
 win32_sethostent(int stayopen)
 {
-    dTHXo;
-    Perl_croak_nocontext("sethostent not implemented!\n");
+    win32_croak_not_implemented("sethostent");
 }
 
 
 void
 win32_setnetent(int stayopen)
 {
-    dTHXo;
-    Perl_croak_nocontext("setnetent not implemented!\n");
+    win32_croak_not_implemented("setnetent");
 }
 
 
 void
 win32_setprotoent(int stayopen)
 {
-    dTHXo;
-    Perl_croak_nocontext("setprotoent not implemented!\n");
+    win32_croak_not_implemented("setprotoent");
 }
 
 
 void
 win32_setservent(int stayopen)
 {
-    dTHXo;
-    Perl_croak_nocontext("setservent not implemented!\n");
+    win32_croak_not_implemented("setservent");
 }
 
 static struct servent*
@@ -665,11 +678,9 @@ win32_savecopyservent(struct servent*d, struct servent*s, const char *proto)
     d->s_name = s->s_name;
     d->s_aliases = s->s_aliases;
     d->s_port = s->s_port;
-#ifndef __BORLANDC__   /* Buggy on Win95 and WinNT-with-Borland-WSOCK */
-    if (!IsWin95() && s->s_proto && strlen(s->s_proto))
+    if (s->s_proto && strlen(s->s_proto))
        d->s_proto = s->s_proto;
     else
-#endif
     if (proto && strlen(proto))
        d->s_proto = (char *)proto;
     else