{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All Projects | } { | | } { | Description: Socket connections. | } { | | } { | | } { | Copyright (C) - 2012 - Gerrit Moeller. | } { | | } { | Source code distributed under MIT license. | } { | | } { | See: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} unit GMSockets; interface uses {$IFDEF JEDIAPI}{$IFNDEF FPC}jwaWinType,{$ENDIF}{$ENDIF} GMActiveX, GMStrDef, GMIntf, GMCommon, GMSocketAPI; type TGMSocketAddressFamily = (afUnspecified, afInet4, afINet6, afIPX, afAppleTalk, afNetBios, afIrDA, afBluetooth); TGMIPAddressFamily = afUnspecified .. afINet6; TGMSocketKind = (skRaw, skStream, skDatagram, skReliableDatagram, skSeqencedPacket); TGMSocketProtocol = (spICMP, spIGMP, spRFCOMM, spTCP, spUDP, spICMPv6, spReliableMulticast); TSockOperation = (ioSend, ioReceive, ioAccept); const cBroadcastIPAddr = '255.255.255.255'; //cDfltCheckCanceledIntervalMilliseconds = 300; cLocalHost = 'localhost'; FACILITY_GM_SOCKET = 2011; cStrmSizeUnlimited = -1; type //TGMTlsAttribute = (tsaUseTls); //TGMTlsAttributes = set of TGMTlsAttribute; TGMSocketAddress = class; IGMSocketAddress = interface(IUnknown) ['{EFF4550C-1CA6-4769-BB46-9D6249B08BF9}'] function Obj: TGMSocketAddress; end; IGMSocketIO = interface(IUnknown) ['{0F38ED51-D59B-4917-AE33-F1329E2563DE}'] function SendData(const AData: Pointer; const ADataSize: LongInt): LongInt; stdcall; function ReceiveData(const AData: Pointer; const ADataSize: LongInt): LongInt; stdcall; // function IsDataAvailable: Boolean; stdcall; end; IGMSocket = interface(IGMSocketIO) ['{4D9C657F-8E40-4BD3-80B2-B84644D3FEC4}'] procedure Connect(const AHost: TGMString; const APort: TGMString); stdcall; procedure Connect2(const AAddress: IGMSocketAddress); stdcall; procedure Bind(const APort: TGMString; const AHost: TGMString = ''); stdcall; procedure Bind2(const AAddress: IGMSocketAddress); stdcall; procedure Listen(const AMaxConnectionQueueLen: LongInt = SOMAXCONN); stdcall; procedure AcceptAndTakeOver; stdcall; function Accept: IGMSocket; stdcall; function Socket: TSocket; stdcall; function GetAskCanceled: IUnknown; stdcall; // function Obj: TGMSocket; function LocalAddress: IGMSocketAddress; stdcall; function RemoteAddress: IGMSocketAddress; stdcall; end; IGMCheckNonBlockingErrorCode = interface(IUnknown) ['{0F511780-389A-471C-AA44-1DBA6DFDE0AD}'] function CheckNonBlockingErrorCode(const AIOErrorCode: LongInt; const AOperation: TSockOperation; const ASuccesCodes: array of PtrInt; const ASocketAPIRoutineName: TGMString): TSocket; end; TGMSocketAddress = class(TGMRefCountedObj, IGMSocketAddress, IGMGetText) protected FHost, FResolvedHost, FPort: TGMString; procedure ResolveAddress(const ASocket: IGMSocket; const AHost: TGMString; const APort: TGMString); virtual; abstract; procedure SetupFromData; virtual; abstract; public constructor Create(const ASocket: IGMSocket; const AHost: TGMString; const APort: TGMString; const ARefLifeTime: Boolean = True); reintroduce; overload; virtual; constructor CreateLocal(const ASocket: IGMSocket; const ARefLifeTime: Boolean = True); constructor CreateRemote(const ASocket: IGMSocket; const ARefLifeTime: Boolean = True); // constructor CreateLocal(const ASocket: IGMSocket; const ARefLifeTime: Boolean = True); // constructor CreateRemote(const ASocket: IGMSocket; const ARefLifeTime: Boolean = True); function Obj: TGMSocketAddress; function AddrData: Pointer; virtual; abstract; function AddrDataSize: LongInt; virtual; abstract; function AddrBufferSize: LongInt; virtual; abstract; function GetText: TGMString; virtual; stdcall; abstract; property Host: TGMString read FHost; property ResolvedHost: TGMString read FResolvedHost; property Port: TGMString read FPort; end; TGMSocketAddressClass = class of TGMSocketAddress; PGMIPAddrUnion = ^TGMIPAddrUnion; TGMIPAddrUnion = packed record case AddressFamily: u_short of AF_INET: (IP4Port: u_short; IP4Addr: TInAddr; IP4Zero: array[0..7] of byte); AF_INET6: (IP6Port: u_short; IP6Flowinfo: u_long; IP6Addr: TInAddr6; IP6Scope_id: u_long); end; TGMIPSocketAddress = class(TGMSocketAddress) protected FIPAddress: TGMIPAddrUnion; procedure ResolveAddress(const ASocket: IGMSocket; const AHost: TGMString; const APort: TGMString); override; procedure SetupFromData; override; public constructor CreateFromIPAddress(const AIPAddress: TGMIPAddrUnion; const ARefLifeTime: Boolean = True); function AddrData: Pointer; override; function AddrDataSize: LongInt; override; function AddrBufferSize: LongInt; override; function IPAddress: PGMIPAddrUnion; function GetText: TGMString; override; end; TGMSocket = class(TGMRefCountedObj, IGMSocketIO, IGMSocket, IGMCheckNonBlockingErrorCode) protected //FConnected: Boolean; FCheckCanceledIntervalMilliseconds: LongInt; FBlocking: Boolean; FSocket: TSocket; FAddressFamily: TGMSocketAddressFamily; FSocketKind: TGMSocketKind; FProtocol: TGMSocketProtocol; FLocalAddress, FRemoteAddress: IGMSocketAddress; function SocketAddrCreateClass: TGMSocketAddressClass; virtual; function AcceptConnection: TSocket; procedure CheckCanceled; public FAskCanceled: IGMGetOperationCanceled; constructor Create(const ARefLifeTime: Boolean = True); overload; override; constructor Create(const AAddressFamily: TGMSocketAddressFamily; const ASocketKind: TGMSocketKind; const ASocketProtocol: TGMSocketProtocol; const AAskCanceled: IUnknown = nil; const ASocket: TSocket = INVALID_SOCKET; const ARefLifeTime: Boolean = True); reintroduce; overload; destructor Destroy; override; function GetAskCanceled: IUnknown; stdcall; // function IsDataAvailable: Boolean; stdcall; // function Obj: TGMSocket; // procedure ReleaseReferences; stdcall; function CheckNonBlockingErrorCode(const AIOErrorCode: LongInt; const AOperation: TSockOperation; const ASuccesCodes: array of PtrInt; const ASocketAPIRoutineName: TGMString): TSocket; // procedure Bind(const AHost: TGMString; const APort: LongInt); procedure Connect(const AHost: TGMString; const APort: TGMString); stdcall; procedure Connect2(const AAddress: IGMSocketAddress); stdcall; procedure Bind(const APort: TGMString; const AHost: TGMString = ''); stdcall; procedure Bind2(const AAddress: IGMSocketAddress); stdcall; procedure Listen(const AMaxConnectionQueueLen: LongInt = SOMAXCONN); stdcall; procedure AcceptAndTakeOver; stdcall; function Accept: IGMSocket; stdcall; function SendData(const AData: Pointer; const ADataSize: LongInt): LongInt; stdcall; function ReceiveData(const AData: Pointer; const ADataSize: LongInt): LongInt; stdcall; function LocalAddress: IGMSocketAddress; stdcall; function RemoteAddress: IGMSocketAddress; stdcall; function Socket: TSocket; stdcall; // function SendAnsiStringContents(const AData: AnsiString): LongInt; // function SendStreamContents(const AStream: IStream): LongInt; // property Socket: TSocket read FSocket; property AddressFamily: TGMSocketAddressFamily read FAddressFamily; end; TGMTcpSocket = class(TGMSocket) protected //FPreferIp4: Boolean; function SocketAddrCreateClass: TGMSocketAddressClass; override; public constructor Create(const AIPAdressFamily: TGMIPAddressFamily; //const APreferIp4: Boolean; const AAskCanceled: IUnknown = nil; const ARefLifeTime: Boolean = True); reintroduce; overload; end; IGMSetContentSize = interface(IUnknown) ['{6BC78ADE-B5EA-4AEF-BA76-DD90B3124998}'] function SetReadContentSize(const AValue: Int64): Int64; stdcall; function SetWriteContentSize(const AValue: Int64): Int64; stdcall; end; TGMSocketStream = class(TGMSequentialIStream, IGMSetContentSize) protected FPendingData: AnsiString; FSocket: IGMSocketIO; FReadSize, FReadConsumed, FWriteSize, FWriteUsed: Int64; // <- cannot use FSize because it will be modified in inherited read method procedure InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); override; procedure InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); override; public constructor Create(const ARefLifeTime: Boolean = True); overload; override; constructor Create(const ASocket: IGMSocketIO; const AMode: LongWord = STGM_READ or STGM_WRITE; const AName: UnicodeString = ''; const ARefLifeTime: Boolean = True); reintroduce; overload; function SetReadContentSize(const AValue: Int64): Int64; stdcall; function SetWriteContentSize(const AValue: Int64): Int64; stdcall; //function GetSocket: IGMSocketIO; property Socket: IGMSocketIO read FSocket; end; EGMSocketError = class(EGMException, IGMGetHRCode) protected FErrorCode: LongInt; public constructor SocketError(const ASocketErrorCode: LongInt; const ACaller: TObject; const ACallingName: TGMString); function GetHRCode: HResult; stdcall; end; //procedure InitializeSocketLibrary; function GMIPAddrUnionDataSize(const AIPAddress: TGMIPAddrUnion): LongInt; function BuildSocketErrorMsg(const ASocketErrorCode: LongInt): TGMString; function GMCheckSocketCode(const ASocketErrorCode: LongInt; const ASuccesCodes: array of PtrInt; const ACaller: TObject; const ACallingName: TGMString): LongInt; function GMSocketHrResult(const ASocketerrorCode: LongInt): HResult; function GMIsSocketReConnectErrorCode(const AErrorCode: HResult): Boolean; //function GMTlsAttributesFromLongWord(const AValue: Longword): TGMTlsAttributes; //function GMTlsAttributesToLongWord(const AValue: TGMTlsAttributes): Longword; function GMSetReadContentSize(const AIntf: IUnknown; const ASize: Int64): Int64; function GMSetWriteContentSize(const AIntf: IUnknown; const ASize: Int64): Int64; const cGMSocketAddressFamilies: array [TGMSocketAddressFamily] of LongInt = (AF_UNSPEC, AF_INET, AF_INET6, AF_IPX, AF_APPLETALK, AF_NETBIOS, AF_IRDA, AF_BTH); cGMSocketKinds: array [TGMSocketKind] of LongInt = (SOCK_RAW, SOCK_STREAM, SOCK_DGRAM, SOCK_RDM, SOCK_SEQPACKET); cGMSocketProtocols: array [TGMSocketProtocol] of LongInt = (IPPROTO_ICMP, IPPROTO_IGMP, BTHPROTO_RFCOMM, IPPROTO_TCP, IPPROTO_UDP, IPPROTO_ICMPV6, IPPROTO_RM); var vDfltInetAddrFamily: TGMSocketAddressFamily = afInet4; implementation resourcestring RStrSocketErrorFmt = 'Socket error (%d): %s'; RStrTheSocket = 'The Socket'; RStrInvalidIODirectionFmt = 'Invalid socket I/O direction: %d'; RStrTheAddressArgument = 'The address argument'; RStrHostResolvedToFmt = 'Hostname "%s" resolved to: %s'; RStrConnectingSocketFmt = 'Connecting socket to address: %s'; RStrBindingSocketFmt = 'Binding socket to address: %s'; RStrConnectionAcceptedFrom = 'Connection accepted from: '; RStrSocketConnectionClosed = 'Socket connection closed'; //RStrIPAddressFmt = 'IP4-Address: %d.%d.%d.%d, Port: %d'; //RStrBindToAddrFmt = 'Binding socket to address: %s'; //RStrHostResolvedFmt = 'Host "%s" resolved to: %s'; //RStrConnectToAddrFmt = 'Connecting socket to address: %s'; var vCSSoketLibrary: IGMCriticalSection = nil; vSocketLibInitialized: Boolean = False; { ------------------------- } { ---- Global Routines ---- } { ------------------------- } function GMSocketHrResult(const ASocketerrorCode: LongInt): HResult; begin Result := cCustomHrError or (FACILITY_GM_SOCKET shl 16) or ASocketerrorCode; end; function BuildSocketErrorMsg(const ASocketErrorCode: LongInt): TGMString; begin Result := GMFormat(RStrSocketErrorFmt, [ASocketErrorCode, SocketErrorMsgFromCode(ASocketErrorCode)]); end; function GMCheckSocketCode(const ASocketErrorCode: LongInt; const ASuccesCodes: array of PtrInt; const ACaller: TObject; const ACallingName: TGMString): LongInt; begin if (ASocketErrorCode <> WSANOERROR) and ((Length(ASuccesCodes) <= 0) or not GMIsOneOfIntegers(ASocketErrorCode, ASuccesCodes)) then raise EGMSocketError.SocketError(ASocketErrorCode, ACaller, ACallingName) else Result := ASocketErrorCode; end; function GMIsSocketReConnectErrorCode(const AErrorCode: HResult): Boolean; begin Result := (AErrorCode = GMSocketHrResult(WSAECONNRESET)) or (AErrorCode = GMSocketHrResult(WSAECONNABORTED)); end; procedure EnterSocketLibraryCS; begin if vCSSoketLibrary <> nil then vCSSoketLibrary.EnterCriticalSection; end; procedure LeaveSocketLibraryCS; begin if vCSSoketLibrary <> nil then vCSSoketLibrary.LeaveCriticalSection; end; procedure InitializeSocketLibrary; var WSAStartupData: TWSAData; begin EnterSocketLibraryCS; try if vSocketLibInitialized then Exit; GMCheckSocketCode(WSAStartUp(cWinsockVersion202, WSAStartupData), [], nil, 'InitializeSocketLibrary'); vSocketLibInitialized := True; finally LeaveSocketLibraryCS; end; end; procedure FinalizeSocketLibrary; begin EnterSocketLibraryCS; try if not vSocketLibInitialized then Exit; WSACleanup; vSocketLibInitialized := False; finally LeaveSocketLibraryCS; end; end; //function GMTlsAttributesToLongWord(const AValue: TGMTlsAttributes): Longword; //var i: TGMTlsAttribute; //begin //Result := 0; //for i:=Low(i) to High(i) do if i in AValue then Result := Result or (1 shl Ord(i)); //end; // //function GMTlsAttributesFromLongWord(const AValue: Longword): TGMTlsAttributes; //var i: TGMTlsAttribute; //begin //Result := []; //for i:=Low(i) to High(i) do if AValue and (1 shl Ord(i)) <> 0 then Include(Result, i); //end; function GMSetReadContentSize(const AIntf: IUnknown; const ASize: Int64): Int64; var setSize: IGMSetContentSize; begin if GMQueryInterface(AIntf, IGMSetContentSize, setSize) then Result := setSize.SetReadContentSize(ASize) else Result := -1; end; function GMSetWriteContentSize(const AIntf: IUnknown; const ASize: Int64): Int64; var setSize: IGMSetContentSize; begin if GMQueryInterface(AIntf, IGMSetContentSize, setSize) then Result := setSize.SetWriteContentSize(ASize) else Result := -1; end; function GMIPAddrUnionDataSize(const AIPAddress: TGMIPAddrUnion): LongInt; begin case AIPAddress.AddressFamily of AF_INET: Result := SizeOf(TSockAddrIn); AF_INET6: Result := SizeOf(TSockAddrIn6); else Result := 0; end; end; function IPAddrUnionAsString(const AAddressUnion: TGMIPAddrUnion; const AShowPort: Boolean = True): TGMString; begin case AAddressUnion.AddressFamily of AF_INET: begin Result := GMFormat('%d.%d.%d.%d', // 'IP4-Address: %d.%d.%d.%d', [AAddressUnion.IP4Addr.s_b_Arr.s_bArr[0], AAddressUnion.IP4Addr.s_b_Arr.s_bArr[1], AAddressUnion.IP4Addr.s_b_Arr.s_bArr[2], AAddressUnion.IP4Addr.s_b_Arr.s_bArr[3]]); if AShowPort then Result := Result + GMFormat(', Port: %d', [GMSocketAPI.ntohs(AAddressUnion.IP4Port)]); end; else Result := ''; end; end; function TimeVal(const ASeconds, AMicroSeconds: LongInt): TTimeVal; begin Result.tv_sec := ASeconds; Result.tv_usec := AMicroSeconds; end; function TimeValFromMilliseconds(const AMilliSeconds: LongInt): TTimeVal; begin Result := TimeVal(AMilliSeconds div 1000, (AMilliSeconds mod 1000) * 1000); // <- u-seconds NOT milli-seconds! end; function AssignFDSet(const ASockets: array of TSocket): TFDSet; var i: LongInt; begin //FillByte(Result, SizeOf(Result), 0); //FD_Zero(Result); Result := Default(TFDSet); for i:=Low(ASockets) to High(ASockets) do FD_Set(ASockets[i], Result); end; function AssignIPAddrUnion(var AAddressUnion: TGMIPAddrUnion; const AHost, APort: AnsiString; const AFamily, ASockProtocol, ASockType: LongInt): LongInt; type TPULong = ^u_long; var protoEnt: PProtoEnt; servEnt: PServEnt; hostEnt: PHostEnt; //r: LongInt; //Hints1, Hints2: TAddrInfo; //Sin1, Sin2: TGMIPAddrUnion; //TwoPass: boolean; //function GetAddr(const AHost, APort: AnsiString; Hints: TAddrInfo; var AAddressUnion: TGMIPAddrUnion): LongInt; //var // Addr: PAddrInfo; //begin // Addr := nil; // try // FillByte(AAddressUnion, Sizeof(AAddressUnion), 0); // if Hints.ai_socktype = SOCK_RAW then // begin // Hints.ai_socktype := 0; // Hints.ai_protocol := 0; // Result := synsock.GetAddrInfo(PAnsiChar(AHost), nil, @Hints, Addr); // end // else // begin // if (AHost = cAnyHost) or (AHost = c6AnyHost) then // begin // Hints.ai_flags := AI_PASSIVE; // Result := synsock.GetAddrInfo(nil, PAnsiChar(APort), @Hints, Addr); // end // else // if (AHost = cLocalhost) or (AHost = c6Localhost) then // begin // Result := synsock.GetAddrInfo(nil, PAnsiChar(APort), @Hints, Addr); // end // else // begin // Result := synsock.GetAddrInfo(PAnsiChar(AHost), PAnsiChar(APort), @Hints, Addr); // end; // end; // if Result = 0 then // if (Addr <> nil) then // Move(Addr^.ai_addr^, AAddressUnion, Addr^.ai_addrlen); // finally // if Assigned(Addr) then // synsock.FreeAddrInfo(Addr); // end; //end; begin Result := WSANOERROR; //FillByte(AAddressUnion, Sizeof(AAddressUnion), 0); AAddressUnion := Default(TGMIPAddrUnion); //if not IsNewApi(AFamily) then begin EnterSocketLibraryCS; try AAddressUnion.AddressFamily := AF_INET; protoEnt := GMSocketAPI.GetProtoByNumber(ASockProtocol); servEnt := nil; if (protoEnt <> nil) and (GMStrToInt(GMMakeDezInt(APort, -1)) = -1) then servEnt := GMSocketAPI.GetServByName(PAnsiChar(APort), protoEnt^.p_name); if servEnt = nil then AAddressUnion.IP4Port := GMSocketAPI.htons(GMStrToInt(GMMakeDezInt(APort, 0))) else AAddressUnion.IP4Port := servEnt^.s_port; // if (Length(AHost) = 0) or GMSameText(AHost, cLocalHost) then AAddressUnion.IP4Addr.s_addr := INADDR_ANY // else if AHost = cBroadcastIPAddr then AAddressUnion.IP4Addr.s_addr := INADDR_BROADCAST else begin AAddressUnion.IP4Addr.s_addr := GMSocketAPI.inet_addr(PAnsiChar(AHost)); if AAddressUnion.IP4Addr.s_addr = u_long(INADDR_NONE) then begin hostEnt := GMSocketAPI.GetHostByName(PAnsiChar(AHost)); Result := GMSocketAPI.WSAGetLastError; if hostEnt <> nil then AAddressUnion.IP4Addr.S_addr := u_long(TPULong(hostEnt^.h_addr_list^)^); end; end; finally LeaveSocketLibraryCS; end; end //else //begin // FillByte(Hints1, Sizeof(Hints1), 0); // FillByte(Hints2, Sizeof(Hints2), 0); // TwoPass := False; // if AFamily = 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 := AFamily; // // Hints1.ai_socktype := ASockType; // Hints1.ai_protocol := ASockProtocol; // Hints2.ai_socktype := Hints1.ai_socktype; // Hints2.ai_protocol := Hints1.ai_protocol; // // r := GetAddr(AHost, APort, Hints1, Sin1); // Result := r; // AAddressUnion := sin1; // if r <> 0 then // if TwoPass then // begin // r := GetAddr(AHost, APort, Hints2, Sin2); // Result := r; // if r = 0 then // AAddressUnion := sin2; // end; //end; end; { ------------------------ } { ---- EGMSocketError ---- } { ------------------------ } constructor EGMSocketError.SocketError(const ASocketErrorCode: LongInt; const ACaller: TObject; const ACallingName: TGMString); begin FErrorCode := ASocketErrorCode; ObjError(BuildSocketErrorMsg(ASocketErrorCode), ACaller, ACallingName); end; function EGMSocketError.GetHRCode: HResult; begin Result := GMSocketHrResult(FErrorCode); end; { -------------------------- } { ---- TGMSocketAddress ---- } { -------------------------- } constructor TGMSocketAddress.Create(const ASocket: IGMSocket; const AHost: TGMString; const APort: TGMString; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FHost := AHost; FPort := APort; ResolveAddress(ASocket, AHost, APort); end; constructor TGMSocketAddress.CreateLocal(const ASocket: IGMSocket; const ARefLifeTime: Boolean); var dataSize: LongInt; begin inherited Create(ARefLifeTime); if ASocket <> nil then begin dataSize := AddrBufferSize; if getsockname(ASocket.Socket, AddrData^, dataSize) <> WSANOERROR then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.getsockname'); SetupFromData; end; end; constructor TGMSocketAddress.CreateRemote(const ASocket: IGMSocket; const ARefLifeTime: Boolean); var dataSize: LongInt; begin inherited Create(ARefLifeTime); if ASocket <> nil then begin dataSize := AddrBufferSize; if getpeername(ASocket.Socket, AddrData^, dataSize) <> WSANOERROR then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.getpeername'); SetupFromData; end; end; function TGMSocketAddress.Obj: TGMSocketAddress; begin Result := Self; end; { ---------------------------- } { ---- TGMIPSocketAddress ---- } { ---------------------------- } constructor TGMIPSocketAddress.CreateFromIPAddress(const AIPAddress: TGMIPAddrUnion; const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FIPAddress := AIPAddress; FResolvedHost := IPAddrUnionAsString(FIPAddress, False); end; procedure TGMIPSocketAddress.ResolveAddress(const ASocket: IGMSocket; const AHost: TGMString; const APort: TGMString); //var preferIp4: Boolean; var Socket: TGMSocket; begin GMCheckPointerAssigned(Pointer(ASocket), RStrTheSocket, Self, {$I %CurrentRoutine%}); //preferIp4 := not (ASocket.Obj is TGMTcpSocket) or (ASocket.Obj as TGMTcpSocket).FPreferIp4; Socket := GMObjFromIntf(ASocket) as TGMSocket; GMCheckSocketCode(AssignIPAddrUnion(FIPAddress, AHost, APort, cGMSocketAddressFamilies[Socket.FAddressFamily], cGMSocketKinds[Socket.FSocketKind], cGMSocketProtocols[Socket.FProtocol]), [], Self, {$I %CurrentRoutine%}); // preferIp4 GMTrace(GMFormat(RStrHostResolvedToFmt, [AHost, GetText]), tpSocket); FResolvedHost := IPAddrUnionAsString(FIPAddress, False); end; function TGMIPSocketAddress.GetText: TGMString; begin Result := IPAddrUnionAsString(FIPAddress); end; function TGMIPSocketAddress.AddrData: Pointer; begin Result := @FIPAddress; end; function TGMIPSocketAddress.AddrDataSize: LongInt; begin Result := GMIPAddrUnionDataSize(FIPAddress); end; function TGMIPSocketAddress.IPAddress: PGMIPAddrUnion; begin Result := @FIPAddress; end; function TGMIPSocketAddress.AddrBufferSize: LongInt; begin Result := SizeOf(FIPAddress); end; procedure TGMIPSocketAddress.SetupFromData; begin FResolvedHost := IPAddrUnionAsString(FIPAddress, False); case FIPAddress.AddressFamily of AF_INET: FPort := GMIntToStr(GMSocketAPI.ntohs(FIPAddress.IP4Port)); AF_INET6: FPort := GMIntToStr(GMSocketAPI.ntohs(FIPAddress.IP6Port)); // AF_INET: begin // FResolvedHost := GMFormat('%d.%d.%d.%d', // [FIPAddress.IP4Addr.s_b_Arr.s_bArr[0], FIPAddress.IP4Addr.s_b_Arr.s_bArr[1], // FIPAddress.IP4Addr.s_b_Arr.s_bArr[2], FIPAddress.IP4Addr.s_b_Arr.s_bArr[3]]); // FPort := GMIntToStr(GMSocketAPI.ntohs(FIPAddress.IP4Port)); // end; end; end; { ------------------- } { ---- TGMSocket ---- } { ------------------- } constructor TGMSocket.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FSocket := INVALID_SOCKET; FProtocol := spTCP; FBlocking := True; FCheckCanceledIntervalMilliseconds := cDfltUiResponseMS; end; constructor TGMSocket.Create(const AAddressFamily: TGMSocketAddressFamily; const ASocketKind: TGMSocketKind; const ASocketProtocol: TGMSocketProtocol; const AAskCanceled: IUnknown; const ASocket: TSocket; const ARefLifeTime: Boolean); const cNonBlocking: array [Boolean] of LongInt = (0, 1); var ioCtrlVal: u_long; begin Create(ARefLifeTime); FAddressFamily := AAddressFamily; FSocketKind := ASocketKind; FProtocol := ASocketProtocol; GMQueryInterface(AAskCanceled, IGMGetOperationCanceled, FAskCanceled); FBlocking := FAskCanceled = nil; InitializeSocketLibrary; FSocket := ASocket; if FSocket = INVALID_SOCKET then begin EnterSocketLibraryCS; try FSocket := GMSocketAPI.socket(cGMSocketAddressFamilies[AAddressFamily], cGMSocketKinds[ASocketKind], cGMSocketProtocols[ASocketProtocol]); if FSocket = INVALID_SOCKET then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.socket'); finally LeaveSocketLibraryCS; end; end; ioCtrlVal := cNonBlocking[not FBlocking]; if ioctlsocket(FSocket, FIONBIO, ioCtrlVal) <> WSANOERROR then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.ioctlsocket(FIONBIO)'); end; destructor TGMSocket.Destroy; var closeCode: Integer; begin if FSocket <> INVALID_SOCKET then begin closeCode := GMSocketAPI.closeSocket(FSocket); if closeCode <> WSANOERROR then GMTrace(GMStringJoin('CloseSocket', ': ', SocketErrorMsgFromCode(closeCode)), tpSocket); FSocket := INVALID_SOCKET; GMTrace(GMStringJoin(RStrSocketConnectionClosed, ': ', GMStringJoin(GMGetIntfText(FLocalAddress), ' <--> ', GMGetIntfText(FRemoteAddress))), tpSocket); end; inherited Destroy; end; function TGMSocket.GetAskCanceled: IUnknown; begin Result := FAskCanceled; end; //function TGMSocket.IsDataAvailable: Boolean; //var data: Byte; //begin //Result := GMSocketApi.recv(Socket, data, SizeOf(data), MSG_PEEK) > 0; //end; //procedure TGMSocket.ReleaseReferences; //begin //FAskCanceled := nil; //end; function TGMSocket.Socket: TSocket; begin Result := FSocket; end; //function TGMSocket.Obj: TGMSocket; //begin //Result := Self; //end; function TGMSocket.SocketAddrCreateClass: TGMSocketAddressClass; begin Result := nil; end; procedure TGMSocket.CheckCanceled; begin if (FAskCanceled <> nil) and FAskCanceled.OperationCanceled then raise EGMAbort.Create(RStrOperationCanceled); end; function TGMSocket.CheckNonBlockingErrorCode(const AIOErrorCode: LongInt; const AOperation: TSockOperation; const ASuccesCodes: array of PtrInt; const ASocketAPIRoutineName: TGMString): TSocket; var resultSz, selResult: LongInt; timeOut: TTimeVal; fdData, fdError: TFDSet; begin Result := AIOErrorCode; if Result <> WSAEWOULDBLOCK then GMCheckSocketCode(AIOErrorCode, ASuccesCodes, Self, ASocketAPIRoutineName) else begin timeOut := TimeValFromMilliseconds(FCheckCanceledIntervalMilliseconds); //FillByte(fdData, SizeOf(fdData), 0); //fdData := Default(TFDSet); //FillByte(fdError, SizeOf(fdError), 0); //fdError := Default(TFDSet); repeat fdData := AssignFDSet([FSocket]); fdError := AssignFDSet([FSocket]); case AOperation of ioSend: selResult := GMSocketAPI.select(FSocket+1, nil, @fdData, @fdError, @timeOut); ioReceive, ioAccept: selResult := GMSocketAPI.select(FSocket+1, @fdData, nil, @fdError, @timeOut); else raise EGMException.ObjError(GMFormat(RStrInvalidIODirectionFmt, [Ord(AOperation)]), Self, {$I %CurrentRoutine%}); end; case selResult of 0: CheckCanceled; // <- Timeout occured, continue with loop SOCKET_ERROR: GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.select'); // begin lastErr := WSAGetLastError; Break; end; else if FD_ISSET(FSocket, fdData) then case AOperation of ioAccept: begin Result := AcceptConnection; if Result = INVALID_SOCKET then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.accept'); Break; end; else Result := WSANOERROR; Break; end else if FD_ISSET(FSocket, fdError) then begin resultSz := SizeOf(Result); if getsockopt(FSocket, SOL_SOCKET, SO_ERROR, Pointer(@Result), resultSz) <> WSANOERROR then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.getsockopt'); if Result <> WSANOERROR then GMCheckSocketCode(Result, ASuccesCodes, Self, ASocketAPIRoutineName); Break; end; end; until False; end; end; function TGMSocket.LocalAddress: IGMSocketAddress; begin if FLocalAddress = nil then FLocalAddress := SocketAddrCreateClass.CreateLocal(Self, True); Result := FLocalAddress; end; function TGMSocket.RemoteAddress: IGMSocketAddress; begin if FRemoteAddress = nil then FRemoteAddress := SocketAddrCreateClass.CreateRemote(Self, True); Result := FRemoteAddress; end; procedure TGMSocket.Connect2(const AAddress: IGMSocketAddress); begin GMCheckPointerAssigned(Pointer(AAddress), RStrTheAddressArgument, Self, {$I %CurrentRoutine%}); FRemoteAddress := AAddress; GMTrace(GMFormat(RStrConnectingSocketFmt, [GMGetIntfText(AAddress)]), tpSocket); if GMSocketAPI.connect(FSocket, AAddress.Obj.AddrData^, AAddress.Obj.AddrDataSize) <> WSANOERROR then CheckNonBlockingErrorCode(WSAGetLastError, ioSend, [WSAEISCONN], 'SocketAPI.connect'); //FConnected := True; CheckCanceled; //dataSize := SizeOf(ourAddr); //GMCheckSocketCode(getsockname(FSocket, ourAddr, dataSize), Self, 'Socket.getsockname'); // //dataSize := SizeOf(peerAddr); //GMCheckSocketCode(getpeername(FSocket, peerAddr, dataSize), Self, 'Socket.getpeername'); end; procedure TGMSocket.Connect(const AHost, APort: TGMString); var address: IGMSocketAddress; begin //if FConnected then Exit; GMCheckPointerAssigned(SocketAddrCreateClass, 'SocketAddrCreateClass', Self, {$I %CurrentRoutine%}); address := SocketAddrCreateClass.Create(Self, AHost, APort, True); CheckCanceled; Connect2(address); end; procedure TGMSocket.Bind2(const AAddress: IGMSocketAddress); var port: U_short; dataSize: LongInt; begin GMCheckPointerAssigned(Pointer(AAddress), RStrTheAddressArgument, Self, {$I %CurrentRoutine%}); FLocalAddress := AAddress; if AAddress.Obj is TGMIPSocketAddress then port := GMSocketAPI.ntohs((AAddress.Obj as TGMIPSocketAddress).IPAddress.IP4Port) else port := $FFFF; if GMSocketApi.Bind(Socket, AAddress.Obj.AddrData^, AAddress.Obj.AddrDataSize) <> WSANOERROR then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.Bind'); if port = 0 then // <- let system assign an unused port! begin dataSize := AAddress.Obj.AddrDataSize; if GMSocketApi.getsockname(FSocket, AAddress.Obj.AddrData^, dataSize) <> WSANOERROR then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.getsockname'); end; GMTrace(GMFormat(RStrBindingSocketFmt, [GMGetIntfText(AAddress)]), tpSocket); // <- trace after a system assigned port may have been used CheckCanceled; end; procedure TGMSocket.Bind(const APort, AHost: TGMString); var address: IGMSocketAddress; begin address := SocketAddrCreateClass.Create(Self, AHost, APort); CheckCanceled; Bind2(address); end; procedure TGMSocket.Listen(const AMaxConnectionQueueLen: LongInt); begin if GMSocketApi.Listen(Socket, AMaxConnectionQueueLen) <> WSANOERROR then GMCheckSocketCode(WSAGetLastError, [], Self, 'SocketAPI.Listen'); end; function TGMSocket.AcceptConnection: TSocket; var remoteAddr: IGMSocketAddress; dataSize: LongInt; begin remoteAddr := SocketAddrCreateClass.Create(True); dataSize := remoteAddr.obj.AddrBufferSize; Result := GMSocketApi.accept(FSocket, remoteAddr.obj.AddrData, @dataSize); if Result <> INVALID_SOCKET then begin FRemoteAddress := remoteAddr; GMTrace(RStrConnectionAcceptedFrom + GMGetIntfText(remoteAddr), tpSocket); end; end; procedure TGMSocket.AcceptAndTakeOver; var sock: TSocket; begin sock := AcceptConnection; if sock = INVALID_SOCKET then sock := CheckNonBlockingErrorCode(WSAGetLastError, ioAccept, [], 'SocketAPI.accept'); if FSocket <> INVALID_SOCKET then GMSocketAPI.closeSocket(FSocket); FSocket := sock; end; function TGMSocket.Accept: IGMSocket; var sock: TSocket; begin sock := AcceptConnection; if sock = INVALID_SOCKET then sock := CheckNonBlockingErrorCode(WSAGetLastError, ioAccept, [], 'SocketAPI.accept'); Result := TGMSocket.Create(FAddressFamily, FSocketKind, FProtocol, FAskCanceled, sock, True); end; function TGMSocket.SendData(const AData: Pointer; const ADataSize: LongInt): LongInt; begin repeat Result := GMSocketApi.send(Socket, AData^, ADataSize, 0); if Result = SOCKET_ERROR then CheckNonBlockingErrorCode(WSAGetLastError, ioSend, [], 'SocketAPI.send'); CheckCanceled; until Result <> SOCKET_ERROR; end; function TGMSocket.ReceiveData(const AData: Pointer; const ADataSize: LongInt): LongInt; begin repeat Result := GMSocketApi.recv(Socket, AData^, ADataSize, 0); if Result = SOCKET_ERROR then CheckNonBlockingErrorCode(WSAGetLastError, ioReceive, [], 'SocketAPI.recv'); CheckCanceled; until Result <> SOCKET_ERROR; end; { ---------------------- } { ---- TGMTcpSocket ---- } { ---------------------- } constructor TGMTcpSocket.Create(const AIPAdressFamily: TGMIPAddressFamily; //const APreferIp4: Boolean; const AAskCanceled: IUnknown; const ARefLifeTime: Boolean); begin inherited Create(AIPAdressFamily, skStream, spTCP, AAskCanceled, INVALID_SOCKET, ARefLifeTime); //FPreferIp4 := APreferIp4; end; function TGMTcpSocket.SocketAddrCreateClass: TGMSocketAddressClass; begin Result := TGMIPSocketAddress; end; { ------------------------- } { ---- TGMSocketStream ---- } { ------------------------- } constructor TGMSocketStream.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); FReadSize := cStrmSizeUnlimited; FWriteSize := cStrmSizeUnlimited; end; constructor TGMSocketStream.Create(const ASocket: IGMSocketIO; const AMode: LongWord; const AName: UnicodeString; const ARefLifeTime: Boolean); begin inherited Create(AMode, AName, ARefLifeTime); GMCheckPointerAssigned(Pointer(ASocket), RStrTheSocket, Self, 'Create'); FSocket := ASocket; end; function TGMSocketStream.SetReadContentSize(const AValue: Int64): Int64; stdcall; begin Result := FReadSize; FReadSize := AValue; FReadConsumed := 0; end; function TGMSocketStream.SetWriteContentSize(const AValue: Int64): Int64; stdcall; begin Result := FWriteSize; FWriteSize := AValue; FWriteUsed := 0; end; //function TGMSocketStream.GetSocket: IGMSocketIO; //begin // Result := FSocket; //end; procedure TGMSocketStream.InternalRead(pv: Pointer; cb: LongWord; var pcbRead: LongWord); begin // // When Reading beyond end of data or calling with cb=0 then no further reading for subsequent requests // is possible. A stupid idea, but we have to deal with it. // if FReadSize >= 0 then cb := Min(cb, Max(0, FReadSize - FReadConsumed)); if cb <= 0 then pcbRead := 0 else pcbRead := FSocket.ReceiveData(pv, cb); if FReadSize >= 0 then Inc(FReadConsumed, pcbRead); end; procedure TGMSocketStream.InternalWrite(pv: Pointer; cb: LongWord; var pcbWritten: LongWord); begin if FWriteSize >= 0 then cb := Min(cb, Max(0, FWriteSize - FWriteUsed)); if cb <= 0 then pcbWritten := 0 else pcbWritten := FSocket.SendData(pv, cb); if FWriteSize >= 0 then Inc(FWriteUsed, pcbWritten); end; initialization vCSSoketLibrary := TGMCriticalSection.Create; finalization FinalizeSocketLibrary; end.