From 2a96820027cc860494e1fb9dd790b7bdfdaaf76f Mon Sep 17 00:00:00 2001 From: geby Date: Tue, 5 Feb 2013 10:17:42 +0000 Subject: [PATCH] OS/2 support by Tomas Hajny git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@171 7c85be65-684b-0410-a082-b2ed4fbef004 --- ssl_openssl_lib.pas | 36 +- ssos2ws1.inc | 1843 +++++++++++++++++++++++++++++++++++++++++++ synafpc.pas | 11 +- synaicnv.pas | 13 +- synautil.pas | 52 +- synsock.pas | 11 +- tzutil.pas | 702 ++++++++++++++++ 7 files changed, 2638 insertions(+), 30 deletions(-) create mode 100644 ssos2ws1.inc create mode 100644 tzutil.pas diff --git a/ssl_openssl_lib.pas b/ssl_openssl_lib.pas index e4d9e62..9fa6e8c 100644 --- a/ssl_openssl_lib.pas +++ b/ssl_openssl_lib.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.007.001 | +| Project : Ararat Synapse | 003.007.002 | |==============================================================================| | Content: SSL support by OpenSSL | |==============================================================================| -| Copyright (c)1999-2012, Lukas Gebauer | +| Copyright (c)1999-2013, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,11 +33,12 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2002-2012. | +| Portions created by Lukas Gebauer are Copyright (c)2002-2013. | | Portions created by Petr Fejfar are Copyright (c)2011-2012. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | +| Tomas Hajny (OS2 support) | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | @@ -87,10 +88,13 @@ uses synafpc, {$IFNDEF MSWINDOWS} {$IFDEF FPC} - BaseUnix, SysUtils; + {$IFDEF UNIX} + BaseUnix, + {$ENDIF UNIX} {$ELSE} - Libc, SysUtils; + Libc, {$ENDIF} + SysUtils; {$ELSE} Windows; {$ENDIF} @@ -112,8 +116,18 @@ var DLLSSLName: string = 'libssl.dylib'; DLLUtilName: string = 'libcrypto.dylib'; {$ELSE} + {$IFDEF OS2} + {$IFDEF OS2GCC} + DLLSSLName: string = 'kssl.dll'; + DLLUtilName: string = 'kcrypto.dll'; + {$ELSE OS2GCC} + DLLSSLName: string = 'ssl.dll'; + DLLUtilName: string = 'crypto.dll'; + {$ENDIF OS2GCC} + {$ELSE OS2} DLLSSLName: string = 'libssl.so'; DLLUtilName: string = 'libcrypto.so'; + {$ENDIF OS2} {$ENDIF} {$ELSE} DLLSSLName: string = 'ssleay32.dll'; @@ -799,7 +813,11 @@ var implementation -uses SyncObjs; +uses +{$IFDEF OS2} + Sockets, +{$ENDIF OS2} + SyncObjs; {$IFNDEF CIL} type @@ -1950,8 +1968,12 @@ begin if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then InitLocks; {$ENDIF} - Result := True; SSLloaded := True; +{$IFDEF OS2} + Result := InitEMXHandles; +{$ELSE OS2} + Result := True; +{$ENDIF OS2} end else begin diff --git a/ssos2ws1.inc b/ssos2ws1.inc new file mode 100644 index 0000000..1a52b70 --- /dev/null +++ b/ssos2ws1.inc @@ -0,0 +1,1843 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: Socket Independent Platform Layer - OS/2 winsock1 | +|==============================================================================| +| Copyright (c)1999-2013, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2003-2013. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Tomas Hajny (OS2 support) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$MACRO ON} + +{$IFNDEF ODIN} + {$DEFINE WINSOCK1} + {$DEFINE PMWSOCK} +{$ENDIF ODIN} + +{$IFDEF PMWSOCK} + {$DEFINE extdecl := cdecl} +{$ELSE PMWSOCK} + {$DEFINE extdecl := stdcall} +{$ENDIF PMWSOCK} + +//{$DEFINE WINSOCK1} +{Note about define WINSOCK1: +If you activate this compiler directive, then socket interface level 1.1 is +used instead default level 2.2. Level 2.2 is not available on old W95, however +you can install update. +} + +//{$DEFINE FORCEOLDAPI} +{Note about define FORCEOLDAPI: +If you activate this compiler directive, then is allways used old socket API +for name resolution. If you leave this directive inactive, then the new API +is used, when running system allows it. + +For IPv6 support you must have new API! +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} +{$IFDEF VER125} + {$DEFINE BCB} +{$ENDIF} +{$IFDEF BCB} + {$ObjExportAll On} + (*$HPPEMIT '/* EDE 2003-02-19 */' *) + (*$HPPEMIT 'namespace Synsock { using System::Shortint; }' *) + (*$HPPEMIT '#undef h_addr' *) + (*$HPPEMIT '#undef IOCPARM_MASK' *) + (*$HPPEMIT '#undef FD_SETSIZE' *) + (*$HPPEMIT '#undef IOC_VOID' *) + (*$HPPEMIT '#undef IOC_OUT' *) + (*$HPPEMIT '#undef IOC_IN' *) + (*$HPPEMIT '#undef IOC_INOUT' *) + (*$HPPEMIT '#undef FIONREAD' *) + (*$HPPEMIT '#undef FIONBIO' *) + (*$HPPEMIT '#undef FIOASYNC' *) + (*$HPPEMIT '#undef IPPROTO_IP' *) + (*$HPPEMIT '#undef IPPROTO_ICMP' *) + (*$HPPEMIT '#undef IPPROTO_IGMP' *) + (*$HPPEMIT '#undef IPPROTO_TCP' *) + (*$HPPEMIT '#undef IPPROTO_UDP' *) + (*$HPPEMIT '#undef IPPROTO_RAW' *) + (*$HPPEMIT '#undef IPPROTO_MAX' *) + (*$HPPEMIT '#undef INADDR_ANY' *) + (*$HPPEMIT '#undef INADDR_LOOPBACK' *) + (*$HPPEMIT '#undef INADDR_BROADCAST' *) + (*$HPPEMIT '#undef INADDR_NONE' *) + (*$HPPEMIT '#undef INVALID_SOCKET' *) + (*$HPPEMIT '#undef SOCKET_ERROR' *) + (*$HPPEMIT '#undef WSADESCRIPTION_LEN' *) + (*$HPPEMIT '#undef WSASYS_STATUS_LEN' *) + (*$HPPEMIT '#undef IP_OPTIONS' *) + (*$HPPEMIT '#undef IP_TOS' *) + (*$HPPEMIT '#undef IP_TTL' *) + (*$HPPEMIT '#undef IP_MULTICAST_IF' *) + (*$HPPEMIT '#undef IP_MULTICAST_TTL' *) + (*$HPPEMIT '#undef IP_MULTICAST_LOOP' *) + (*$HPPEMIT '#undef IP_ADD_MEMBERSHIP' *) + (*$HPPEMIT '#undef IP_DROP_MEMBERSHIP' *) + (*$HPPEMIT '#undef IP_DONTFRAGMENT' *) + (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_TTL' *) + (*$HPPEMIT '#undef IP_DEFAULT_MULTICAST_LOOP' *) + (*$HPPEMIT '#undef IP_MAX_MEMBERSHIPS' *) + (*$HPPEMIT '#undef SOL_SOCKET' *) + (*$HPPEMIT '#undef SO_DEBUG' *) + (*$HPPEMIT '#undef SO_ACCEPTCONN' *) + (*$HPPEMIT '#undef SO_REUSEADDR' *) + (*$HPPEMIT '#undef SO_KEEPALIVE' *) + (*$HPPEMIT '#undef SO_DONTROUTE' *) + (*$HPPEMIT '#undef SO_BROADCAST' *) + (*$HPPEMIT '#undef SO_USELOOPBACK' *) + (*$HPPEMIT '#undef SO_LINGER' *) + (*$HPPEMIT '#undef SO_OOBINLINE' *) + (*$HPPEMIT '#undef SO_DONTLINGER' *) + (*$HPPEMIT '#undef SO_SNDBUF' *) + (*$HPPEMIT '#undef SO_RCVBUF' *) + (*$HPPEMIT '#undef SO_SNDLOWAT' *) + (*$HPPEMIT '#undef SO_RCVLOWAT' *) + (*$HPPEMIT '#undef SO_SNDTIMEO' *) + (*$HPPEMIT '#undef SO_RCVTIMEO' *) + (*$HPPEMIT '#undef SO_ERROR' *) + (*$HPPEMIT '#undef SO_OPENTYPE' *) + (*$HPPEMIT '#undef SO_SYNCHRONOUS_ALERT' *) + (*$HPPEMIT '#undef SO_SYNCHRONOUS_NONALERT' *) + (*$HPPEMIT '#undef SO_MAXDG' *) + (*$HPPEMIT '#undef SO_MAXPATHDG' *) + (*$HPPEMIT '#undef SO_UPDATE_ACCEPT_CONTEXT' *) + (*$HPPEMIT '#undef SO_CONNECT_TIME' *) + (*$HPPEMIT '#undef SO_TYPE' *) + (*$HPPEMIT '#undef SOCK_STREAM' *) + (*$HPPEMIT '#undef SOCK_DGRAM' *) + (*$HPPEMIT '#undef SOCK_RAW' *) + (*$HPPEMIT '#undef SOCK_RDM' *) + (*$HPPEMIT '#undef SOCK_SEQPACKET' *) + (*$HPPEMIT '#undef TCP_NODELAY' *) + (*$HPPEMIT '#undef AF_UNSPEC' *) + (*$HPPEMIT '#undef SOMAXCONN' *) + (*$HPPEMIT '#undef AF_INET' *) + (*$HPPEMIT '#undef AF_MAX' *) + (*$HPPEMIT '#undef PF_UNSPEC' *) + (*$HPPEMIT '#undef PF_INET' *) + (*$HPPEMIT '#undef PF_MAX' *) + (*$HPPEMIT '#undef MSG_OOB' *) + (*$HPPEMIT '#undef MSG_PEEK' *) + (*$HPPEMIT '#undef WSABASEERR' *) + (*$HPPEMIT '#undef WSAEINTR' *) + (*$HPPEMIT '#undef WSAEBADF' *) + (*$HPPEMIT '#undef WSAEACCES' *) + (*$HPPEMIT '#undef WSAEFAULT' *) + (*$HPPEMIT '#undef WSAEINVAL' *) + (*$HPPEMIT '#undef WSAEMFILE' *) + (*$HPPEMIT '#undef WSAEWOULDBLOCK' *) + (*$HPPEMIT '#undef WSAEINPROGRESS' *) + (*$HPPEMIT '#undef WSAEALREADY' *) + (*$HPPEMIT '#undef WSAENOTSOCK' *) + (*$HPPEMIT '#undef WSAEDESTADDRREQ' *) + (*$HPPEMIT '#undef WSAEMSGSIZE' *) + (*$HPPEMIT '#undef WSAEPROTOTYPE' *) + (*$HPPEMIT '#undef WSAENOPROTOOPT' *) + (*$HPPEMIT '#undef WSAEPROTONOSUPPORT' *) + (*$HPPEMIT '#undef WSAESOCKTNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEOPNOTSUPP' *) + (*$HPPEMIT '#undef WSAEPFNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEAFNOSUPPORT' *) + (*$HPPEMIT '#undef WSAEADDRINUSE' *) + (*$HPPEMIT '#undef WSAEADDRNOTAVAIL' *) + (*$HPPEMIT '#undef WSAENETDOWN' *) + (*$HPPEMIT '#undef WSAENETUNREACH' *) + (*$HPPEMIT '#undef WSAENETRESET' *) + (*$HPPEMIT '#undef WSAECONNABORTED' *) + (*$HPPEMIT '#undef WSAECONNRESET' *) + (*$HPPEMIT '#undef WSAENOBUFS' *) + (*$HPPEMIT '#undef WSAEISCONN' *) + (*$HPPEMIT '#undef WSAENOTCONN' *) + (*$HPPEMIT '#undef WSAESHUTDOWN' *) + (*$HPPEMIT '#undef WSAETOOMANYREFS' *) + (*$HPPEMIT '#undef WSAETIMEDOUT' *) + (*$HPPEMIT '#undef WSAECONNREFUSED' *) + (*$HPPEMIT '#undef WSAELOOP' *) + (*$HPPEMIT '#undef WSAENAMETOOLONG' *) + (*$HPPEMIT '#undef WSAEHOSTDOWN' *) + (*$HPPEMIT '#undef WSAEHOSTUNREACH' *) + (*$HPPEMIT '#undef WSAENOTEMPTY' *) + (*$HPPEMIT '#undef WSAEPROCLIM' *) + (*$HPPEMIT '#undef WSAEUSERS' *) + (*$HPPEMIT '#undef WSAEDQUOT' *) + (*$HPPEMIT '#undef WSAESTALE' *) + (*$HPPEMIT '#undef WSAEREMOTE' *) + (*$HPPEMIT '#undef WSASYSNOTREADY' *) + (*$HPPEMIT '#undef WSAVERNOTSUPPORTED' *) + (*$HPPEMIT '#undef WSANOTINITIALISED' *) + (*$HPPEMIT '#undef WSAEDISCON' *) + (*$HPPEMIT '#undef WSAENOMORE' *) + (*$HPPEMIT '#undef WSAECANCELLED' *) + (*$HPPEMIT '#undef WSAEEINVALIDPROCTABLE' *) + (*$HPPEMIT '#undef WSAEINVALIDPROVIDER' *) + (*$HPPEMIT '#undef WSAEPROVIDERFAILEDINIT' *) + (*$HPPEMIT '#undef WSASYSCALLFAILURE' *) + (*$HPPEMIT '#undef WSASERVICE_NOT_FOUND' *) + (*$HPPEMIT '#undef WSATYPE_NOT_FOUND' *) + (*$HPPEMIT '#undef WSA_E_NO_MORE' *) + (*$HPPEMIT '#undef WSA_E_CANCELLED' *) + (*$HPPEMIT '#undef WSAEREFUSED' *) + (*$HPPEMIT '#undef WSAHOST_NOT_FOUND' *) + (*$HPPEMIT '#undef HOST_NOT_FOUND' *) + (*$HPPEMIT '#undef WSATRY_AGAIN' *) + (*$HPPEMIT '#undef TRY_AGAIN' *) + (*$HPPEMIT '#undef WSANO_RECOVERY' *) + (*$HPPEMIT '#undef NO_RECOVERY' *) + (*$HPPEMIT '#undef WSANO_DATA' *) + (*$HPPEMIT '#undef NO_DATA' *) + (*$HPPEMIT '#undef WSANO_ADDRESS' *) + (*$HPPEMIT '#undef ENAMETOOLONG' *) + (*$HPPEMIT '#undef ENOTEMPTY' *) + (*$HPPEMIT '#undef FD_CLR' *) + (*$HPPEMIT '#undef FD_ISSET' *) + (*$HPPEMIT '#undef FD_SET' *) + (*$HPPEMIT '#undef FD_ZERO' *) + (*$HPPEMIT '#undef NO_ADDRESS' *) + (*$HPPEMIT '#undef ADDR_ANY' *) + (*$HPPEMIT '#undef SO_GROUP_ID' *) + (*$HPPEMIT '#undef SO_GROUP_PRIORITY' *) + (*$HPPEMIT '#undef SO_MAX_MSG_SIZE' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFOA' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFOW' *) + (*$HPPEMIT '#undef SO_PROTOCOL_INFO' *) + (*$HPPEMIT '#undef PVD_CONFIG' *) + (*$HPPEMIT '#undef AF_INET6' *) + (*$HPPEMIT '#undef PF_INET6' *) +{$ENDIF} + +{$IFDEF FPC} + {$IFDEF WIN32} + {$ALIGN OFF} + {$ELSE} + {$PACKRECORDS C} + {$ENDIF} +{$ELSE} + {$IFDEF WIN64} + {$ALIGN ON} + {$MINENUMSIZE 4} + {$ELSE} + {$MINENUMSIZE 4} + {$ALIGN OFF} + {$ENDIF} +{$ENDIF} + +interface + +uses + SyncObjs, SysUtils, Classes, +{$IFDEF OS2} + Sockets, Dynlibs +{$ELSE OS2} + Windows +{$ENDIF OS2} +; + +function InitSocketInterface(stack: String): Boolean; +function DestroySocketInterface: Boolean; + +const +{$IFDEF WINSOCK1} + WinsockLevel = $0101; +{$ELSE} + WinsockLevel = $0202; +{$ENDIF} + +type +{$IFDEF OS2} + Bool = longint; +{$ENDIF OS2} + u_short = Word; + u_int = Integer; + u_long = Longint; + pu_long = ^u_long; + pu_short = ^u_short; +{$IFDEF FPC} + TSocket = ptruint; +{$ELSE} + {$IFDEF WIN64} + TSocket = UINT_PTR; + {$ELSE} + TSocket = u_int; + {$ENDIF} +{$ENDIF} + TAddrFamily = integer; + + TMemory = pointer; + +const + {$IFDEF WINCE} + DLLStackName = 'ws2.dll'; + {$ELSE} + {$IFDEF WINSOCK1} + {$IFDEF OS2} + {$IFDEF DAPWSOCK} + DLLStackName = 'dapwsock.dll'; + {$ELSE DAPWSOCK} + DLLStackName = 'pmwsock.dll'; + {$ENDIF DAPWSOCK} + {$ELSE OS2} + DLLStackName = 'wsock32.dll'; + {$ENDIF OS2} + {$ELSE} + DLLStackName = 'ws2_32.dll'; + {$ENDIF} + {$ENDIF} + DLLwship6 = 'wship6.dll'; + + cLocalhost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + c6Localhost = '::1'; + c6AnyHost = '::0'; + c6Broadcast = 'ffff::1'; + cAnyPort = '0'; + + +const + FD_SETSIZE = 64; +type + PFDSet = ^TFDSet; + TFDSet = record + fd_count: u_int; + fd_array: array[0..FD_SETSIZE-1] of TSocket; + end; + +const + FIONREAD = $4004667f; + FIONBIO = $8004667e; + FIOASYNC = $8004667d; + +type + PTimeVal = ^TTimeVal; + TTimeVal = record + tv_sec: Longint; + tv_usec: Longint; + end; + +const + IPPROTO_IP = 0; { Dummy } + IPPROTO_ICMP = 1; { Internet Control Message Protocol } + IPPROTO_IGMP = 2; { Internet Group Management Protocol} + IPPROTO_TCP = 6; { TCP } + IPPROTO_UDP = 17; { User Datagram Protocol } + IPPROTO_IPV6 = 41; + IPPROTO_ICMPV6 = 58; + IPPROTO_RM = 113; + + IPPROTO_RAW = 255; + IPPROTO_MAX = 256; + +type + + PInAddr = ^TInAddr; + TInAddr = record + case integer of + 0: (S_bytes: packed array [0..3] of byte); + 1: (S_addr: u_long); + end; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = record + case Integer of + 0: (sin_family: u_short; + sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of byte); + 1: (sa_family: u_short; + sa_data: array[0..13] of byte) + end; + + TIP_mreq = record + imr_multiaddr: TInAddr; { IP multicast address of group } + imr_interface: TInAddr; { local IP address of interface } + end; + + PInAddr6 = ^TInAddr6; + TInAddr6 = record + case integer of + 0: (S6_addr: packed array [0..15] of byte); + 1: (u6_addr8: packed array [0..15] of byte); + 2: (u6_addr16: packed array [0..7] of word); + 3: (u6_addr32: packed array [0..3] of integer); + end; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = record + sin6_family: u_short; // AF_INET6 + sin6_port: u_short; // Transport level port number + sin6_flowinfo: u_long; // IPv6 flow information + sin6_addr: TInAddr6; // IPv6 address + sin6_scope_id: u_long; // Scope Id: IF number for link-local + // SITE id for site-local + end; + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + padding: integer; + end; + + PHostEnt = ^THostEnt; + THostEnt = record + h_name: PAnsiChar; + h_aliases: ^PAnsiChar; +{$IFDEF PMWSOCK} + h_addrtype: longint; + h_length: longint; +{$ELSE PMWSOCK} + h_addrtype: Smallint; + h_length: Smallint; +{$ENDIF PMWSOCK} + case integer of + 0: (h_addr_list: ^PAnsiChar); + 1: (h_addr: ^PInAddr); + end; + + PNetEnt = ^TNetEnt; + TNetEnt = record + n_name: PAnsiChar; + n_aliases: ^PAnsiChar; +{$IFDEF PMWSOCK} + n_addrtype: longint; +{$ELSE PMWSOCK} + n_addrtype: Smallint; +{$ENDIF PMWSOCK} + n_net: u_long; + end; + + PServEnt = ^TServEnt; + TServEnt = record + s_name: PAnsiChar; + s_aliases: ^PAnsiChar; +{$ifdef WIN64} + s_proto: PAnsiChar; + s_port: Smallint; +{$else} +{$IFDEF PMWSOCK} + s_port: longint; +{$ELSE PMWSOCK} + s_port: Smallint; +{$ENDIF PMWSOCK} + s_proto: PAnsiChar; +{$endif} + end; + + PProtoEnt = ^TProtoEnt; + TProtoEnt = record + p_name: PAnsiChar; + p_aliases: ^PAnsichar; +{$IFDEF PMWSOCK} + p_proto: longint; +{$ELSE PMWSOCK} + p_proto: Smallint; +{$ENDIF PMWSOCK} + end; + +const + INADDR_ANY = $00000000; + INADDR_LOOPBACK = $7F000001; + INADDR_BROADCAST = $FFFFFFFF; + INADDR_NONE = $FFFFFFFF; + ADDR_ANY = INADDR_ANY; + INVALID_SOCKET = TSocket(NOT(0)); + SOCKET_ERROR = -1; + +Const + {$IFDEF WINSOCK1} + IP_OPTIONS = 1; + IP_MULTICAST_IF = 2; { set/get IP multicast interface } + IP_MULTICAST_TTL = 3; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 4; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 5; { add an IP group membership } + IP_DROP_MEMBERSHIP = 6; { drop an IP group membership } + IP_TTL = 7; { set/get IP Time To Live } + IP_TOS = 8; { set/get IP Type Of Service } + IP_DONTFRAGMENT = 9; { set/get IP Don't Fragment flag } + {$ELSE} + IP_OPTIONS = 1; + IP_HDRINCL = 2; + IP_TOS = 3; { set/get IP Type Of Service } + IP_TTL = 4; { set/get IP Time To Live } + IP_MULTICAST_IF = 9; { set/get IP multicast interface } + IP_MULTICAST_TTL = 10; { set/get IP multicast timetolive } + IP_MULTICAST_LOOP = 11; { set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = 12; { add an IP group membership } + IP_DROP_MEMBERSHIP = 13; { drop an IP group membership } + IP_DONTFRAGMENT = 14; { set/get IP Don't Fragment flag } + {$ENDIF} + + IP_DEFAULT_MULTICAST_TTL = 1; { normally limit m'casts to 1 hop } + IP_DEFAULT_MULTICAST_LOOP = 1; { normally hear sends if a member } + IP_MAX_MEMBERSHIPS = 20; { per socket; must fit in one mbuf } + + SOL_SOCKET = $ffff; {options for socket level } +{ Option flags per-socket. } + SO_DEBUG = $0001; { turn on debugging info recording } + SO_ACCEPTCONN = $0002; { socket has had listen() } + SO_REUSEADDR = $0004; { allow local address reuse } + SO_KEEPALIVE = $0008; { keep connections alive } + SO_DONTROUTE = $0010; { just use interface addresses } + SO_BROADCAST = $0020; { permit sending of broadcast msgs } + SO_USELOOPBACK = $0040; { bypass hardware when possible } + SO_LINGER = $0080; { linger on close if data present } + SO_OOBINLINE = $0100; { leave received OOB data in line } + SO_DONTLINGER = $ff7f; +{ Additional options. } + SO_SNDBUF = $1001; { send buffer size } + SO_RCVBUF = $1002; { receive buffer size } + SO_SNDLOWAT = $1003; { send low-water mark } + SO_RCVLOWAT = $1004; { receive low-water mark } + SO_SNDTIMEO = $1005; { send timeout } + SO_RCVTIMEO = $1006; { receive timeout } + SO_ERROR = $1007; { get error status and clear } + SO_TYPE = $1008; { get socket type } +{ WinSock 2 extension -- new options } + SO_GROUP_ID = $2001; { ID of a socket group} + SO_GROUP_PRIORITY = $2002; { the relative priority within a group} + SO_MAX_MSG_SIZE = $2003; { maximum message size } + SO_PROTOCOL_INFOA = $2004; { WSAPROTOCOL_INFOA structure } + SO_PROTOCOL_INFOW = $2005; { WSAPROTOCOL_INFOW structure } + SO_PROTOCOL_INFO = SO_PROTOCOL_INFOA; + PVD_CONFIG = $3001; {configuration info for service provider } +{ Option for opening sockets for synchronous access. } + SO_OPENTYPE = $7008; + SO_SYNCHRONOUS_ALERT = $10; + SO_SYNCHRONOUS_NONALERT = $20; +{ Other NT-specific options. } + SO_MAXDG = $7009; + SO_MAXPATHDG = $700A; + SO_UPDATE_ACCEPT_CONTEXT = $700B; + SO_CONNECT_TIME = $700C; + + SOMAXCONN = $7fffffff; + + IPV6_UNICAST_HOPS = 8; // ??? + IPV6_MULTICAST_IF = 9; // set/get IP multicast i/f + IPV6_MULTICAST_HOPS = 10; // set/get IP multicast ttl + IPV6_MULTICAST_LOOP = 11; // set/get IP multicast loopback + IPV6_JOIN_GROUP = 12; // add an IP group membership + IPV6_LEAVE_GROUP = 13; // drop an IP group membership + + MSG_NOSIGNAL = 0; + + // getnameinfo constants + NI_MAXHOST = 1025; + NI_MAXSERV = 32; + NI_NOFQDN = $1; + NI_NUMERICHOST = $2; + NI_NAMEREQD = $4; + NI_NUMERICSERV = $8; + NI_DGRAM = $10; + + +const + SOCK_STREAM = 1; { stream socket } + SOCK_DGRAM = 2; { datagram socket } + SOCK_RAW = 3; { raw-protocol interface } + SOCK_RDM = 4; { reliably-delivered message } + SOCK_SEQPACKET = 5; { sequenced packet stream } + +{ TCP options. } + TCP_NODELAY = $0001; + +{ Address families. } + + AF_UNSPEC = 0; { unspecified } + AF_INET = 2; { internetwork: UDP, TCP, etc. } + AF_INET6 = 23; { Internetwork Version 6 } + AF_MAX = 24; + +{ Protocol families, same as address families for now. } + PF_UNSPEC = AF_UNSPEC; + PF_INET = AF_INET; + PF_INET6 = AF_INET6; + PF_MAX = AF_MAX; + +type + { Structure used by kernel to store most addresses. } + PSockAddr = ^TSockAddr; + TSockAddr = TSockAddrIn; + + { Structure used by kernel to pass protocol information in raw sockets. } + PSockProto = ^TSockProto; + TSockProto = record + sp_family: u_short; + sp_protocol: u_short; + end; + +type + PAddrInfo = ^TAddrInfo; + TAddrInfo = record + ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST. + ai_family: integer; // PF_xxx. + ai_socktype: integer; // SOCK_xxx. + ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6. + ai_addrlen: u_int; // Length of ai_addr. + ai_canonname: PAnsiChar; // Canonical name for nodename. + ai_addr: PSockAddr; // Binary address. + ai_next: PAddrInfo; // Next structure in linked list. + end; + +const + // Flags used in "hints" argument to getaddrinfo(). + AI_PASSIVE = $1; // Socket address will be used in bind() call. + AI_CANONNAME = $2; // Return canonical name in first ai_canonname. + AI_NUMERICHOST = $4; // Nodename must be a numeric address string. + +type +{ Structure used for manipulating linger option. } + PLinger = ^TLinger; + TLinger = record +{$IFDEF PMWSOCK} + l_onoff: longint; + l_linger: longint; +{$ELSE PMWSOCK} + l_onoff: u_short; + l_linger: u_short; +{$ENDIF PMWSOCK} + end; + +const + + MSG_OOB = $01; // Process out-of-band data. + MSG_PEEK = $02; // Peek at incoming messages. + +const + +{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" } + WSABASEERR = 10000; + +{ Windows Sockets definitions of regular Microsoft C error constants } + + WSAEINTR = (WSABASEERR+4); + WSAEBADF = (WSABASEERR+9); + WSAEACCES = (WSABASEERR+13); + WSAEFAULT = (WSABASEERR+14); + WSAEINVAL = (WSABASEERR+22); + WSAEMFILE = (WSABASEERR+24); + +{ Windows Sockets definitions of regular Berkeley error constants } + + WSAEWOULDBLOCK = (WSABASEERR+35); + WSAEINPROGRESS = (WSABASEERR+36); + WSAEALREADY = (WSABASEERR+37); + WSAENOTSOCK = (WSABASEERR+38); + WSAEDESTADDRREQ = (WSABASEERR+39); + WSAEMSGSIZE = (WSABASEERR+40); + WSAEPROTOTYPE = (WSABASEERR+41); + WSAENOPROTOOPT = (WSABASEERR+42); + WSAEPROTONOSUPPORT = (WSABASEERR+43); + WSAESOCKTNOSUPPORT = (WSABASEERR+44); + WSAEOPNOTSUPP = (WSABASEERR+45); + WSAEPFNOSUPPORT = (WSABASEERR+46); + WSAEAFNOSUPPORT = (WSABASEERR+47); + WSAEADDRINUSE = (WSABASEERR+48); + WSAEADDRNOTAVAIL = (WSABASEERR+49); + WSAENETDOWN = (WSABASEERR+50); + WSAENETUNREACH = (WSABASEERR+51); + WSAENETRESET = (WSABASEERR+52); + WSAECONNABORTED = (WSABASEERR+53); + WSAECONNRESET = (WSABASEERR+54); + WSAENOBUFS = (WSABASEERR+55); + WSAEISCONN = (WSABASEERR+56); + WSAENOTCONN = (WSABASEERR+57); + WSAESHUTDOWN = (WSABASEERR+58); + WSAETOOMANYREFS = (WSABASEERR+59); + WSAETIMEDOUT = (WSABASEERR+60); + WSAECONNREFUSED = (WSABASEERR+61); + WSAELOOP = (WSABASEERR+62); + WSAENAMETOOLONG = (WSABASEERR+63); + WSAEHOSTDOWN = (WSABASEERR+64); + WSAEHOSTUNREACH = (WSABASEERR+65); + WSAENOTEMPTY = (WSABASEERR+66); + WSAEPROCLIM = (WSABASEERR+67); + WSAEUSERS = (WSABASEERR+68); + WSAEDQUOT = (WSABASEERR+69); + WSAESTALE = (WSABASEERR+70); + WSAEREMOTE = (WSABASEERR+71); + +{ Extended Windows Sockets error constant definitions } + + WSASYSNOTREADY = (WSABASEERR+91); + WSAVERNOTSUPPORTED = (WSABASEERR+92); + WSANOTINITIALISED = (WSABASEERR+93); + WSAEDISCON = (WSABASEERR+101); + WSAENOMORE = (WSABASEERR+102); + WSAECANCELLED = (WSABASEERR+103); + WSAEEINVALIDPROCTABLE = (WSABASEERR+104); + WSAEINVALIDPROVIDER = (WSABASEERR+105); + WSAEPROVIDERFAILEDINIT = (WSABASEERR+106); + WSASYSCALLFAILURE = (WSABASEERR+107); + WSASERVICE_NOT_FOUND = (WSABASEERR+108); + WSATYPE_NOT_FOUND = (WSABASEERR+109); + WSA_E_NO_MORE = (WSABASEERR+110); + WSA_E_CANCELLED = (WSABASEERR+111); + WSAEREFUSED = (WSABASEERR+112); + +{ Error return codes from gethostbyname() and gethostbyaddr() + (when using the resolver). Note that these errors are + retrieved via WSAGetLastError() and must therefore follow + the rules for avoiding clashes with error numbers from + specific implementations or language run-time systems. + For this reason the codes are based at WSABASEERR+1001. + Note also that [WSA]NO_ADDRESS is defined only for + compatibility purposes. } + +{ Authoritative Answer: Host not found } + WSAHOST_NOT_FOUND = (WSABASEERR+1001); + HOST_NOT_FOUND = WSAHOST_NOT_FOUND; +{ Non-Authoritative: Host not found, or SERVERFAIL } + WSATRY_AGAIN = (WSABASEERR+1002); + TRY_AGAIN = WSATRY_AGAIN; +{ Non recoverable errors, FORMERR, REFUSED, NOTIMP } + WSANO_RECOVERY = (WSABASEERR+1003); + NO_RECOVERY = WSANO_RECOVERY; +{ Valid name, no data record of requested type } + WSANO_DATA = (WSABASEERR+1004); + NO_DATA = WSANO_DATA; +{ no address, look for MX record } + WSANO_ADDRESS = WSANO_DATA; + NO_ADDRESS = WSANO_ADDRESS; + + EWOULDBLOCK = WSAEWOULDBLOCK; + EINPROGRESS = WSAEINPROGRESS; + EALREADY = WSAEALREADY; + ENOTSOCK = WSAENOTSOCK; + EDESTADDRREQ = WSAEDESTADDRREQ; + EMSGSIZE = WSAEMSGSIZE; + EPROTOTYPE = WSAEPROTOTYPE; + ENOPROTOOPT = WSAENOPROTOOPT; + EPROTONOSUPPORT = WSAEPROTONOSUPPORT; + ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT; + EOPNOTSUPP = WSAEOPNOTSUPP; + EPFNOSUPPORT = WSAEPFNOSUPPORT; + EAFNOSUPPORT = WSAEAFNOSUPPORT; + EADDRINUSE = WSAEADDRINUSE; + EADDRNOTAVAIL = WSAEADDRNOTAVAIL; + ENETDOWN = WSAENETDOWN; + ENETUNREACH = WSAENETUNREACH; + ENETRESET = WSAENETRESET; + ECONNABORTED = WSAECONNABORTED; + ECONNRESET = WSAECONNRESET; + ENOBUFS = WSAENOBUFS; + EISCONN = WSAEISCONN; + ENOTCONN = WSAENOTCONN; + ESHUTDOWN = WSAESHUTDOWN; + ETOOMANYREFS = WSAETOOMANYREFS; + ETIMEDOUT = WSAETIMEDOUT; + ECONNREFUSED = WSAECONNREFUSED; + ELOOP = WSAELOOP; + ENAMETOOLONG = WSAENAMETOOLONG; + EHOSTDOWN = WSAEHOSTDOWN; + EHOSTUNREACH = WSAEHOSTUNREACH; + ENOTEMPTY = WSAENOTEMPTY; + EPROCLIM = WSAEPROCLIM; + EUSERS = WSAEUSERS; + EDQUOT = WSAEDQUOT; + ESTALE = WSAESTALE; + EREMOTE = WSAEREMOTE; + + EAI_ADDRFAMILY = 1; // Address family for nodename not supported. + EAI_AGAIN = 2; // Temporary failure in name resolution. + EAI_BADFLAGS = 3; // Invalid value for ai_flags. + EAI_FAIL = 4; // Non-recoverable failure in name resolution. + EAI_FAMILY = 5; // Address family ai_family not supported. + EAI_MEMORY = 6; // Memory allocation failure. + EAI_NODATA = 7; // No address associated with nodename. + EAI_NONAME = 8; // Nodename nor servname provided, or not known. + EAI_SERVICE = 9; // Servname not supported for ai_socktype. + EAI_SOCKTYPE = 10; // Socket type ai_socktype not supported. + EAI_SYSTEM = 11; // System error returned in errno. + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = record + wVersion: Word; + wHighVersion: Word; +{$ifdef win64} + iMaxSockets : Word; + iMaxUdpDg : Word; + lpVendorInfo : PAnsiChar; + szDescription : array[0..WSADESCRIPTION_LEN] of AnsiChar; + szSystemStatus : array[0..WSASYS_STATUS_LEN] of AnsiChar; +{$else} + szDescription: array[0..WSADESCRIPTION_LEN] of AnsiChar; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of AnsiChar; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PAnsiChar; +{$endif} + end; + + function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; + function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; + function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; + function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean; + procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); + procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +var + in6addr_any, in6addr_loopback : TInAddr6; + +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +procedure FD_ZERO(var FDSet: TFDSet); + +{=============================================================================} + +type + TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer; + extdecl; + TWSACleanup = function: Integer; + extdecl; + TWSAGetLastError = function: Integer; + extdecl; + TGetServByName = function(name, proto: PAnsiChar): PServEnt; + extdecl; + TGetServByPort = function(port: Integer; proto: PAnsiChar): PServEnt; + extdecl; + TGetProtoByName = function(name: PAnsiChar): PProtoEnt; + extdecl; + TGetProtoByNumber = function(proto: Integer): PProtoEnt; + extdecl; + TGetHostByName = function(name: PAnsiChar): PHostEnt; + extdecl; + TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; + extdecl; + TGetHostName = function(name: PAnsiChar; len: Integer): Integer; + extdecl; + TShutdown = function(s: TSocket; how: Integer): Integer; + extdecl; + TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; + extdecl; + TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; + extdecl; + TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr; + tolen: Integer): Integer; + extdecl; + TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer; + extdecl; + TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer; + extdecl; + TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr; + var fromlen: Integer): Integer; + extdecl; + Tntohs = function(netshort: u_short): u_short; + extdecl; + Tntohl = function(netlong: u_long): u_long; + extdecl; + TListen = function(s: TSocket; backlog: Integer): Integer; + extdecl; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: Integer): Integer; + extdecl; + TInet_ntoa = function(inaddr: TInAddr): PAnsiChar; + extdecl; + TInet_addr = function(cp: PAnsiChar): u_long; + extdecl; + Thtons = function(hostshort: u_short): u_short; + extdecl; + Thtonl = function(hostlong: u_long): u_long; + extdecl; + TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + extdecl; + TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; + extdecl; + TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer; + extdecl; + TCloseSocket = function(s: TSocket): Integer; + extdecl; + TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer; + extdecl; + TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket; + extdecl; + TTSocket = function(af, Struc, Protocol: Integer): TSocket; + extdecl; + TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + extdecl; + + TGetAddrInfo = function(NodeName: PAnsiChar; ServName: PAnsiChar; Hints: PAddrInfo; + var Addrinfo: PAddrInfo): integer; + extdecl; + TFreeAddrInfo = procedure(ai: PAddrInfo); + extdecl; + TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PAnsiChar; + hostlen: DWORD; serv: PAnsiChar; servlen: DWORD; flags: integer): integer; + extdecl; + + T__WSAFDIsSet = function (s: TSocket; var FDSet: TFDSet): Bool; + extdecl; + + TWSAIoctl = function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; + extdecl; + +var + WSAStartup: TWSAStartup = nil; + WSACleanup: TWSACleanup = nil; + WSAGetLastError: TWSAGetLastError = nil; + GetServByName: TGetServByName = nil; + GetServByPort: TGetServByPort = nil; + GetProtoByName: TGetProtoByName = nil; + GetProtoByNumber: TGetProtoByNumber = nil; + GetHostByName: TGetHostByName = nil; + GetHostByAddr: TGetHostByAddr = nil; + ssGetHostName: TGetHostName = nil; +{$IFDEF OS2} + ssShutdown: TShutdown = nil; + ssSetSockOpt: TSetSockOpt = nil; + ssGetSockOpt: TGetSockOpt = nil; +{$ELSE OS2} + Shutdown: TShutdown = nil; + SetSockOpt: TSetSockOpt = nil; + GetSockOpt: TGetSockOpt = nil; +{$ENDIF OS2} + ssSendTo: TSendTo = nil; + ssSend: TSend = nil; + ssRecv: TRecv = nil; + ssRecvFrom: TRecvFrom = nil; + ntohs: Tntohs = nil; + ntohl: Tntohl = nil; +{$IFDEF OS2} + ssListen: TListen = nil; + ssIoctlSocket: TIoctlSocket = nil; +{$ELSE OS2} + Listen: TListen = nil; + IoctlSocket: TIoctlSocket = nil; +{$ENDIF OS2} + Inet_ntoa: TInet_ntoa = nil; + Inet_addr: TInet_addr = nil; + htons: Thtons = nil; + htonl: Thtonl = nil; + ssGetSockName: TGetSockName = nil; + ssGetPeerName: TGetPeerName = nil; + ssConnect: TConnect = nil; +{$IFDEF OS2} + ssCloseSocket: TCloseSocket = nil; +{$ELSE OS2} + CloseSocket: TCloseSocket = nil; +{$ENDIF OS2} + ssBind: TBind = nil; + ssAccept: TAccept = nil; +{$IFDEF OS2} + ssSocket: TTSocket = nil; +{$ELSE OS2} + Socket: TTSocket = nil; +{$ENDIF OS2} + Select: TSelect = nil; + + GetAddrInfo: TGetAddrInfo = nil; + FreeAddrInfo: TFreeAddrInfo = nil; + GetNameInfo: TGetNameInfo = nil; + +{$IFDEF OS2} + ss__WSAFDIsSet: T__WSAFDIsSet = nil; + + ssWSAIoctl: TWSAIoctl = nil; +{$ELSE OS2} + __WSAFDIsSet: T__WSAFDIsSet = nil; + + WSAIoctl: TWSAIoctl = nil; +{$ENDIF OS2} + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + case integer of + 0: (AddressFamily: u_short); + 1: ( + case sin_family: u_short of + AF_INET: (sin_port: u_short; + sin_addr: TInAddr; + sin_zero: array[0..7] of byte); + AF_INET6: (sin6_port: u_short; + sin6_flowinfo: u_long; + sin6_addr: TInAddr6; + sin6_scope_id: u_long); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + +function Bind(s: TSocket; const addr: TVarSin): Integer; +function Connect(s: TSocket; const name: TVarSin): Integer; +function GetSockName(s: TSocket; var name: TVarSin): Integer; +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +function GetHostName: AnsiString; +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +function Accept(s: TSocket; var addr: TVarSin): TSocket; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): AnsiString; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; +function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word; +{$IFDEF OS2} +function Socket (af, Struc, Protocol: Integer): TSocket; +function Shutdown (s: TSocket; how: Integer): Integer; +function SetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; +function GetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; +function Listen (s: TSocket; backlog: Integer): Integer; +function IoctlSocket (s: TSocket; cmd: DWORD; var arg: Integer): Integer; +function CloseSocket (s: TSocket): Integer; + +function __WSAFDIsSet (s: TSocket; var FDSet: TFDSet): Bool; + +function WSAIoctl (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; +{$ENDIF OS2} + +{==============================================================================} +implementation + +var + SynSockCount: Integer = 0; + LibHandle: THandle = 0; + Libwship6Handle: THandle = 0; + +function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0)); +end; + +function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and + (a^.u6_addr32[2] = 0) and + (a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and + (a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1)); +end; + +function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80)); +end; + +function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean; +begin + Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0)); +end; + +function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean; +begin + Result := (a^.u6_addr8[0] = $FF); +end; + +function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; +begin + Result := (CompareMem( a, b, sizeof(TInAddr6))); +end; + +procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); +end; + +procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); +begin + FillChar(a^, sizeof(TInAddr6), 0); + a^.u6_addr8[15] := 1; +end; + +{=============================================================================} +procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet); +var + I: Integer; +begin +{$IFDEF OS2} + Socket := TSocket (NativeSocket (cInt (Socket))); +{$ENDIF OS2} + I := 0; + while I < FDSet.fd_count do + begin + if FDSet.fd_array[I] = Socket then + begin + while I < FDSet.fd_count - 1 do + begin + FDSet.fd_array[I] := FDSet.fd_array[I + 1]; + Inc(I); + end; + Dec(FDSet.fd_count); + Break; + end; + Inc(I); + end; +end; + +function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean; +begin +{$IFDEF OS2} + Socket := TSocket (NativeSocket (cInt (Socket))); +{$ENDIF OS2} + Result := __WSAFDIsSet(Socket, FDSet) +{$IFDEF OS2} + <> 0 +{$ENDIF OS2} ; +end; + +procedure FD_SET(Socket: TSocket; var FDSet: TFDSet); +begin +{$IFDEF OS2} + Socket := TSocket (NativeSocket (cInt (Socket))); +{$ENDIF OS2} + if FDSet.fd_count < FD_SETSIZE then + begin + FDSet.fd_array[FDSet.fd_count] := Socket; + Inc(FDSet.fd_count); + end; +end; + +procedure FD_ZERO(var FDSet: TFDSet); +begin + FDSet.fd_count := 0; +end; + +{=============================================================================} + +function SizeOfVarSin(sin: TVarSin): integer; +begin + case sin.sin_family of + AF_INET: + Result := SizeOf(TSockAddrIn); + AF_INET6: + Result := SizeOf(TSockAddrIn6); + else + Result := 0; + end; +end; + +{=============================================================================} + +function Bind(s: TSocket; const addr: TVarSin): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssBind(s, @addr, SizeOfVarSin(addr)); +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssConnect(s, @name, SizeOfVarSin(name)); +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetSockName(s, @name, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + len := SizeOf(name); + FillChar(name, len, 0); + Result := ssGetPeerName(s, @name, Len); +end; + +function GetHostName: AnsiString; +var + s: AnsiString; +begin + Result := ''; + setlength(s, 255); + ssGetHostName(pAnsichar(s), Length(s) - 1); + Result := PAnsichar(s); +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssSend(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssRecv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto)); +end; + +function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer; +var + x: integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + x := SizeOf(from); + Result := ssRecvFrom(s, Buf^, len, flags, @from, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin +{$IFDEF OS2} + S := TSocket (NativeSocket (cInt (S))); +{$ENDIF OS2} + x := SizeOf(addr); +{$IFDEF OS2} + Result := TSocket (EMXSocket (cInt (ssAccept (S, @Addr, X)))); +{$ELSE OS2} + Result := ssAccept(s, @addr, x); +{$ENDIF OS2} +end; + +{$IFDEF OS2} +function Shutdown (s: TSocket; how: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + Shutdown := ssShutdown (s, how); +end; + +function Socket (af, Struc, Protocol: Integer): TSocket; +begin + Socket := TSocket (EMXSocket (cInt (ssSocket (af, Struc, Protocol)))); +end; + +function SetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + optlen: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + SetSockOpt := ssSetSockOpt (S, Level, OptName, OptVal, OptLen); +end; + +function GetSockOpt (s: TSocket; level, optname: Integer; optval: PAnsiChar; + var optlen: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + GetSockOpt := ssGetSockOpt (S, Level, OptName, OptVal, OptLen); +end; + +function Listen (s: TSocket; backlog: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + Listen := ssListen (S, BackLog); +end; + +function IoctlSocket (s: TSocket; cmd: DWORD; var arg: Integer): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + IOCtlSocket := ssIOCtlSocket (S, Cmd, Arg); +end; + +function CloseSocket (s: TSocket): Integer; +begin + S := TSocket (NativeSocket (cInt (S))); + CloseSocket := ssCloseSocket (S); +end; + +function __WSAFDIsSet (s: TSocket; var FDSet: TFDSet): Bool; +begin + S := TSocket (NativeSocket (cInt (S))); + __WSAFDIsSet := ss__WSAFDIsSet (S, FDSet); +end; + +function WSAIoctl (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer; + cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD; + lpcbBytesReturned: PDWORD; lpOverlapped: Pointer; + lpCompletionRoutine: pointer): u_int; +begin + S := TSocket (NativeSocket (cInt (S))); + WSAIOCtl := ssWSAIOCtl (S, dwIoControlCode, lpvInBuffer, cbInBuffer, + lpvOutBuffer, cbOutBuffer, lpcbBytesReturned, lpOverlapped, + lpCompletionRoutine); +end; +{$ENDIF OS2} + +{=============================================================================} +function IsNewApi(Family: integer): Boolean; +begin + Result := SockEnhancedApi; + if not Result then + Result := (Family = AF_INET6) and SockWship6Api; +end; + +function SetVarSin(var Sin: TVarSin; IP, Port: AnsiString; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +type + pu_long = ^u_long; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + HostEnt: PHostEnt; + r: integer; + Hints1, Hints2: TAddrInfo; + Sin1, Sin2: TVarSin; + TwoPass: boolean; + + function GetAddr(const IP, port: AnsiString; Hints: TAddrInfo; var Sin: TVarSin): integer; + var + Addr: PAddrInfo; + begin + Addr := nil; + try + FillChar(Sin, Sizeof(Sin), 0); + if Hints.ai_socktype = SOCK_RAW then + begin + Hints.ai_socktype := 0; + Hints.ai_protocol := 0; + Result := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + end + else + begin + Result := synsock.GetAddrInfo(PAnsiChar(IP), PAnsiChar(Port), @Hints, Addr); + end; + end; + if Result = 0 then + if (Addr <> nil) then + Move(Addr^.ai_addr^, Sin, Addr^.ai_addrlen); + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + +begin + Result := 0; + FillChar(Sin, Sizeof(Sin), 0); + if not IsNewApi(family) then + begin + SynSockCS.Enter; + try + Sin.sin_family := AF_INET; + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if (ProtoEnt <> nil) and (StrToIntDef(string(Port),-1) =-1) then + ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Sin.sin_port := synsock.htons(StrToIntDef(string(Port), 0)) + else + Sin.sin_port := ServEnt^.s_port; + if IP = cBroadcast then + Sin.sin_addr.s_addr := u_long(INADDR_BROADCAST) + else + begin + Sin.sin_addr.s_addr := synsock.inet_addr(PAnsiChar(IP)); + if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then + begin + HostEnt := synsock.GetHostByName(PAnsiChar(IP)); + Result := synsock.WSAGetLastError; + if HostEnt <> nil then + Sin.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + begin + FillChar(Hints1, Sizeof(Hints1), 0); + FillChar(Hints2, Sizeof(Hints2), 0); + TwoPass := False; + if Family = AF_UNSPEC then + begin + if PreferIP4 then + begin + Hints1.ai_family := AF_INET; + Hints2.ai_family := AF_INET6; + TwoPass := True; + end + else + begin + Hints2.ai_family := AF_INET; + Hints1.ai_family := AF_INET6; + TwoPass := True; + end; + end + else + Hints1.ai_family := Family; + + Hints1.ai_socktype := SockType; + Hints1.ai_protocol := SockProtocol; + Hints2.ai_socktype := Hints1.ai_socktype; + Hints2.ai_protocol := Hints1.ai_protocol; + + r := GetAddr(IP, Port, Hints1, Sin1); + Result := r; + sin := sin1; + if r <> 0 then + if TwoPass then + begin + r := GetAddr(IP, Port, Hints2, Sin2); + Result := r; + if r = 0 then + sin := sin2; + end; + end; +end; + +function GetSinIP(Sin: TVarSin): AnsiString; +var + p: PAnsiChar; + host, serv: AnsiString; + hostlen, servlen: integer; + r: integer; +begin + Result := ''; + if not IsNewApi(Sin.AddressFamily) then + begin + p := synsock.inet_ntoa(Sin.sin_addr); + if p <> nil then + Result := p; + end + else + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(@sin, SizeOfVarSin(sin), PAnsiChar(host), hostlen, + PAnsiChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + Result := PAnsiChar(host); + end; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + if (Sin.sin_family = AF_INET6) then + Result := synsock.ntohs(Sin.sin6_port) + else + Result := synsock.ntohs(Sin.sin_port); +end; + +procedure ResolveNameToIP(Name: AnsiString; Family, SockProtocol, SockType: integer; const IPList: TStrings); +type + TaPInAddr = array[0..250] of PInAddr; + PaPInAddr = ^TaPInAddr; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + AddrNext: PAddrInfo; + r: integer; + host, serv: AnsiString; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IP: u_long; + PAdrPtr: PaPInAddr; + i: Integer; + s: String; + InAddr: TInAddr; +begin + IPList.Clear; + if not IsNewApi(Family) then + begin + IP := synsock.inet_addr(PAnsiChar(Name)); + if IP = u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := synsock.GetHostByName(PAnsiChar(Name)); + if RemoteHost <> nil then + begin + PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); + i := 0; + while PAdrPtr^[i] <> nil do + begin + InAddr := PAdrPtr^[i]^; + s := Format('%d.%d.%d.%d', [InAddr.S_bytes[0], InAddr.S_bytes[1], + InAddr.S_bytes[2], InAddr.S_bytes[3]]); + IPList.Add(s); + Inc(i); + end; + end; + finally + SynSockCS.Leave; + end; + end + else + IPList.Add(string(Name)); + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PAnsiChar(Name), nil, @Hints, Addr); + if r = 0 then + begin + AddrNext := Addr; + while not(AddrNext = nil) do + begin + if not(((Family = AF_INET6) and (AddrNext^.ai_family = AF_INET)) + or ((Family = AF_INET) and (AddrNext^.ai_family = AF_INET6))) then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(AddrNext^.ai_addr, AddrNext^.ai_addrlen, + PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + begin + host := PAnsiChar(host); + IPList.Add(string(host)); + end; + end; + AddrNext := AddrNext^.ai_next; + end; + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; + if IPList.Count = 0 then + IPList.Add(cAnyHost); +end; + +function ResolvePort(Port: AnsiString; Family, SockProtocol, SockType: integer): Word; +var + ProtoEnt: PProtoEnt; + ServEnt: PServEnt; + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; +begin + Result := 0; + if not IsNewApi(Family) then + begin + SynSockCS.Enter; + try + ProtoEnt := synsock.GetProtoByNumber(SockProtocol); + ServEnt := nil; + if ProtoEnt <> nil then + ServEnt := synsock.GetServByName(PAnsiChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Result := StrToIntDef(string(Port), 0) + else + Result := synsock.htons(ServEnt^.s_port); + finally + SynSockCS.Leave; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := Sockprotocol; + Hints.ai_flags := AI_PASSIVE; + r := synsock.GetAddrInfo(nil, PAnsiChar(Port), @Hints, Addr); + if (r = 0) and Assigned(Addr) then + begin + if Addr^.ai_family = AF_INET then + Result := synsock.htons(Addr^.ai_addr^.sin_port); + if Addr^.ai_family = AF_INET6 then + Result := synsock.htons(PSockAddrIn6(Addr^.ai_addr)^.sin6_port); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +function ResolveIPToName(IP: AnsiString; Family, SockProtocol, SockType: integer): AnsiString; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; + host, serv: AnsiString; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: u_long; +begin + Result := IP; + if not IsNewApi(Family) then + begin + IPn := synsock.inet_addr(PAnsiChar(IP)); + if IPn <> u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := GetHostByAddr(@IPn, SizeOf(IPn), AF_INET); + if RemoteHost <> nil then + Result := RemoteHost^.h_name; + finally + SynSockCS.Leave; + end; + end; + end + else + begin + Addr := nil; + try + FillChar(Hints, Sizeof(Hints), 0); + Hints.ai_family := AF_UNSPEC; + Hints.ai_socktype := SockType; + Hints.ai_protocol := SockProtocol; + Hints.ai_flags := 0; + r := synsock.GetAddrInfo(PAnsiChar(IP), nil, @Hints, Addr); + if (r = 0) and Assigned(Addr)then + begin + hostlen := NI_MAXHOST; + servlen := NI_MAXSERV; + setlength(host, hostlen); + setlength(serv, servlen); + r := getnameinfo(Addr^.ai_addr, Addr^.ai_addrlen, + PAnsiChar(host), hostlen, PAnsiChar(serv), servlen, + NI_NUMERICSERV); + if r = 0 then + Result := PAnsiChar(host); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: String): Boolean; +begin + Result := False; + if stack = '' then + stack := DLLStackName; + SynSockCS.Enter; + try + if SynSockCount = 0 then + begin + SockEnhancedApi := False; + SockWship6Api := False; + LibHandle := LoadLibrary(PChar(Stack)); + if LibHandle <> 0 then + begin +{$IFDEF OS2} + ssWSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl'))); + ss__WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet'))); + ssCloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket'))); + ssIoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket'))); +{$ELSE OS2} + WSAIoctl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAIoctl'))); + __WSAFDIsSet := GetProcAddress(LibHandle, PAnsiChar(AnsiString('__WSAFDIsSet'))); + CloseSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('closesocket'))); + IoctlSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ioctlsocket'))); +{$ENDIF OS2} + WSAGetLastError := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAGetLastError'))); + WSAStartup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSAStartup'))); + WSACleanup := GetProcAddress(LibHandle, PAnsiChar(AnsiString('WSACleanup'))); + ssAccept := GetProcAddress(LibHandle, PAnsiChar(AnsiString('accept'))); + ssBind := GetProcAddress(LibHandle, PAnsiChar(AnsiString('bind'))); + ssConnect := GetProcAddress(LibHandle, PAnsiChar(AnsiString('connect'))); + ssGetPeerName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getpeername'))); + ssGetSockName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockname'))); +{$IFDEF OS2} + ssGetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt'))); +{$ELSE OS2} + GetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getsockopt'))); +{$ENDIF OS2} + Htonl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htonl'))); + Htons := GetProcAddress(LibHandle, PAnsiChar(AnsiString('htons'))); + Inet_Addr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_addr'))); + Inet_Ntoa := GetProcAddress(LibHandle, PAnsiChar(AnsiString('inet_ntoa'))); +{$IFDEF OS2} + ssListen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen'))); +{$ELSE OS2} + Listen := GetProcAddress(LibHandle, PAnsiChar(AnsiString('listen'))); +{$ENDIF OS2} + Ntohl := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohl'))); + Ntohs := GetProcAddress(LibHandle, PAnsiChar(AnsiString('ntohs'))); + ssRecv := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recv'))); + ssRecvFrom := GetProcAddress(LibHandle, PAnsiChar(AnsiString('recvfrom'))); + Select := GetProcAddress(LibHandle, PAnsiChar(AnsiString('select'))); + ssSend := GetProcAddress(LibHandle, PAnsiChar(AnsiString('send'))); + ssSendTo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('sendto'))); +{$IFDEF OS2} + ssSetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt'))); + ssShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown'))); + ssSocket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket'))); +{$ELSE OS2} + SetSockOpt := GetProcAddress(LibHandle, PAnsiChar(AnsiString('setsockopt'))); + ShutDown := GetProcAddress(LibHandle, PAnsiChar(AnsiString('shutdown'))); + Socket := GetProcAddress(LibHandle, PAnsiChar(AnsiString('socket'))); +{$ENDIF OS2} + GetHostByAddr := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyaddr'))); + GetHostByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostbyname'))); + GetProtoByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobyname'))); + GetProtoByNumber := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getprotobynumber'))); + GetServByName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyname'))); + GetServByPort := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getservbyport'))); + ssGetHostName := GetProcAddress(LibHandle, PAnsiChar(AnsiString('gethostname'))); + +{$IFNDEF FORCEOLDAPI} + GetAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getaddrinfo'))); + FreeAddrInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('freeaddrinfo'))); + GetNameInfo := GetProcAddress(LibHandle, PAnsiChar(AnsiString('getnameinfo'))); + SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); + if not SockEnhancedApi then + begin + LibWship6Handle := LoadLibrary(PChar(DLLWship6)); + if LibWship6Handle <> 0 then + begin + GetAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getaddrinfo'))); + FreeAddrInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('freeaddrinfo'))); + GetNameInfo := GetProcAddress(LibWship6Handle, PAnsiChar(AnsiString('getnameinfo'))); + SockWship6Api := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo) + and Assigned(GetNameInfo); + end; + end; +{$ENDIF} + Result := True; + end; + end + else Result := True; + if Result then + Inc(SynSockCount); + finally + SynSockCS.Leave; + end; +end; + +function DestroySocketInterface: Boolean; +begin + SynSockCS.Enter; + try + Dec(SynSockCount); + if SynSockCount < 0 then + SynSockCount := 0; + if SynSockCount = 0 then + begin + if LibHandle <> 0 then + begin + FreeLibrary(libHandle); + LibHandle := 0; + end; + if LibWship6Handle <> 0 then + begin + FreeLibrary(LibWship6Handle); + LibWship6Handle := 0; + end; + end; + finally + SynSockCS.Leave; + end; + Result := True; +end; + +initialization +begin + SynSockCS := SyncObjs.TCriticalSection.Create; + SET_IN6_IF_ADDR_ANY (@in6addr_any); + SET_LOOPBACK_ADDR6 (@in6addr_loopback); +end; + +finalization +begin + SynSockCS.Free; +end; \ No newline at end of file diff --git a/synafpc.pas b/synafpc.pas index 4876199..63b5eb2 100644 --- a/synafpc.pas +++ b/synafpc.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.003.000 | +| Project : Ararat Synapse | 001.003.001 | |==============================================================================| | Content: Utils for FreePascal compatibility | |==============================================================================| -| Copyright (c)1999-2012, Lukas Gebauer | +| Copyright (c)1999-2013, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,10 +33,11 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2003-2012. | +| Portions created by Lukas Gebauer are Copyright (c)2003-2013. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | +| Tomas Hajny (OS2 support) | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | @@ -115,7 +116,11 @@ end; function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; begin +{$IFDEF OS2GCC} + Result := dynlibs.GetProcedureAddress(Module, '_' + Proc); +{$ELSE OS2GCC} Result := dynlibs.GetProcedureAddress(Module, Proc); +{$ENDIF OS2GCC} end; function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; diff --git a/synaicnv.pas b/synaicnv.pas index 3dd79c5..8a51db5 100644 --- a/synaicnv.pas +++ b/synaicnv.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.001.001 | +| Project : Ararat Synapse | 001.001.002 | |==============================================================================| -| Content: ICONV support for Win32, Linux and .NET | +| Content: ICONV support for Win32, OS/2, Linux and .NET | |==============================================================================| -| Copyright (c)2004-2010, Lukas Gebauer | +| Copyright (c)2004-2013, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,10 +33,11 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2004-2010. | +| Portions created by Lukas Gebauer are Copyright (c)2004-2013. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | +| Tomas Hajny (OS2 support) | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | @@ -81,7 +82,11 @@ uses const {$IFNDEF MSWINDOWS} + {$IFDEF OS2} + DLLIconvName = 'iconv.dll'; + {$ELSE OS2} DLLIconvName = 'libiconv.so'; + {$ENDIF OS2} {$ELSE} DLLIconvName = 'iconv.dll'; {$ENDIF} diff --git a/synautil.pas b/synautil.pas index a76952a..fcf52bd 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 004.015.002 | +| Project : Ararat Synapse | 004.015.003 | |==============================================================================| | Content: support procedures and functions | |==============================================================================| -| Copyright (c)1999-2012, Lukas Gebauer | +| Copyright (c)1999-2013, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,13 +33,14 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2012. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2013. | | Portions created by Hernan Sanchez are Copyright (c) 2000. | | Portions created by Petr Fejfar are Copyright (c)2011-2012. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | | Hernan Sanchez (hernan.sanchez@iname.com) | +| Tomas Hajny (OS2 support) | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | @@ -66,10 +67,14 @@ interface uses {$IFDEF MSWINDOWS} Windows, -{$ELSE} +{$ELSE MSWINDOWS} {$IFDEF FPC} + {$IFDEF OS2} + Dos, TZUtil, + {$ELSE OS2} UnixUtil, Unix, BaseUnix, - {$ELSE} + {$ENDIF OS2} + {$ELSE FPC} Libc, {$ENDIF} {$ENDIF} @@ -763,21 +768,31 @@ begin st.Millisecond := stw.wMilliseconds; result := SystemTimeToDateTime(st); {$ENDIF} -{$ELSE} +{$ELSE MSWINDOWS} {$IFNDEF FPC} var TV: TTimeVal; begin gettimeofday(TV, nil); Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; -{$ELSE} +{$ELSE FPC} + {$IFDEF UNIX} var TV: TimeVal; begin fpgettimeofday(@TV, nil); Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; -{$ENDIF} -{$ENDIF} + {$ELSE UNIX} + {$IFDEF OS2} +var + ST: TSystemTime; +begin + GetLocalTime (ST); + Result := SystemTimeToDateTime (ST); + {$ENDIF OS2} + {$ENDIF UNIX} +{$ENDIF FPC} +{$ENDIF MSWINDOWS} end; {==============================================================================} @@ -805,7 +820,7 @@ begin stw.wMilliseconds := st.Millisecond; Result := SetSystemTime(stw); {$ENDIF} -{$ELSE} +{$ELSE MSWINDOWS} {$IFNDEF FPC} var TV: TTimeVal; @@ -821,7 +836,8 @@ begin TV.tv_sec := trunc(d); TV.tv_usec := trunc(frac(d) * 1000000); Result := settimeofday(TV, TZ) <> -1; -{$ELSE} +{$ELSE FPC} + {$IFDEF UNIX} var TV: TimeVal; d: double; @@ -830,8 +846,18 @@ begin TV.tv_sec := trunc(d); TV.tv_usec := trunc(frac(d) * 1000000); Result := fpsettimeofday(@TV, nil) <> -1; -{$ENDIF} -{$ENDIF} + {$ELSE UNIX} + {$IFDEF OS2} +var + ST: TSystemTime; +begin + DateTimeToSystemTime (NewDT, ST); + SetTime (ST.Hour, ST.Minute, ST.Second, ST.Millisecond div 10); + Result := true; + {$ENDIF OS2} + {$ENDIF UNIX} +{$ENDIF FPC} +{$ENDIF MSWINDOWS} end; {==============================================================================} diff --git a/synsock.pas b/synsock.pas index 8ed9e5b..4bb2510 100644 --- a/synsock.pas +++ b/synsock.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 005.002.001 | +| Project : Ararat Synapse | 005.002.002 | |==============================================================================| | Content: Socket Independent Platform Layer | |==============================================================================| -| Copyright (c)1999-2011, Lukas Gebauer | +| Copyright (c)1999-2013, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,10 +33,11 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2001-2011. | +| Portions created by Lukas Gebauer are Copyright (c)2001-2013. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | +| Tomas Hajny (OS2 support) | |==============================================================================| | History: see HISTORY.HTM from distribution package | | (Found at URL: http://www.ararat.cz/synapse/) | @@ -65,7 +66,11 @@ unit synsock; {$I sswin32.inc} //not complete yet! {$ELSE} {$IFDEF FPC} + {$IFDEF OS2} + {$I ssos2ws1.inc} + {$ELSE OS2} {$I ssfpc.inc} + {$ENDIF OS2} {$ELSE} {$I sslinux.inc} {$ENDIF} diff --git a/tzutil.pas b/tzutil.pas new file mode 100644 index 0000000..7657f16 --- /dev/null +++ b/tzutil.pas @@ -0,0 +1,702 @@ +//Unit with timezone support for some Freepascal platforms. +//Tomas Hajny + +unit tzutil; + + +interface + +type + DSTSpecType = (DSTMonthWeekDay, DSTMonthDay, DSTJulian, DSTJulianX); + +(* Initialized to default values *) +const + TZName: string = ''; + TZDSTName: string = ''; + TZOffset: longint = 0; + DSTOffset: longint = 0; + DSTStartMonth: byte = 4; + DSTStartWeek: shortint = 1; + DSTStartDay: word = 0; + DSTStartSec: cardinal = 7200; + DSTEndMonth: byte = 10; + DSTEndWeek: shortint = -1; + DSTEndDay: word = 0; + DSTEndSec: cardinal = 10800; + DSTStartSpecType: DSTSpecType = DSTMonthWeekDay; + DSTEndSpecType: DSTSpecType = DSTMonthWeekDay; + +function TZSeconds: longint; +(* Return current offset from UTC in seconds while respecting DST *) + +implementation + +uses + Dos; + +function TZSeconds: longint; +const + MonthDays: array [1..12] of byte = + (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + MonthEnds: array [1..12] of word = + (31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365); +var + Y, Mo, D, WD, H, Mi, S, S100: word; + MS, DS, ME, DE: byte; + L: longint; + Second: cardinal; + AfterDSTStart, BeforeDSTEnd: boolean; + +function LeapDay: byte; +begin + if (Y mod 400 = 0) or (Y mod 100 <> 0) and (Y mod 4 = 0) then + LeapDay := 1 + else + LeapDay := 0; +end; + +function FirstDay (MM: byte): byte; +(* What day of week (0-6) is the first day of month MM? *) +var + DD: longint; +begin + if MM < Mo then + begin + DD := D + MonthEnds [Pred (Mo)]; + if MM > 1 then + Dec (DD, MonthEnds [Pred (MM)]); + if (MM <= 2) and (Mo > 2) then + Inc (DD, LeapDay); + end + else + if MM > Mo then + begin + DD := - MonthDays [Mo] + D - MonthEnds [Pred (MM)] + MonthEnds [Mo]; + if (Mo <= 2) and (MM > 2) then + Dec (DD, LeapDay); + end + else +(* M = MM *) + DD := D; + DD := WD - DD mod 7 + 1; + if DD < 0 then + FirstDay := DD + 7 + else + FirstDay := DD mod 7; +end; + +begin + TZSeconds := TZOffset; + if DSTOffset <> TZOffset then + begin + GetDate (Y, Mo, D, WD); + GetTime (H, Mi, S, S100); + Second := cardinal (H) * 3600 + Mi * 60 + S; + + if (DSTStartSpecType = DSTMonthWeekDay) or (DSTStartSpecType = DSTMonthDay) + then + begin + MS := DSTStartMonth; + if DSTStartSpecType = DSTMonthDay then + DS := DSTStartDay + else + begin + DS := FirstDay (DSTStartMonth); + if (DSTStartWeek >= 1) and (DSTStartWeek <= 4) then + if DSTStartDay < DS then + DS := DSTStartWeek * 7 + DSTStartDay - DS + 1 + else + DS := Pred (DSTStartWeek) * 7 + DSTStartDay - DS + 1 + else +(* Last week in month *) + begin + DS := DS + MonthDays [MS] - 1; + if MS = 2 then + Inc (DS, LeapDay); + DS := DS mod 7; + if DS < DSTStartDay then + DS := DS + 7 - DSTStartDay + else + DS := DS - DSTStartDay; + DS := MonthDays [MS] - DS; + end; + end; + end + else + begin +(* Julian day *) + L := DSTStartDay; + if (DSTStartSpecType = DSTJulian) then +(* 0-based *) + if (L + LeapDay <= 59) then + Inc (L) + else + L := L + 1 - LeapDay; + if L <= 31 then + begin + MS := 1; + DS := L; + end + else + if (L <= 59) or + (DSTStartSpecType = DSTJulian) and (L - LeapDay <= 59) then + begin + MS := 2; + DS := DSTStartDay - 31; + end + else + begin + MS := 3; + while (MS < 12) and (MonthEnds [MS] > L) do + Inc (MS); + DS := L - MonthEnds [Pred (MS)]; + end; + end; + + if (DSTEndSpecType = DSTMonthWeekDay) or (DSTEndSpecType = DSTMonthDay) then + begin + ME := DSTEndMonth; + if DSTEndSpecType = DSTMonthDay then + DE := DSTEndDay + else + begin + DE := FirstDay (DSTEndMonth); + if (DSTEndWeek >= 1) and (DSTEndWeek <= 4) then + if DSTEndDay < DE then + DE := DSTEndWeek * 7 + DSTEndDay - DE + 1 + else + DE := Pred (DSTEndWeek) * 7 + DSTEndDay - DE + 1 + else +(* Last week in month *) + begin + DE := DE + MonthDays [ME] - 1; + if ME = 2 then + Inc (DE, LeapDay); + DE := DE mod 7; + if DE < DSTEndDay then + DE := DE + 7 - DSTEndDay + else + DE := DE - DSTEndDay; + DE := MonthDays [ME] - DE; + end; + end; + end + else + begin +(* Julian day *) + L := DSTEndDay; + if (DSTEndSpecType = DSTJulian) then +(* 0-based *) + if (L + LeapDay <= 59) then + Inc (L) + else + L := L + 1 - LeapDay; + if L <= 31 then + begin + ME := 1; + DE := L; + end + else + if (L <= 59) or + (DSTEndSpecType = DSTJulian) and (L - LeapDay <= 59) then + begin + ME := 2; + DE := DSTEndDay - 31; + end + else + begin + ME := 3; + while (ME < 12) and (MonthEnds [ME] > L) do + Inc (ME); + DE := L - MonthEnds [Pred (ME)]; + end; + end; + + if Mo < MS then + AfterDSTStart := false + else + if Mo > MS then + AfterDSTStart := true + else + if D < DS then + AfterDSTStart := false + else + if D > DS then + AfterDSTStart := true + else + AfterDSTStart := Second > DSTStartSec; + if Mo > ME then + BeforeDSTEnd := false + else + if Mo < ME then + BeforeDSTEnd := true + else + if D > DE then + BeforeDSTEnd := false + else + if D < DE then + BeforeDSTEnd := true + else + BeforeDSTEnd := Second < DSTEndSec; + if AfterDSTStart and BeforeDSTEnd then + TZSeconds := DSTOffset; + end; +end; + +procedure InitTZ; +const + TZEnvName = 'TZ'; + EMXTZEnvName = 'EMXTZ'; +var + TZ, S: string; + I, J: byte; + Err: longint; + GnuFmt: boolean; + ADSTStartMonth: byte; + ADSTStartWeek: shortint; + ADSTStartDay: word; + ADSTStartSec: cardinal; + ADSTEndMonth: byte; + ADSTEndWeek: shortint; + ADSTEndDay: word; + ADSTEndSec: cardinal; + ADSTStartSpecType: DSTSpecType; + ADSTEndSpecType: DSTSpecType; + ADSTChangeSec: cardinal; + + function ParseOffset (OffStr: string): longint; + (* Parse time offset given as [-|+]HH[:MI[:SS]] and return in seconds *) + var + TZShiftHH, TZShiftDir: shortint; + TZShiftMI, TZShiftSS: byte; + N1, N2: byte; + begin + TZShiftHH := 0; + TZShiftMI := 0; + TZShiftSS := 0; + TZShiftDir := 1; + N1 := 1; + while (N1 <= Length (OffStr)) and (OffStr [N1] <> ':') do + Inc (N1); + Val (Copy (OffStr, 1, Pred (N1)), TZShiftHH, Err); + if (Err = 0) and (TZShiftHH >= -24) and (TZShiftHH <= 23) then + begin +(* Normalize the hour offset to -12..11 if necessary *) + if TZShiftHH > 11 then + Dec (TZShiftHH, 24) else + if TZShiftHH < -12 then + Inc (TZShiftHH, 24); + if TZShiftHH < 0 then + TZShiftDir := -1; + if (N1 <= Length (OffStr)) then + begin + N2 := Succ (N1); + while (N2 <= Length (OffStr)) and (OffStr [N2] <> ':') do + Inc (N2); + Val (Copy (OffStr, Succ (N1), N2 - N1), TZShiftMI, Err); + if (Err = 0) and (TZShiftMI <= 59) then + begin + if (N2 <= Length (OffStr)) then + begin + Val (Copy (OffStr, Succ (N2), Length (OffStr) - N2), TZShiftSS, Err); + if (Err <> 0) or (TZShiftSS > 59) then + TZShiftSS := 0; + end + end + else + TZShiftMI := 0; + end; + end + else + TZShiftHH := 0; + ParseOffset := longint (TZShiftHH) * 3600 + + TZShiftDir * (longint (TZShiftMI) * 60 + TZShiftSS); + end; + +begin + TZ := GetEnv (TZEnvName); + if TZ = '' then + TZ := GetEnv (EMXTZEnvName); + if TZ <> '' then + begin + TZ := Upcase (TZ); +(* Timezone name *) + I := 1; + while (I <= Length (TZ)) and (TZ [I] in ['A'..'Z']) do + Inc (I); + TZName := Copy (TZ, 1, Pred (I)); + if I <= Length (TZ) then + begin +(* Timezone shift *) + J := Succ (I); + while (J <= Length (TZ)) and not (TZ [J] in ['A'..'Z']) do + Inc (J); + TZOffset := ParseOffset (Copy (TZ, I, J - I)); +(* DST timezone name *) + I := J; + while (J <= Length (TZ)) and (TZ [J] in ['A'..'Z']) do + Inc (J); + if J > I then + begin + TZDSTName := Copy (TZ, I, J - I); +(* DST timezone name provided; if equal to the standard timezone *) +(* name then DSTOffset is set to be equal to TZOffset by default, *) +(* otherwise it is set to TZOffset - 3600 seconds. *) + if TZDSTName <> TZName then + DSTOffset := -3600 + TZOffset + else + DSTOffset := TZOffset; + end + else + begin + TZDSTName := TZName; +(* No DST timezone name provided => DSTOffset is equal to TZOffset *) + DSTOffset := TZOffset; + end; + if J <= Length (TZ) then + begin +(* Check if DST offset is specified here; *) +(* if not, default value set above is used. *) + if TZ [J] <> ',' then + begin + I := J; + Inc (J); + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + DSTOffset := ParseOffset (Copy (TZ, I, J - I)); + end; + if J < Length (TZ) then + begin + Inc (J); +(* DST switching details *) + case TZ [J] of + 'M': + begin +(* Mmonth.week.dayofweek[/StartHour] *) + ADSTStartSpecType := DSTMonthWeekDay; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTStartMonth, Err); + if (Err > 0) or (ADSTStartMonth > 12) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTStartWeek, Err); + if (Err > 0) or (ADSTStartWeek < 1) or (ADSTStartWeek > 5) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay < 0) or (ADSTStartDay > 6) + or (J >= Length (TZ)) then + Exit; + if TZ [J] = '/' then + begin + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) + then + Exit + else + ADSTStartSec := ADSTStartSec * 3600; + end + else + (* Use the preset default *) + ADSTStartSec := DSTStartSec; + Inc (J); + end; + 'J': + begin +(* Jjulianday[/StartHour] *) + ADSTStartSpecType := DSTJulianX; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in [',', '/']) do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay = 0) or (ADSTStartDay > 365) + or (J >= Length (TZ)) then + Exit; + if TZ [J] = '/' then + begin + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) + then + Exit + else + ADSTStartSec := ADSTStartSec * 3600; + end + else + (* Use the preset default *) + ADSTStartSec := DSTStartSec; + Inc (J); + end + else + begin +(* Check the used format first - GNU libc / GCC / EMX expect *) +(* "NameOffsetDstname[Dstoffset],Start[/StartHour],End[/EndHour]"; *) +(* if more than one comma (',') is found, the following format is assumed: *) +(* "NameOffsetDstname[Dstoffset],StartMonth,StartWeek,StartDay,StartSecond, *) +(* EndMonth,EndWeek,EndDay,EndSecond,DSTDifference". *) + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + S := Copy (TZ, I, J - I); + if J < Length (TZ) then + begin + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + GnuFmt := J > Length (TZ); + end + else + Exit; + if GnuFmt then + begin + ADSTStartSpecType := DSTJulian; + J := Pos ('/', S); + if J = 0 then + begin + Val (S, ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay > 365) then + Exit; + (* Use the preset default *) + ADSTStartSec := DSTStartSec; + end + else + begin + if J = Length (S) then + Exit; + Val (Copy (S, 1, Pred (J)), ADSTStartDay, Err); + if (Err > 0) or (ADSTStartDay > 365) then + Exit; + Val (Copy (S, Succ (J), Length (S) - J), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) then + Exit + else + ADSTStartSec := ADSTStartSec * 3600; + end; + J := I; + end + else + begin + Val (S, ADSTStartMonth, Err); + if (Err > 0) or (ADSTStartMonth > 12) then + Exit; + Val (Copy (TZ, I, J - I), ADSTStartWeek, Err); + if (Err > 0) or (ADSTStartWeek < -1) or (ADSTStartWeek > 5) or + (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartDay, Err); + if (DSTStartWeek = 0) then + begin + if (Err > 0) or (ADSTStartDay < 1) or (ADSTStartDay > 31) + or (ADSTStartDay > 30) and (ADSTStartMonth in [4, 6, 9, 11]) + or (ADSTStartMonth = 2) and (ADSTStartDay > 29) then + Exit; + ADSTStartSpecType := DSTMonthDay; + end + else + begin + if (Err > 0) or (ADSTStartDay < 0) or (ADSTStartDay > 6) then + Exit; + ADSTStartSpecType := DSTMonthWeekDay; + end; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTStartSec, Err); + if (Err > 0) or (ADSTStartSec > 86399) or (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndMonth, Err); + if (Err > 0) or (ADSTEndMonth > 12) or (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndWeek, Err); + if (Err > 0) or (ADSTEndWeek < -1) or (ADSTEndWeek > 5) + or (J >= Length (TZ)) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndDay, Err); + if (DSTEndWeek = 0) then + begin + if (Err > 0) or (ADSTEndDay < 1) or (ADSTEndDay > 31) + or (ADSTEndDay > 30) and (ADSTEndMonth in [4, 6, 9, 11]) + or (ADSTEndMonth = 2) and (ADSTEndDay > 29) then + Exit; + ADSTEndSpecType := DSTMonthDay; + end + else + begin + if (Err > 0) or (ADSTEndDay < 0) or (ADSTEndDay > 6) then + Exit; + ADSTEndSpecType := DSTMonthWeekDay; + end; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> ',') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndSec, Err); + if (Err > 0) or (ADSTEndSec > 86399) or (J >= Length (TZ)) then + Exit; + Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTChangeSec, Err); + if (Err = 0) and (ADSTChangeSec < 86400) then + begin +(* Format complete, all checks successful => accept the parsed values. *) + DSTStartMonth := ADSTStartMonth; + DSTStartWeek := ADSTStartWeek; + DSTStartDay := ADSTStartDay; + DSTStartSec := ADSTStartSec; + DSTEndMonth := ADSTEndMonth; + DSTEndWeek := ADSTEndWeek; + DSTEndDay := ADSTEndDay; + DSTEndSec := ADSTEndSec; + DSTStartSpecType := ADSTStartSpecType; + DSTEndSpecType := ADSTEndSpecType; + DSTOffset := TZOffset - ADSTChangeSec; + end; +(* Parsing finished *) + Exit; + end; + end; + end; +(* GnuFmt - DST end specification *) + if TZ [J] = 'M' then + begin +(* Mmonth.week.dayofweek *) + ADSTEndSpecType := DSTMonthWeekDay; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTEndMonth, Err); + if (Err > 0) or (ADSTEndMonth > 12) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and not (TZ [J] in ['.', ',', '/']) do + Inc (J); + if (J >= Length (TZ)) or (TZ [J] <> '.') then + Exit; + Val (Copy (TZ, I, J - I), ADSTEndWeek, Err); + if (Err > 0) or (ADSTEndWeek < 1) or (ADSTEndWeek > 5) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> '/') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndDay, Err); + if (Err > 0) or (ADSTEndDay < 0) or (ADSTEndDay > 6) then + Exit; + end + else + begin + if TZ [J] = 'J' then + begin +(* Jjulianday *) + if J = Length (TZ) then + Exit; + Inc (J); + ADSTEndSpecType := DSTJulianX + end + else + ADSTEndSpecType := DSTJulian; + if J >= Length (TZ) then + Exit; + Inc (J); + I := J; + while (J <= Length (TZ)) and (TZ [J] <> '/') do + Inc (J); + Val (Copy (TZ, I, J - I), ADSTEndDay, Err); + if (Err > 0) or (ADSTEndDay = 0) and (ADSTEndSpecType = DSTJulianX) + or (ADSTEndDay > 365) then + Exit; + end; + if (J <= Length (TZ)) and (TZ [J] = '/') then + begin + if J = Length (TZ) then + Exit; + Val (Copy (TZ, Succ (J), Length (TZ) - J), ADSTEndSec, Err); + if (Err > 0) or (ADSTEndSec > 86399) then + Exit + else + ADSTEndSec := ADSTEndSec * 3600; + end + else + (* Use the preset default *) + ADSTEndSec := DSTEndSec; + +(* Format complete, all checks successful => accept the parsed values. *) + if ADSTStartSpecType = DSTMonthWeekDay then + begin + DSTStartMonth := ADSTStartMonth; + DSTStartWeek := ADSTStartWeek; + end; + DSTStartDay := ADSTStartDay; + DSTStartSec := ADSTStartSec; + if ADSTStartSpecType = DSTMonthWeekDay then + begin + DSTEndMonth := ADSTEndMonth; + DSTEndWeek := ADSTEndWeek; + end; + DSTEndDay := ADSTEndDay; + DSTEndSec := ADSTEndSec; + DSTStartSpecType := ADSTStartSpecType; + DSTEndSpecType := ADSTEndSpecType; + end; + end + else + DSTOffset := -3600 + TZOffset; + end; + end; +end; + + +begin + InitTZ; +end.