1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                    G N A T . S O C K E T S . T H I N                     --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--              Copyright (C) 2001-2004 Ada Core Technologies, Inc.         --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
19-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
20-- MA 02111-1307, USA.                                                      --
21--                                                                          --
22-- As a special exception,  if other files  instantiate  generics from this --
23-- unit, or you link  this unit with other files  to produce an executable, --
24-- this  unit  does not  by itself cause  the resulting  executable  to  be --
25-- covered  by the  GNU  General  Public  License.  This exception does not --
26-- however invalidate  any other reasons why  the executable file  might be --
27-- covered by the  GNU Public License.                                      --
28--                                                                          --
29-- GNAT was originally developed  by the GNAT team at  New York University. --
30-- Extensive contributions were provided by Ada Core Technologies Inc.      --
31--                                                                          --
32------------------------------------------------------------------------------
33
34--  This package provides a target dependent thin interface to the sockets
35--  layer for use by the GNAT.Sockets package (g-socket.ads). This package
36--  should not be directly with'ed by an applications program.
37
38--  This version is for NT.
39
40with GNAT.Sockets.Constants; use GNAT.Sockets.Constants;
41with Interfaces.C.Strings;   use Interfaces.C.Strings;
42
43with System; use System;
44
45package body GNAT.Sockets.Thin is
46
47   use type C.unsigned;
48
49   WSAData_Dummy : array (1 .. 512) of C.int;
50
51   WS_Version  : constant := 16#0101#;
52   Initialized : Boolean := False;
53
54   SYSNOTREADY          : constant := 10091;
55   VERNOTSUPPORTED      : constant := 10092;
56   NOTINITIALISED       : constant := 10093;
57   EDISCON              : constant := 10101;
58
59   function Standard_Connect
60     (S       : C.int;
61      Name    : System.Address;
62      Namelen : C.int)
63      return    C.int;
64   pragma Import (Stdcall, Standard_Connect, "connect");
65
66   function Standard_Select
67     (Nfds      : C.int;
68      Readfds   : Fd_Set_Access;
69      Writefds  : Fd_Set_Access;
70      Exceptfds : Fd_Set_Access;
71      Timeout   : Timeval_Access)
72      return      C.int;
73   pragma Import (Stdcall, Standard_Select, "select");
74
75   type Error_Type is
76     (N_EINTR,
77      N_EBADF,
78      N_EACCES,
79      N_EFAULT,
80      N_EINVAL,
81      N_EMFILE,
82      N_EWOULDBLOCK,
83      N_EINPROGRESS,
84      N_EALREADY,
85      N_ENOTSOCK,
86      N_EDESTADDRREQ,
87      N_EMSGSIZE,
88      N_EPROTOTYPE,
89      N_ENOPROTOOPT,
90      N_EPROTONOSUPPORT,
91      N_ESOCKTNOSUPPORT,
92      N_EOPNOTSUPP,
93      N_EPFNOSUPPORT,
94      N_EAFNOSUPPORT,
95      N_EADDRINUSE,
96      N_EADDRNOTAVAIL,
97      N_ENETDOWN,
98      N_ENETUNREACH,
99      N_ENETRESET,
100      N_ECONNABORTED,
101      N_ECONNRESET,
102      N_ENOBUFS,
103      N_EISCONN,
104      N_ENOTCONN,
105      N_ESHUTDOWN,
106      N_ETOOMANYREFS,
107      N_ETIMEDOUT,
108      N_ECONNREFUSED,
109      N_ELOOP,
110      N_ENAMETOOLONG,
111      N_EHOSTDOWN,
112      N_EHOSTUNREACH,
113      N_SYSNOTREADY,
114      N_VERNOTSUPPORTED,
115      N_NOTINITIALISED,
116      N_EDISCON,
117      N_HOST_NOT_FOUND,
118      N_TRY_AGAIN,
119      N_NO_RECOVERY,
120      N_NO_DATA,
121      N_OTHERS);
122
123   Error_Messages : constant array (Error_Type) of chars_ptr :=
124     (N_EINTR =>
125        New_String ("Interrupted system call"),
126      N_EBADF =>
127        New_String ("Bad file number"),
128      N_EACCES =>
129        New_String ("Permission denied"),
130      N_EFAULT =>
131        New_String ("Bad address"),
132      N_EINVAL =>
133        New_String ("Invalid argument"),
134      N_EMFILE =>
135        New_String ("Too many open files"),
136      N_EWOULDBLOCK =>
137        New_String ("Operation would block"),
138      N_EINPROGRESS =>
139        New_String ("Operation now in progress. This error is "
140                    & "returned if any Windows Sockets API "
141                    & "function is called while a blocking "
142                    & "function is in progress"),
143      N_EALREADY =>
144        New_String ("Operation already in progress"),
145      N_ENOTSOCK =>
146        New_String ("Socket operation on nonsocket"),
147      N_EDESTADDRREQ =>
148        New_String ("Destination address required"),
149      N_EMSGSIZE =>
150        New_String ("Message too long"),
151      N_EPROTOTYPE =>
152        New_String ("Protocol wrong type for socket"),
153      N_ENOPROTOOPT =>
154        New_String ("Protocol not available"),
155      N_EPROTONOSUPPORT =>
156        New_String ("Protocol not supported"),
157      N_ESOCKTNOSUPPORT =>
158        New_String ("Socket type not supported"),
159      N_EOPNOTSUPP =>
160        New_String ("Operation not supported on socket"),
161      N_EPFNOSUPPORT =>
162        New_String ("Protocol family not supported"),
163      N_EAFNOSUPPORT =>
164        New_String ("Address family not supported by protocol family"),
165      N_EADDRINUSE =>
166        New_String ("Address already in use"),
167      N_EADDRNOTAVAIL =>
168        New_String ("Cannot assign requested address"),
169      N_ENETDOWN =>
170        New_String ("Network is down. This error may be "
171                    & "reported at any time if the Windows "
172                    & "Sockets implementation detects an "
173                    & "underlying failure"),
174      N_ENETUNREACH =>
175        New_String ("Network is unreachable"),
176      N_ENETRESET =>
177        New_String ("Network dropped connection on reset"),
178      N_ECONNABORTED =>
179        New_String ("Software caused connection abort"),
180      N_ECONNRESET =>
181        New_String ("Connection reset by peer"),
182      N_ENOBUFS =>
183        New_String ("No buffer space available"),
184      N_EISCONN  =>
185        New_String ("Socket is already connected"),
186      N_ENOTCONN =>
187        New_String ("Socket is not connected"),
188      N_ESHUTDOWN =>
189        New_String ("Cannot send after socket shutdown"),
190      N_ETOOMANYREFS =>
191        New_String ("Too many references: cannot splice"),
192      N_ETIMEDOUT =>
193        New_String ("Connection timed out"),
194      N_ECONNREFUSED =>
195        New_String ("Connection refused"),
196      N_ELOOP =>
197        New_String ("Too many levels of symbolic links"),
198      N_ENAMETOOLONG =>
199        New_String ("File name too long"),
200      N_EHOSTDOWN =>
201        New_String ("Host is down"),
202      N_EHOSTUNREACH =>
203        New_String ("No route to host"),
204      N_SYSNOTREADY =>
205        New_String ("Returned by WSAStartup(), indicating that "
206                    & "the network subsystem is unusable"),
207      N_VERNOTSUPPORTED =>
208        New_String ("Returned by WSAStartup(), indicating that "
209                    & "the Windows Sockets DLL cannot support "
210                    & "this application"),
211      N_NOTINITIALISED =>
212        New_String ("Winsock not initialized. This message is "
213                    & "returned by any function except WSAStartup(), "
214                    & "indicating that a successful WSAStartup() has "
215                    & "not yet been performed"),
216      N_EDISCON =>
217        New_String ("Disconnect"),
218      N_HOST_NOT_FOUND =>
219        New_String ("Host not found. This message indicates "
220                    & "that the key (name, address, and so on) was not found"),
221      N_TRY_AGAIN =>
222        New_String ("Nonauthoritative host not found. This error may "
223                    & "suggest that the name service itself is not "
224                    & "functioning"),
225      N_NO_RECOVERY =>
226        New_String ("Nonrecoverable error. This error may suggest that the "
227                    & "name service itself is not functioning"),
228      N_NO_DATA =>
229        New_String ("Valid name, no data record of requested type. "
230                    & "This error indicates that the key (name, address, "
231                    & "and so on) was not found."),
232      N_OTHERS =>
233        New_String ("Unknown system error"));
234
235   ---------------
236   -- C_Connect --
237   ---------------
238
239   function C_Connect
240     (S       : C.int;
241      Name    : System.Address;
242      Namelen : C.int)
243      return    C.int
244   is
245      Res : C.int;
246
247   begin
248      Res := Standard_Connect (S, Name, Namelen);
249
250      if Res = -1 then
251         if Socket_Errno = EWOULDBLOCK then
252            Set_Socket_Errno (EINPROGRESS);
253         end if;
254      end if;
255
256      return Res;
257   end C_Connect;
258
259   -------------
260   -- C_Readv --
261   -------------
262
263   function C_Readv
264     (Socket : C.int;
265      Iov    : System.Address;
266      Iovcnt : C.int)
267      return  C.int
268   is
269      Res : C.int;
270      Count : C.int := 0;
271
272      Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
273      for Iovec'Address use Iov;
274      pragma Import (Ada, Iovec);
275
276   begin
277      for J in Iovec'Range loop
278         Res := C_Recv
279           (Socket,
280            Iovec (J).Base.all'Address,
281            C.int (Iovec (J).Length),
282            0);
283
284         if Res < 0 then
285            return Res;
286         else
287            Count := Count + Res;
288         end if;
289      end loop;
290      return Count;
291   end C_Readv;
292
293   --------------
294   -- C_Select --
295   --------------
296
297   function C_Select
298     (Nfds      : C.int;
299      Readfds   : Fd_Set_Access;
300      Writefds  : Fd_Set_Access;
301      Exceptfds : Fd_Set_Access;
302      Timeout   : Timeval_Access)
303      return      C.int
304   is
305      pragma Warnings (Off, Exceptfds);
306
307      RFS  : constant Fd_Set_Access := Readfds;
308      WFS  : constant Fd_Set_Access := Writefds;
309      WFSC : Fd_Set_Access := No_Fd_Set;
310      EFS  : Fd_Set_Access := Exceptfds;
311      Res  : C.int;
312      S    : aliased C.int;
313      Last : aliased C.int;
314
315   begin
316      --  Asynchronous connection failures are notified in the
317      --  exception fd set instead of the write fd set. To ensure
318      --  POSIX compatitibility, copy write fd set into exception fd
319      --  set. Once select() returns, check any socket present in the
320      --  exception fd set and peek at incoming out-of-band data. If
321      --  the test is not successfull and if the socket is present in
322      --  the initial write fd set, then move the socket from the
323      --  exception fd set to the write fd set.
324
325      if WFS /= No_Fd_Set then
326         --  Add any socket present in write fd set into exception fd set
327
328         if EFS = No_Fd_Set then
329            EFS := New_Socket_Set (WFS);
330
331         else
332            WFSC := New_Socket_Set (WFS);
333
334            Last := Nfds - 1;
335            loop
336               Get_Socket_From_Set
337                 (WFSC, S'Unchecked_Access, Last'Unchecked_Access);
338               exit when S = -1;
339               Insert_Socket_In_Set (EFS, S);
340            end loop;
341
342            Free_Socket_Set (WFSC);
343         end if;
344
345         --  Keep a copy of write fd set
346
347         WFSC := New_Socket_Set (WFS);
348      end if;
349
350      Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout);
351
352      if EFS /= No_Fd_Set then
353         declare
354            EFSC    : constant Fd_Set_Access := New_Socket_Set (EFS);
355            Flag    : constant C.int := MSG_PEEK + MSG_OOB;
356            Buffer  : Character;
357            Length  : C.int;
358            Fromlen : aliased C.int;
359
360         begin
361            Last := Nfds - 1;
362            loop
363               Get_Socket_From_Set
364                 (EFSC, S'Unchecked_Access, Last'Unchecked_Access);
365
366               --  No more sockets in EFSC
367
368               exit when S = -1;
369
370               --  Check out-of-band data
371
372               Length := C_Recvfrom
373                 (S, Buffer'Address, 1, Flag,
374                  null, Fromlen'Unchecked_Access);
375
376               --  If the signal is not an out-of-band data, then it
377               --  is a connection failure notification.
378
379               if Length = -1 then
380                  Remove_Socket_From_Set (EFS, S);
381
382                  --  If S is present in the initial write fd set,
383                  --  move it from exception fd set back to write fd
384                  --  set. Otherwise, ignore this event since the user
385                  --  is not watching for it.
386
387                  if WFSC /= No_Fd_Set
388                    and then Is_Socket_In_Set (WFSC, S)
389                  then
390                     Insert_Socket_In_Set (WFS, S);
391                  end if;
392               end if;
393            end loop;
394
395            Free_Socket_Set (EFSC);
396         end;
397
398         if Exceptfds = No_Fd_Set then
399            Free_Socket_Set (EFS);
400         end if;
401      end if;
402
403      --  Free any copy of write fd set
404
405      if WFSC /= No_Fd_Set then
406         Free_Socket_Set (WFSC);
407      end if;
408
409      return Res;
410   end C_Select;
411
412   --------------
413   -- C_Writev --
414   --------------
415
416   function C_Writev
417     (Socket : C.int;
418      Iov    : System.Address;
419      Iovcnt : C.int)
420      return   C.int
421   is
422      Res : C.int;
423      Count : C.int := 0;
424
425      Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
426      for Iovec'Address use Iov;
427      pragma Import (Ada, Iovec);
428
429   begin
430      for J in Iovec'Range loop
431         Res := C_Send
432           (Socket,
433            Iovec (J).Base.all'Address,
434            C.int (Iovec (J).Length),
435            0);
436
437         if Res < 0 then
438            return Res;
439         else
440            Count := Count + Res;
441         end if;
442      end loop;
443      return Count;
444   end C_Writev;
445
446   --------------
447   -- Finalize --
448   --------------
449
450   procedure Finalize is
451   begin
452      if Initialized then
453         WSACleanup;
454         Initialized := False;
455      end if;
456   end Finalize;
457
458   ----------------
459   -- Initialize --
460   ----------------
461
462   procedure Initialize (Process_Blocking_IO : Boolean := False) is
463      pragma Unreferenced (Process_Blocking_IO);
464
465      Return_Value : Interfaces.C.int;
466
467   begin
468      if not Initialized then
469         Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
470         pragma Assert (Interfaces.C."=" (Return_Value, 0));
471         Initialized := True;
472      end if;
473   end Initialize;
474
475   -----------------
476   -- Set_Address --
477   -----------------
478
479   procedure Set_Address
480     (Sin     : Sockaddr_In_Access;
481      Address : In_Addr)
482   is
483   begin
484      Sin.Sin_Addr := Address;
485   end Set_Address;
486
487   ----------------
488   -- Set_Family --
489   ----------------
490
491   procedure Set_Family
492     (Sin    : Sockaddr_In_Access;
493      Family : C.int)
494   is
495   begin
496      Sin.Sin_Family := C.unsigned_short (Family);
497   end Set_Family;
498
499   ----------------
500   -- Set_Length --
501   ----------------
502
503   procedure Set_Length
504     (Sin : Sockaddr_In_Access;
505      Len : C.int)
506   is
507      pragma Unreferenced (Sin);
508      pragma Unreferenced (Len);
509
510   begin
511      null;
512   end Set_Length;
513
514   --------------
515   -- Set_Port --
516   --------------
517
518   procedure Set_Port
519     (Sin  : Sockaddr_In_Access;
520      Port : C.unsigned_short)
521   is
522   begin
523      Sin.Sin_Port := Port;
524   end Set_Port;
525
526   --------------------------
527   -- Socket_Error_Message --
528   --------------------------
529
530   function Socket_Error_Message
531     (Errno : Integer)
532     return  C.Strings.chars_ptr
533   is
534      use GNAT.Sockets.Constants;
535
536   begin
537      case Errno is
538         when EINTR =>           return Error_Messages (N_EINTR);
539         when EBADF =>           return Error_Messages (N_EBADF);
540         when EACCES =>          return Error_Messages (N_EACCES);
541         when EFAULT =>          return Error_Messages (N_EFAULT);
542         when EINVAL =>          return Error_Messages (N_EINVAL);
543         when EMFILE =>          return Error_Messages (N_EMFILE);
544         when EWOULDBLOCK =>     return Error_Messages (N_EWOULDBLOCK);
545         when EINPROGRESS =>     return Error_Messages (N_EINPROGRESS);
546         when EALREADY =>        return Error_Messages (N_EALREADY);
547         when ENOTSOCK =>        return Error_Messages (N_ENOTSOCK);
548         when EDESTADDRREQ =>    return Error_Messages (N_EDESTADDRREQ);
549         when EMSGSIZE =>        return Error_Messages (N_EMSGSIZE);
550         when EPROTOTYPE =>      return Error_Messages (N_EPROTOTYPE);
551         when ENOPROTOOPT =>     return Error_Messages (N_ENOPROTOOPT);
552         when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
553         when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
554         when EOPNOTSUPP =>      return Error_Messages (N_EOPNOTSUPP);
555         when EPFNOSUPPORT =>    return Error_Messages (N_EPFNOSUPPORT);
556         when EAFNOSUPPORT =>    return Error_Messages (N_EAFNOSUPPORT);
557         when EADDRINUSE =>      return Error_Messages (N_EADDRINUSE);
558         when EADDRNOTAVAIL =>   return Error_Messages (N_EADDRNOTAVAIL);
559         when ENETDOWN =>        return Error_Messages (N_ENETDOWN);
560         when ENETUNREACH =>     return Error_Messages (N_ENETUNREACH);
561         when ENETRESET =>       return Error_Messages (N_ENETRESET);
562         when ECONNABORTED =>    return Error_Messages (N_ECONNABORTED);
563         when ECONNRESET =>      return Error_Messages (N_ECONNRESET);
564         when ENOBUFS =>         return Error_Messages (N_ENOBUFS);
565         when EISCONN =>         return Error_Messages (N_EISCONN);
566         when ENOTCONN =>        return Error_Messages (N_ENOTCONN);
567         when ESHUTDOWN =>       return Error_Messages (N_ESHUTDOWN);
568         when ETOOMANYREFS =>    return Error_Messages (N_ETOOMANYREFS);
569         when ETIMEDOUT =>       return Error_Messages (N_ETIMEDOUT);
570         when ECONNREFUSED =>    return Error_Messages (N_ECONNREFUSED);
571         when ELOOP =>           return Error_Messages (N_ELOOP);
572         when ENAMETOOLONG =>    return Error_Messages (N_ENAMETOOLONG);
573         when EHOSTDOWN =>       return Error_Messages (N_EHOSTDOWN);
574         when EHOSTUNREACH =>    return Error_Messages (N_EHOSTUNREACH);
575         when SYSNOTREADY =>     return Error_Messages (N_SYSNOTREADY);
576         when VERNOTSUPPORTED => return Error_Messages (N_VERNOTSUPPORTED);
577         when NOTINITIALISED =>  return Error_Messages (N_NOTINITIALISED);
578         when EDISCON =>         return Error_Messages (N_EDISCON);
579         when HOST_NOT_FOUND =>  return Error_Messages (N_HOST_NOT_FOUND);
580         when TRY_AGAIN =>       return Error_Messages (N_TRY_AGAIN);
581         when NO_RECOVERY =>     return Error_Messages (N_NO_RECOVERY);
582         when NO_DATA =>         return Error_Messages (N_NO_DATA);
583         when others =>          return Error_Messages (N_OTHERS);
584      end case;
585   end Socket_Error_Message;
586
587end GNAT.Sockets.Thin;
588