gcc/ada/3wsocthi.adb

   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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  30 --                                                                          --
  31 ------------------------------------------------------------------------------
  32
  33 --  This version is for NT.
  34
  35 package body GNAT.Sockets.Thin is
  36
  37    use type C.unsigned;
  38
  39    WSAData_Dummy : array (1 .. 512) of C.int;
  40
  41    WS_Version  : constant := 16#0101#;
  42    Initialized : Boolean := False;
  43
  44    -----------
  45    -- Clear --
  46    -----------
  47
  48    procedure Clear
  49      (Item   : in out Fd_Set;
  50       Socket : C.int)
  51    is
  52    begin
  53       for J in 1 .. Item.fd_count loop
  54          if Item.fd_array (J) = Socket then
  55             Item.fd_array (J .. Item.fd_count - 1) :=
  56               Item.fd_array (J + 1 .. Item.fd_count);
  57             Item.fd_count := Item.fd_count - 1;
  58             exit;
  59          end if;
  60       end loop;
  61    end Clear;
  62
  63    -----------
  64    -- Empty --
  65    -----------
  66
  67    procedure Empty  (Item : in out Fd_Set) is
  68    begin
  69       Item := Null_Fd_Set;
  70    end Empty;
  71
  72    --------------
  73    -- Finalize --
  74    --------------
  75
  76    procedure Finalize is
  77    begin
  78       if Initialized then
  79          WSACleanup;
  80          Initialized := False;
  81       end if;
  82    end Finalize;
  83
  84    --------------
  85    -- Is_Empty --
  86    --------------
  87
  88    function Is_Empty (Item : Fd_Set) return Boolean is
  89    begin
  90       return Item.fd_count = 0;
  91    end Is_Empty;
  92
  93    ------------
  94    -- Is_Set --
  95    ------------
  96
  97    function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is
  98    begin
  99       for J in 1 .. Item.fd_count loop
 100          if Item.fd_array (J) = Socket then
 101             return True;
 102          end if;
 103       end loop;
 104
 105       return False;
 106    end Is_Set;
 107
 108    ----------------
 109    -- Initialize --
 110    ----------------
 111
 112    procedure Initialize (Process_Blocking_IO : Boolean := False) is
 113       Return_Value : Interfaces.C.int;
 114
 115    begin
 116       if not Initialized then
 117          Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
 118          pragma Assert (Interfaces.C."=" (Return_Value, 0));
 119          Initialized := True;
 120       end if;
 121    end Initialize;
 122
 123    ---------
 124    -- Max --
 125    ---------
 126
 127    function Max (Item : Fd_Set) return C.int is
 128       L : C.int := 0;
 129
 130    begin
 131       for J in 1 .. Item.fd_count loop
 132          if Item.fd_array (J) > L then
 133             L := Item.fd_array (J);
 134          end if;
 135       end loop;
 136
 137       return L;
 138    end Max;
 139
 140    ---------
 141    -- Set --
 142    ---------
 143
 144    procedure Set (Item : in out Fd_Set; Socket : in C.int) is
 145    begin
 146       Item.fd_count := Item.fd_count + 1;
 147       Item.fd_array (Item.fd_count) := Socket;
 148    end Set;
 149
 150    --------------------------
 151    -- Socket_Error_Message --
 152    --------------------------
 153
 154    function Socket_Error_Message (Errno : Integer) return String is
 155       use GNAT.Sockets.Constants;
 156
 157    begin
 158       case Errno is
 159          when EINTR =>
 160             return "Interrupted system call";
 161
 162          when EBADF =>
 163             return "Bad file number";
 164
 165          when EACCES =>
 166             return "Permission denied";
 167
 168          when EFAULT =>
 169             return "Bad address";
 170
 171          when EINVAL =>
 172             return "Invalid argument";
 173
 174          when EMFILE =>
 175             return "Too many open files";
 176
 177          when EWOULDBLOCK =>
 178             return "Operation would block";
 179
 180          when EINPROGRESS =>
 181             return "Operation now in progress. This error is "
 182               & "returned if any Windows Sockets API "
 183               & "function is called while a blocking "
 184               & "function is in progress";
 185
 186          when EALREADY =>
 187             return "Operation already in progress";
 188
 189          when ENOTSOCK =>
 190             return "Socket operation on nonsocket";
 191
 192          when EDESTADDRREQ =>
 193             return "Destination address required";
 194
 195          when EMSGSIZE =>
 196             return "Message too long";
 197
 198          when EPROTOTYPE =>
 199             return "Protocol wrong type for socket";
 200
 201          when ENOPROTOOPT =>
 202             return "Protocol not available";
 203
 204          when EPROTONOSUPPORT =>
 205             return "Protocol not supported";
 206
 207          when ESOCKTNOSUPPORT =>
 208             return "Socket type not supported";
 209
 210          when EOPNOTSUPP =>
 211             return "Operation not supported on socket";
 212
 213          when EPFNOSUPPORT =>
 214             return "Protocol family not supported";
 215
 216          when EAFNOSUPPORT =>
 217             return "Address family not supported by protocol family";
 218
 219          when EADDRINUSE =>
 220             return "Address already in use";
 221
 222          when EADDRNOTAVAIL =>
 223             return "Cannot assign requested address";
 224
 225          when ENETDOWN =>
 226             return "Network is down. This error may be "
 227               & "reported at any time if the Windows "
 228               & "Sockets implementation detects an "
 229               & "underlying failure";
 230
 231          when ENETUNREACH =>
 232             return "Network is unreachable";
 233
 234          when ENETRESET =>
 235             return "Network dropped connection on reset";
 236
 237          when ECONNABORTED =>
 238             return "Software caused connection abort";
 239
 240          when ECONNRESET =>
 241             return "Connection reset by peer";
 242
 243          when ENOBUFS =>
 244             return "No buffer space available";
 245
 246          when EISCONN  =>
 247             return "Socket is already connected";
 248
 249          when ENOTCONN =>
 250             return "Socket is not connected";
 251
 252          when ESHUTDOWN =>
 253             return "Cannot send after socket shutdown";
 254
 255          when ETOOMANYREFS =>
 256             return "Too many references: cannot splice";
 257
 258          when ETIMEDOUT =>
 259             return "Connection timed out";
 260
 261          when ECONNREFUSED =>
 262             return "Connection refused";
 263
 264          when ELOOP =>
 265             return "Too many levels of symbolic links";
 266
 267          when ENAMETOOLONG =>
 268             return "File name too long";
 269
 270          when EHOSTDOWN =>
 271             return "Host is down";
 272
 273          when EHOSTUNREACH =>
 274             return "No route to host";
 275
 276          when SYSNOTREADY =>
 277             return "Returned by WSAStartup(), indicating that "
 278               & "the network subsystem is unusable";
 279
 280          when VERNOTSUPPORTED =>
 281             return "Returned by WSAStartup(), indicating that "
 282               & "the Windows Sockets DLL cannot support this application";
 283
 284          when NOTINITIALISED =>
 285             return "Winsock not initialized. This message is "
 286               & "returned by any function except WSAStartup(), "
 287               & "indicating that a successful WSAStartup() has "
 288               & "not yet been performed";
 289
 290          when EDISCON =>
 291             return "Disconnect";
 292
 293          when HOST_NOT_FOUND =>
 294             return "Host not found. This message indicates "
 295               & "that the key (name, address, and so on) was not found";
 296
 297          when TRY_AGAIN =>
 298             return "Nonauthoritative host not found. This error may "
 299               & "suggest that the name service itself is not functioning";
 300
 301          when NO_RECOVERY =>
 302             return "Nonrecoverable error. This error may suggest that the "
 303               & "name service itself is not functioning";
 304
 305          when NO_DATA =>
 306             return "Valid name, no data record of requested type. "
 307               & "This error indicates that the key (name, address, "
 308               & "and so on) was not found.";
 309
 310          when others =>
 311             return "Unknown system error";
 312
 313       end case;
 314    end Socket_Error_Message;
 315
 316 end GNAT.Sockets.Thin;