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