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