[patch@31658] Dynamically load dbg xterm on VMS
[p5sagit/p5-mst-13.2.git] / vms / sockadapt.c
1 /*  sockadapt.c
2  *
3  *  Author: Charles Bailey  bailey@newman.upenn.edu
4  *  Last Revised:  4-Mar-1997
5  *
6  *  This file should contain stubs for any of the TCP/IP functions perl5
7  *  requires which are not supported by your TCP/IP stack.  These stubs
8  *  can attempt to emulate the routine in question, or can just return
9  *  an error status or cause perl to die.
10  *
11  *  This version is set up for perl5 with UCX (or emulation) via
12  *  the DECCRTL or SOCKETSHR 0.9D.
13  */
14
15 #include "EXTERN.h"
16 #include "perl.h"
17
18 #if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000)
19 #  define __sockadapt_my_hostent_t __struct_hostent_ptr32
20 #  define __sockadapt_my_netent_t __struct_netent_ptr32
21 #  define __sockadapt_my_servent_t __struct_servent_ptr32
22 #  define __sockadapt_my_addr_t   __in_addr_t
23 #  define __sockadapt_my_name_t   const char *
24 #else
25 #  define __sockadapt_my_hostent_t struct hostent *
26 #  define __sockadapt_my_netent_t struct netent *
27 #  define __sockadapt_my_servent_t struct servent *
28 #  define __sockadapt_my_addr_t   long
29 #  define __sockadapt_my_name_t   char *
30 #endif
31
32 /* We have these on VMS 7.0 and above, or on Dec C 5.6 if it's providing */
33 /* the 7.0 DECC RTL */
34 #if ((((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)) && defined(DECCRTL_SOCKETS))
35 #else
36 void setnetent(int stayopen) {
37   dTHX;
38   Perl_croak(aTHX_ "Function \"setnetent\" not implemented in this version of perl");
39 }
40 void endnetent() {
41   dTHX;
42   Perl_croak(aTHX_ "Function \"endnetent\" not implemented in this version of perl");
43 }
44 #endif
45
46 #if defined(DECCRTL_SOCKETS)
47    /* Use builtin socket interface in DECCRTL and
48     * UCX emulation in whatever TCP/IP stack is present.
49     */
50
51 #if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
52 #else
53   void sethostent(int stayopen) {
54     dTHX;
55     Perl_croak(aTHX_ "Function \"sethostent\" not implemented in this version of perl");
56   }
57   void endhostent() {
58     dTHX;
59     Perl_croak(aTHX_ "Function \"endhostent\" not implemented in this version of perl");
60   }
61   void setprotoent(int stayopen) {
62     dTHX;
63     Perl_croak(aTHX_ "Function \"setprotoent\" not implemented in this version of perl");
64   }
65   void endprotoent() {
66     dTHX;
67     Perl_croak(aTHX_ "Function \"endprotoent\" not implemented in this version of perl");
68   }
69   void setservent(int stayopen) {
70     dTHX;
71     Perl_croak(aTHX_ "Function \"setservent\" not implemented in this version of perl");
72   }
73   void endservent() {
74     dTHX;
75     Perl_croak(aTHX_ "Function \"endservent\" not implemented in this version of perl");
76   }
77   __sockadapt_my_hostent_t gethostent() {
78     dTHX;
79     Perl_croak(aTHX_ "Function \"gethostent\" not implemented in this version of perl");
80     return (__sockadapt_my_hostent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
81   }
82   __sockadapt_my_servent_t getservent() {
83     dTHX;
84     Perl_croak(aTHX_ "Function \"getservent\" not implemented in this version of perl");
85     return (__sockadapt_my_servent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
86   }
87 #endif
88
89 #else
90     /* Work around things missing/broken in SOCKETSHR. */
91
92 __sockadapt_my_netent_t getnetbyaddr( __sockadapt_my_addr_t net, int type) {
93   dTHX;
94   Perl_croak(aTHX_ "Function \"getnetbyaddr\" not implemented in this version of perl");
95   return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */
96 }
97 __sockadapt_my_netent_t getnetbyname( __sockadapt_my_name_t name) {
98   dTHX;
99   Perl_croak(aTHX_ "Function \"getnetbyname\" not implemented in this version of perl");
100   return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */
101 }
102 __sockadapt_my_netent_t getnetent() {
103   dTHX;
104   Perl_croak(aTHX_ "Function \"getnetent\" not implemented in this version of perl");
105   return (__sockadapt_my_netent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
106 }
107
108 /* Some TCP/IP implementations seem to return success, when getpeername()
109  * is called on a UDP socket, but the port and in_addr are all zeroes.
110  */
111
112 int my_getpeername(int sock, struct sockaddr *addr, int *addrlen) {
113   static char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
114   int rslt;
115
116   rslt = si_getpeername(sock, addr, addrlen);
117
118   /* Just pass an error back up the line */
119   if (rslt) return rslt;
120
121   /* If the call succeeded, make sure we don't have a zeroed port/addr */
122   if (addr->sa_family == AF_INET &&
123       !memcmp((char *)addr + sizeof(u_short), nowhere,
124               sizeof(u_short) + sizeof(struct in_addr))) {
125     rslt = -1;
126     SETERRNO(ENOTCONN,SS$_CLEARED);
127   }
128   return rslt;
129 }
130 #endif /* SOCKETSHR stuff */