diff --git a/blcksock.pas b/blcksock.pas index ab4f4cb..4354752 100644 --- a/blcksock.pas +++ b/blcksock.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 009.000.007 | +| Project : Ararat Synapse | 009.001.003 | |==============================================================================| | Content: Library base | |==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | +| Copyright (c)1999-2006, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)1999-2005. | +| Portions created by Lukas Gebauer are Copyright (c)1999-2006. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -88,16 +88,8 @@ interface uses SysUtils, Classes, -{$IFDEF LINUX} - {$IFDEF FPC} synafpc, - {$ENDIF} - Libc, -{$ENDIF} -{$IFDEF WIN32} - Windows, -{$ENDIF} - synsock, synautil, synacode + synsock, synautil, synacode, synaip {$IFDEF CIL} ,System.Net ,System.Net.Sockets @@ -107,7 +99,7 @@ uses const - SynapseRelease = '36'; + SynapseRelease = '37'; cLocalhost = '127.0.0.1'; cAnyHost = '0.0.0.0'; @@ -119,8 +111,7 @@ const CR = #$0d; LF = #$0a; CRLF = CR + LF; - c64k = 65535; - + c64k = 65536; type @@ -271,9 +262,9 @@ type FNonBlockMode: Boolean; FMaxLineLength: Integer; FMaxSendBandwidth: Integer; - FNextSend: ULong; + FNextSend: LongWord; FMaxRecvBandwidth: Integer; - FNextRecv: ULong; + FNextRecv: LongWord; FConvertLineEnd: Boolean; FLastCR: Boolean; FLastLF: Boolean; @@ -298,10 +289,10 @@ type procedure SetNonBlockMode(Value: Boolean); procedure SetTTL(TTL: integer); function GetTTL:integer; - function IsNewApi: Boolean; procedure SetFamily(Value: TSocketFamily); virtual; procedure SetSocket(Value: TSocket); virtual; function GetWsaData: TWSAData; + function FamilyToAF(f: TSocketFamily): TAddrFamily; protected FSocket: TSocket; FLastError: Integer; @@ -317,9 +308,10 @@ type procedure DoReadFilter(Buffer: TMemory; var Len: Integer); procedure DoMonitor(Writing: Boolean; const Buffer: TMemory; Len: Integer); procedure DoCreateSocket; - procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: ULong); + procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); procedure SetBandwidth(Value: Integer); function TestStopFlag: Boolean; + procedure InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); virtual; public constructor Create; @@ -656,14 +648,6 @@ type it. (It not supported by all socket providers!)} procedure SetRecvTimeout(Timeout: Integer); - {:Convert IPv6 address from their string form to binary. This function - working only on systems with IPv6 support!} - function StrToIP6(const value: string): TSockAddrIn6; - - {:Convert IPv6 address from binary to string form. This function working - only on systems with IPv6 support!} - function IP6ToStr(const value: TSockAddrIn6): string; - {:Return value of socket type.} function GetSocketType: integer; Virtual; @@ -774,8 +758,8 @@ type specify if is used IPv4 (dafault - @true) or IPv6.} property PreferIP4: Boolean read FPreferIP4 Write FPreferIP4; - {:By dafault (@false) is all timeouts used as timeout between two packets in - reading operations. If you set this to @true, then Timeouts is for overall + {:By default (@true) is all timeouts used as timeout between two packets in + reading operations. If you set this to @false, then Timeouts is for overall reading operation!} property InterPacketTimeout: Boolean read FInterPacketTimeout Write FInterPacketTimeout; @@ -1332,9 +1316,9 @@ type TTL: Byte; Protocol: Byte; CheckSum: Word; - SourceIp: DWORD; - DestIp: DWORD; - Options: DWORD; + SourceIp: LongWord; + DestIp: LongWord; + Options: LongWord; end; {:@abstract(Parent class of application protocol implementations.) @@ -1460,11 +1444,16 @@ begin inherited Destroy; end; -function TBlockSocket.IsNewApi: Boolean; +function TBlockSocket.FamilyToAF(f: TSocketFamily): TAddrFamily; begin - Result := SockEnhancedApi; - if not Result then - Result := (FFamily = SF_ip6) and SockWship6Api; + case f of + SF_ip4: + Result := AF_INET; + SF_ip6: + Result := AF_INET6; + else + Result := AF_UNSPEC; + end; end; procedure TBlockSocket.SetDelayedOption(const Value: TSynaOption); @@ -1510,7 +1499,7 @@ begin begin FNonBlockMode := Value.Enabled; x := Ord(FNonBlockMode); - synsock.IoctlSocket(FSocket, FIONBIO, u_long(x)); + synsock.IoctlSocket(FSocket, FIONBIO, x); end; SOT_RecvTimeout: begin @@ -1622,242 +1611,36 @@ begin end; procedure TBlockSocket.SetSin(var Sin: TVarSin; IP, Port: string); -{$IFNDEF CIL} -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: string; 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(PChar(IP), nil, @Hints, Addr); - end - else - begin - if (IP = cAnyHost) or (IP = c6AnyHost) then - begin - Hints.ai_flags := AI_PASSIVE; - Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); - end - else - if (IP = cLocalhost) or (IP = c6Localhost) then - begin - Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); - end - else - begin - Result := synsock.GetAddrInfo(PChar(IP), PChar(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; - + f: TSocketFamily; begin DoStatus(HR_ResolvingBegin, IP + ':' + Port); FLastError := 0; - FillChar(Sin, Sizeof(Sin), 0); - if not IsNewApi then + //if socket exists, then use their type, else use users selection + f := SF_Any; + if (FSocket = INVALID_SOCKET) and (FFamily = SF_any) then begin - SynSockCS.Enter; - try - Sin.sin_family := AF_INET; - ProtoEnt := synsock.GetProtoByNumber(GetSocketProtocol); - ServEnt := nil; - if ProtoEnt <> nil then - ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Sin.sin_port := synsock.htons(StrToIntDef(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(PChar(IP)); - if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then - begin - HostEnt := synsock.GetHostByName(PChar(IP)); - FLastError := 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; + if IsIP(IP) then + f := SF_IP4 + else + if IsIP6(IP) then + f := SF_IP6; end else - begin - FillChar(Hints1, Sizeof(Hints1), 0); - FillChar(Hints2, Sizeof(Hints2), 0); - TwoPass := False; - //if socket exists, then use their type, else use users selection - if FSocket = INVALID_SOCKET then - case FFamily of - SF_Any: - begin - if IsIP(IP) then - Hints1.ai_family := AF_INET - else - if IsIP6(IP) then - Hints1.ai_family := AF_INET6 - else - if FPreferIP4 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; - SF_IP4: - Hints1.ai_family := AF_INET; - SF_IP6: - Hints1.ai_family := AF_INET6; - end - else - if FIP6Used then - Hints1.ai_family := AF_INET6 - else - Hints1.ai_family := AF_INET; - Hints1.ai_socktype := GetSocketType; - Hints1.ai_protocol := GetSocketprotocol; - Hints2.ai_socktype := Hints1.ai_socktype; - Hints2.ai_protocol := Hints1.ai_protocol; - - r := GetAddr(IP, Port, Hints1, Sin1); - FLastError := r; - sin := sin1; - if r <> 0 then - if TwoPass then - begin - r := GetAddr(IP, Port, Hints2, Sin2); - FLastError := r; - if r = 0 then - sin := sin2; - end; - end; -{$ELSE} -var - IPs: array of IPAddress; - n: integer; - ip4, ip6: string; - sip: string; -begin - ip4 := ''; - ip6 := ''; - IPs := Dns.Resolve(IP).AddressList; - for n :=low(IPs) to high(IPs) do begin - if (ip4 = '') and (IPs[n].AddressFamily = AF_INET) then - ip4 := IPs[n].toString; - if (ip6 = '') and (IPs[n].AddressFamily = AF_INET6) then - ip6 := IPs[n].toString; - if (ip4 <> '') and (ip6 <> '') then - break; - end; - if FSocket = INVALID_SOCKET then - case FFamily of - SF_Any: - begin - if (ip4 <> '') and (ip6 <> '') then - begin - if FPreferIP4 then - sip := ip4 - else - Sip := ip6; - end - else - begin - sip := ip4; - if (ip6 <> '') then - sip := ip6; - end; - end; - SF_IP4: - sip := ip4; - SF_IP6: - sip := ip6; - end - else - if FIP6Used then - sip := ip6 - else - sip := ip4; - - sin := TVarSin.Create(IPAddress.Parse(sip), GetPortService(Port)); -{$ENDIF} + f := FFamily; + FLastError := synsock.SetVarSin(sin, ip, port, FamilyToAF(f), + GetSocketprotocol, GetSocketType, FPreferIP4); DoStatus(HR_ResolvingEnd, IP + ':' + Port); end; function TBlockSocket.GetSinIP(Sin: TVarSin): string; -{$IFNDEF CIL} -var - p: PChar; - host, serv: string; - hostlen, servlen: integer; - r: integer; begin - Result := ''; - if not IsNewApi 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), PChar(host), hostlen, - PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - Result := PChar(host); - end; -{$ELSE} -begin - Result := Sin.Address.ToString; -{$ENDIF} + Result := synsock.GetSinIP(sin); end; function TBlockSocket.GetSinPort(Sin: TVarSin): Integer; -{$IFNDEF CIL} begin - if (Sin.sin_family = AF_INET6) then - Result := synsock.ntohs(Sin.sin6_port) - else - Result := synsock.ntohs(Sin.sin_port); -{$ELSE} -begin - Result := Sin.Port; -{$ENDIF} + Result := synsock.GetSinPort(sin); end; procedure TBlockSocket.CreateSocket; @@ -2014,10 +1797,10 @@ begin MaxRecvBandwidth := Value; end; -procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: ULong); +procedure TBlockSocket.LimitBandwidth(Length: Integer; MaxB: integer; var Next: LongWord); var - x: ULong; - y: ULong; + x: LongWord; + y: LongWord; begin if MaxB > 0 then begin @@ -2131,22 +1914,30 @@ begin end; procedure TBlockSocket.SendBlock(const Data: AnsiString); +var + i: integer; begin - SendInteger(Length(data)); - SendString(Data); + i := SwapBytes(Length(data)); + SendString(Codelongint(i) + Data); end; -procedure TBlockSocket.SendStreamRaw(const Stream: TStream); +procedure TBlockSocket.InternalSendStream(const Stream: TStream; WithSize, Indy: boolean); var - si: integer; + si, l: integer; x, y, yr: integer; s: AnsiString; + b: boolean; {$IFDEF CIL} buf: TMemory; {$ENDIF} begin si := Stream.Size - Stream.Position; + if not indy then + l := SwapBytes(si) + else + l := si; x := 0; + b := true; while x < si do begin y := si - x; @@ -2157,6 +1948,11 @@ begin yr := Stream.read(buf, y); if yr > 0 then begin + if WithSize and b then + begin + b := false; + SendString(CodeLongInt(l)); + end; SendBuffer(buf, yr); if FLastError <> 0 then break; @@ -2170,7 +1966,13 @@ begin if yr > 0 then begin SetLength(s, yr); - SendString(s); + if WithSize and b then + begin + b := false; + SendString(CodeLongInt(l) + s); + end + else + SendString(s); if FLastError <> 0 then break; Inc(x, yr); @@ -2181,23 +1983,19 @@ begin end; end; -procedure TBlockSocket.SendStreamIndy(const Stream: TStream); -var - si: integer; +procedure TBlockSocket.SendStreamRaw(const Stream: TStream); begin - si := Stream.Size - Stream.Position; - si := synsock.HToNL(si); - SendInteger(si); - SendStreamRaw(Stream); + InternalSendStream(Stream, false, false); +end; + +procedure TBlockSocket.SendStreamIndy(const Stream: TStream); +begin + InternalSendStream(Stream, true, true); end; procedure TBlockSocket.SendStream(const Stream: TStream); -var - si: integer; begin - si := Stream.Size - Stream.Position; - SendInteger(si); - SendStreamRaw(Stream); + InternalSendStream(Stream, true, false); end; function TBlockSocket.RecvBuffer(Buffer: TMemory; Length: Integer): Integer; @@ -2213,10 +2011,13 @@ begin else SockCheck(Result); ExceptCheck; - Inc(FRecvCounter, Result); - DoStatus(HR_ReadCount, IntToStr(Result)); - DoMonitor(False, Buffer, Result); - DoReadFilter(Buffer, Result); + if Result > 0 then + begin + Inc(FRecvCounter, Result); + DoStatus(HR_ReadCount, IntToStr(Result)); + DoMonitor(False, Buffer, Result); + DoReadFilter(Buffer, Result); + end; end; function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer; @@ -2224,45 +2025,49 @@ function TBlockSocket.RecvBufferEx(Buffer: TMemory; Len: Integer; var s: AnsiString; rl, l: integer; - ti: ULong; + ti: LongWord; {$IFDEF CIL} n: integer; b: TMemory; {$ENDIF} begin FLastError := 0; - rl := 0; - repeat - ti := GetTick; - s := RecvPacket(Timeout); - l := Length(s); - if (rl + l) > Len then - l := Len - rl; - {$IFDEF CIL} - b := BytesOf(s); - for n := 0 to l do - Buffer[rl + n] := b[n]; - {$ELSE} - Move(Pointer(s)^, IncPoint(Buffer, rl)^, l); - {$ENDIF} - rl := rl + l; - if FLastError <> 0 then - Break; - if rl >= Len then - Break; - if not FInterPacketTimeout then - begin - Timeout := Timeout - integer(TickDelta(ti, GetTick)); - if Timeout <= 0 then - begin - FLastError := WSAETIMEDOUT; + Result := 0; + if Len > 0 then + begin + rl := 0; + repeat + ti := GetTick; + s := RecvPacket(Timeout); + l := Length(s); + if (rl + l) > Len then + l := Len - rl; + {$IFDEF CIL} + b := BytesOf(s); + for n := 0 to l do + Buffer[rl + n] := b[n]; + {$ELSE} + Move(Pointer(s)^, IncPoint(Buffer, rl)^, l); + {$ENDIF} + rl := rl + l; + if FLastError <> 0 then Break; + if rl >= Len then + Break; + if not FInterPacketTimeout then + begin + Timeout := Timeout - integer(TickDelta(ti, GetTick)); + if Timeout <= 0 then + begin + FLastError := WSAETIMEDOUT; + Break; + end; end; - end; - until False; - delete(s, 1, l); - FBuffer := s; - Result := rl; + until False; + delete(s, 1, l); + FBuffer := s; + Result := rl; + end; end; function TBlockSocket.RecvBufferStr(Length: Integer; Timeout: Integer): AnsiString; @@ -2312,8 +2117,10 @@ begin end else begin + {$IFDEF WIN32} //not drain CPU on large downloads... Sleep(0); + {$ENDIF} x := WaitingData; if x > 0 then begin @@ -2361,6 +2168,15 @@ begin FLastError := WSAETIMEDOUT; end; end; + if FConvertLineEnd and (Result <> '') then + begin + if FLastCR and (Result[1] = LF) then + Delete(Result, 1, 1); + if FLastLF and (Result[1] = CR) then + Delete(Result, 1, 1); + FLastCR := False; + FLastLF := False; + end; ExceptCheck; end; @@ -2397,7 +2213,7 @@ var CorCRLF: Boolean; t: AnsiString; tl: integer; - ti: ULong; + ti: LongWord; begin FLastError := 0; Result := ''; @@ -2418,12 +2234,6 @@ begin if Length(s) > 0 then if CorCRLF then begin - if FLastCR and (s[1] = LF) then - Delete(s, 1, 1); - if FLastLF and (s[1] = CR) then - Delete(s, 1, 1); - FLastCR := False; - FLastLF := False; t := ''; x := PosCRLF(s, t); tl := Length(t); @@ -2623,8 +2433,10 @@ var x: Integer; begin Result := 0; - if synsock.IoctlSocket(FSocket, FIONREAD, u_long(x)) = 0 then + if synsock.IoctlSocket(FSocket, FIONREAD, x) = 0 then Result := x; + if Result > c64k then + Result := c64k; end; function TBlockSocket.WaitingDataEx: Integer; @@ -2640,7 +2452,11 @@ begin Sleep(1); try while (Length(FBuffer) > 0) or (WaitingData > 0) do + begin RecvPacket(0); + if FLastError <> 0 then + break; + end; except on exception do; end; @@ -2665,116 +2481,13 @@ begin Result := '127.0.0.1'; end; -{$IFDEF CIL} procedure TBlockSocket.ResolveNameToIP(Name: string; const IPList: TStrings); -var - IPs :array of IPAddress; - n: integer; begin IPList.Clear; - IPs := Dns.Resolve(Name).AddressList; - for n := low(IPs) to high(IPs) do - begin - if not(((FFamily = SF_IP6) and (IPs[n].AddressFamily = AF_INET)) - or ((FFamily = SF_IP4) and (IPs[n].AddressFamily = AF_INET6))) then - begin - IPList.Add(IPs[n].toString); - end; - end; -end; - -{$ELSE} -procedure TBlockSocket.ResolveNameToIP(Name: string; const IPList: TStrings); -type - TaPInAddr = array[0..250] of PInAddr; - PaPInAddr = ^TaPInAddr; -var - Hints: TAddrInfo; - Addr: PAddrInfo; - AddrNext: PAddrInfo; - r: integer; - host, serv: string; - hostlen, servlen: integer; - RemoteHost: PHostEnt; - IP: u_long; - PAdrPtr: PaPInAddr; - i: Integer; - s: string; - InAddr: TInAddr; -begin - IPList.Clear; - if not IsNewApi then - begin - IP := synsock.inet_addr(PChar(Name)); - if IP = u_long(INADDR_NONE) then - begin - SynSockCS.Enter; - try - RemoteHost := synsock.GetHostByName(PChar(Name)); - if RemoteHost <> nil then - begin - PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list); - i := 0; - while PAdrPtr^[i] <> nil do - begin - InAddr := PAdrPtr^[i]^; - with InAddr.S_un_b do - s := Format('%d.%d.%d.%d', - [Ord(s_b1), Ord(s_b2), Ord(s_b3), Ord(s_b4)]); - IPList.Add(s); - Inc(i); - end; - end; - finally - SynSockCS.Leave; - end; - end - else - IPList.Add(Name); - end - else - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_UNSPEC; - Hints.ai_socktype := GetSocketType; - Hints.ai_protocol := GetSocketprotocol; - Hints.ai_flags := 0; - r := synsock.GetAddrInfo(PChar(Name), nil, @Hints, Addr); - if r = 0 then - begin - AddrNext := Addr; - while not(AddrNext = nil) do - begin - if not(((FFamily = SF_IP6) and (AddrNext^.ai_family = AF_INET)) - or ((FFamily = SF_IP4) 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, - PChar(host), hostlen, PChar(serv), servlen, - NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - begin - host := PChar(host); - IPList.Add(host); - end; - end; - AddrNext := AddrNext^.ai_next; - end; - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; + synsock.ResolveNameToIP(Name, FamilyToAF(FFamily), GetSocketprotocol, GetSocketType, IPList); if IPList.Count = 0 then IPList.Add(cAnyHost); end; -{$ENDIF} function TBlockSocket.ResolveName(Name: string): string; var @@ -2790,123 +2503,16 @@ begin end; function TBlockSocket.ResolvePort(Port: string): Word; -{$IFDEF CIL} begin - Result := SynSock.GetPortService(Port); + Result := synsock.ResolvePort(Port, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); end; -{$ELSE} -var - ProtoEnt: PProtoEnt; - ServEnt: PServEnt; - Hints: TAddrInfo; - Addr: PAddrInfo; - r: integer; -begin - Result := 0; - if not IsNewApi then - begin - SynSockCS.Enter; - try - ProtoEnt := synsock.GetProtoByNumber(GetSocketProtocol); - ServEnt := nil; - if ProtoEnt <> nil then - ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); - if ServEnt = nil then - Result := StrToIntDef(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 := GetSocketType; - Hints.ai_protocol := GetSocketprotocol; - Hints.ai_flags := AI_PASSIVE; - r := synsock.GetAddrInfo(nil, PChar(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; -{$ENDIF} -{$IFDEF CIL} function TBlockSocket.ResolveIPToName(IP: string): string; begin - Result := Dns.GetHostByAddress(IP).HostName; + if not IsIP(IP) or not IsIp6(IP) then + IP := ResolveName(IP); + Result := synsock.ResolveIPToName(IP, FamilyToAF(FFamily), GetSocketProtocol, GetSocketType); end; -{$ELSE} -function TBlockSocket.ResolveIPToName(IP: string): string; -var - Hints: TAddrInfo; - Addr: PAddrInfo; - r: integer; - host, serv: string; - hostlen, servlen: integer; - RemoteHost: PHostEnt; - IPn: u_long; -begin - Result := IP; - if not IsNewApi then - begin - if not IsIP(IP) then - IP := ResolveName(IP); - IPn := synsock.inet_addr(PChar(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 := GetSocketType; - Hints.ai_protocol := GetSocketprotocol; - Hints.ai_flags := 0; - r := synsock.GetAddrInfo(PChar(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, - PChar(host), hostlen, PChar(serv), servlen, - NI_NUMERICSERV); - if r = 0 then - Result := PChar(host); - end; - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; -end; -{$ENDIF} procedure TBlockSocket.SetRemoteSin(IP, Port: string); begin @@ -3004,7 +2610,7 @@ begin Exit; DoMonitor(True, Buffer, Length); LimitBandwidth(Length, FMaxSendBandwidth, FNextsend); - Result := synsock.SendTo(FSocket, Buffer, Length, 0, FRemoteSin); + Result := synsock.SendTo(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin); SockCheck(Result); ExceptCheck; Inc(FSendCounter, Result); @@ -3017,7 +2623,7 @@ begin if TestStopFlag then Exit; LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv); - Result := synsock.RecvFrom(FSocket, Buffer, Length, 0, FRemoteSin); + Result := synsock.RecvFrom(FSocket, Buffer, Length, MSG_NOSIGNAL, FRemoteSin); SockCheck(Result); ExceptCheck; Inc(FRecvCounter, Result); @@ -3212,107 +2818,6 @@ begin FIP6Used := FRemoteSin.AddressFamily = AF_INET6; end; -{$IFDEF CIL} -function TBlockSocket.StrToIP6(const value: string): TSockAddrIn6; -var - buf: TMemory; - IP: IPAddress; -begin - IP := IPAddress.Parse(Value); - buf := IP.GetAddressBytes; - result.sin6_addr.S_un_b.s_b1 := char(buf[0]); - result.sin6_addr.S_un_b.s_b2 := char(buf[1]); - result.sin6_addr.S_un_b.s_b3 := char(buf[2]); - result.sin6_addr.S_un_b.s_b4 := char(buf[3]); - result.sin6_addr.S_un_b.s_b5 := char(buf[4]); - result.sin6_addr.S_un_b.s_b6 := char(buf[5]); - result.sin6_addr.S_un_b.s_b7 := char(buf[6]); - result.sin6_addr.S_un_b.s_b8 := char(buf[7]); - result.sin6_addr.S_un_b.s_b9 := char(buf[8]); - result.sin6_addr.S_un_b.s_b10 := char(buf[9]); - result.sin6_addr.S_un_b.s_b11 := char(buf[10]); - result.sin6_addr.S_un_b.s_b12 := char(buf[11]); - result.sin6_addr.S_un_b.s_b13 := char(buf[12]); - result.sin6_addr.S_un_b.s_b14 := char(buf[13]); - result.sin6_addr.S_un_b.s_b15 := char(buf[14]); - result.sin6_addr.S_un_b.s_b16 := char(buf[15]); - result.sin6_family := Word(AF_INET6); -end; -{$ELSE} -function TBlockSocket.StrToIP6(const value: string): TSockAddrIn6; -var - addr: PAddrInfo; - hints: TAddrInfo; - r: integer; -begin - FillChar(Result, Sizeof(Result), 0); - if SockEnhancedApi or SockWship6Api then - begin - Addr := nil; - try - FillChar(Hints, Sizeof(Hints), 0); - Hints.ai_family := AF_INET6; - Hints.ai_flags := AI_NUMERICHOST; - r := synsock.GetAddrInfo(PChar(value), nil, @Hints, Addr); - if (r = 0) and Assigned(Addr) then - if (Addr^.ai_family = AF_INET6) then - Move(Addr^.ai_addr^, Result, SizeOf(Result)); - finally - if Assigned(Addr) then - synsock.FreeAddrInfo(Addr); - end; - end; -end; -{$ENDIF} - -{$IFDEF CIL} -function TBlockSocket.IP6ToStr(const value: TSockAddrIn6): string; -var - buf: TMemory; - IP: IPAddress; -begin - setlength(buf, 16); - buf[0] := byte(value.sin6_addr.S_un_b.s_b1); - buf[1] := byte(value.sin6_addr.S_un_b.s_b2); - buf[2] := byte(value.sin6_addr.S_un_b.s_b3); - buf[3] := byte(value.sin6_addr.S_un_b.s_b4); - buf[4] := byte(value.sin6_addr.S_un_b.s_b5); - buf[5] := byte(value.sin6_addr.S_un_b.s_b6); - buf[6] := byte(value.sin6_addr.S_un_b.s_b7); - buf[7] := byte(value.sin6_addr.S_un_b.s_b8); - buf[8] := byte(value.sin6_addr.S_un_b.s_b9); - buf[9] := byte(value.sin6_addr.S_un_b.s_b10); - buf[10] := byte(value.sin6_addr.S_un_b.s_b11); - buf[11] := byte(value.sin6_addr.S_un_b.s_b12); - buf[12] := byte(value.sin6_addr.S_un_b.s_b13); - buf[13] := byte(value.sin6_addr.S_un_b.s_b14); - buf[14] := byte(value.sin6_addr.S_un_b.s_b15); - buf[15] := byte(value.sin6_addr.S_un_b.s_b16); - IP := IPAddress.Create(buf); - Result := IP.ToString; -end; -{$ELSE} -function TBlockSocket.IP6ToStr(const value: TSockAddrIn6): string; -var - host, serv: string; - hostlen, servlen: integer; - r: integer; -begin - Result := ''; - if SockEnhancedApi or SockWship6Api then - begin - hostlen := NI_MAXHOST; - servlen := NI_MAXSERV; - setlength(host, hostlen); - setlength(serv, servlen); - r := getnameinfo(@Value, SizeOf(value), PChar(host), hostlen, - PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); - if r = 0 then - Result := PChar(host); - end; -end; -{$ENDIF} - function TBlockSocket.GetWsaData: TWSAData; begin Result := WsaDataOnce; @@ -3648,8 +3153,8 @@ end; function TSocksBlockSocket.SocksCode(IP, Port: string): string; var - s: string; - ip6: TSockAddrIn6; + ip6: TIp6Bytes; + n: integer; begin if FSocksType <> ST_Socks5 then begin @@ -3678,24 +3183,9 @@ begin if IsIP6(IP) then begin ip6 := StrToIP6(IP); - setlength(s, 16); - s[1] := ip6.sin6_addr.S_un_b.s_b1; - s[2] := ip6.sin6_addr.S_un_b.s_b2; - s[3] := ip6.sin6_addr.S_un_b.s_b3; - s[4] := ip6.sin6_addr.S_un_b.s_b4; - s[5] := ip6.sin6_addr.S_un_b.s_b5; - s[6] := ip6.sin6_addr.S_un_b.s_b6; - s[7] := ip6.sin6_addr.S_un_b.s_b7; - s[8] := ip6.sin6_addr.S_un_b.s_b8; - s[9] := ip6.sin6_addr.S_un_b.s_b9; - s[10] := ip6.sin6_addr.S_un_b.s_b10; - s[11] := ip6.sin6_addr.S_un_b.s_b11; - s[12] := ip6.sin6_addr.S_un_b.s_b12; - s[13] := ip6.sin6_addr.S_un_b.s_b13; - s[14] := ip6.sin6_addr.S_un_b.s_b14; - s[15] := ip6.sin6_addr.S_un_b.s_b15; - s[16] := ip6.sin6_addr.S_un_b.s_b16; - Result := #4 + s; + Result := #4; + for n := 0 to 15 do + Result := Result + char(ip6[n]); end else Result := #3 + char(Length(IP)) + IP; @@ -3708,7 +3198,7 @@ var Atyp: Byte; y, n: integer; w: Word; - ip6: TSockAddrIn6; + ip6: TIp6Bytes; begin FSocksResponsePort := '0'; Result := 0; @@ -3751,26 +3241,8 @@ begin begin if Length(Value) < 22 then Exit; - ip6.sin6_addr.S_un_b.s_b1 := Value[5]; - ip6.sin6_addr.S_un_b.s_b2 := Value[6]; - ip6.sin6_addr.S_un_b.s_b3 := Value[7]; - ip6.sin6_addr.S_un_b.s_b4 := Value[8]; - ip6.sin6_addr.S_un_b.s_b5 := Value[9]; - ip6.sin6_addr.S_un_b.s_b6 := Value[10]; - ip6.sin6_addr.S_un_b.s_b7 := Value[11]; - ip6.sin6_addr.S_un_b.s_b8 := Value[12]; - ip6.sin6_addr.S_un_b.s_b9 := Value[13]; - ip6.sin6_addr.S_un_b.s_b10 := Value[14]; - ip6.sin6_addr.S_un_b.s_b11 := Value[15]; - ip6.sin6_addr.S_un_b.s_b12 := Value[16]; - ip6.sin6_addr.S_un_b.s_b13 := Value[17]; - ip6.sin6_addr.S_un_b.s_b14 := Value[18]; - ip6.sin6_addr.S_un_b.s_b15 := Value[19]; - ip6.sin6_addr.S_un_b.s_b16 := Value[20]; - ip6.sin6_family := word(AF_INET6); - ip6.sin6_port := 0; - ip6.sin6_flowinfo := 0; - ip6.sin6_scope_id := 0; + for n := 0 to 15 do + ip6[n] := ord(Value[n + 5]); FSocksResponseIP := IP6ToStr(ip6); Result := 21; end; @@ -3913,18 +3385,22 @@ procedure TUDPBlockSocket.AddMulticast(MCastIP: string); var Multicast: TIP_mreq; Multicast6: TIPv6_mreq; + n: integer; + ip6: Tip6bytes; begin if FIP6Used then begin - Multicast6.ipv6mr_multiaddr := StrToIp6(MCastIP).sin6_addr; + ip6 := StrToIp6(MCastIP); + for n := 0 to 15 do + Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; Multicast6.ipv6mr_interface := 0; SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_JOIN_GROUP, pchar(@Multicast6), SizeOf(Multicast6))); end else begin - Multicast.imr_multiaddr.S_addr := synsock.inet_addr(PChar(MCastIP)); - Multicast.imr_interface.S_addr := u_long(INADDR_ANY); + Multicast.imr_multiaddr.S_addr := strtoip(MCastIP); + Multicast.imr_interface.S_addr := INADDR_ANY; SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_ADD_MEMBERSHIP, pchar(@Multicast), SizeOf(Multicast))); end; @@ -3935,18 +3411,22 @@ procedure TUDPBlockSocket.DropMulticast(MCastIP: string); var Multicast: TIP_mreq; Multicast6: TIPv6_mreq; + n: integer; + ip6: Tip6bytes; begin if FIP6Used then begin - Multicast6.ipv6mr_multiaddr := StrToIp6(MCastIP).sin6_addr; + ip6 := StrToIp6(MCastIP); + for n := 0 to 15 do + Multicast6.ipv6mr_multiaddr.u6_addr8[n] := Ip6[n]; Multicast6.ipv6mr_interface := 0; SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IPV6, IPV6_LEAVE_GROUP, pchar(@Multicast6), SizeOf(Multicast6))); end else begin - Multicast.imr_multiaddr.S_addr := synsock.inet_addr(PChar(MCastIP)); - Multicast.imr_interface.S_addr := u_long(INADDR_ANY); + Multicast.imr_multiaddr.S_addr := strtoip(MCastIP); + Multicast.imr_interface.S_addr := INADDR_ANY; SockCheck(synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_DROP_MEMBERSHIP, pchar(@Multicast), SizeOf(Multicast))); end; @@ -4038,7 +3518,7 @@ end; function TTCPBlockSocket.WaitingData: Integer; begin Result := 0; - if FSSL.SSLEnabled then + if FSSL.SSLEnabled and (FSocket <> INVALID_SOCKET) then Result := FSSL.WaitingData; if Result = 0 then Result := inherited WaitingData; diff --git a/clamsend.pas b/clamsend.pas new file mode 100644 index 0000000..81dd5f6 --- /dev/null +++ b/clamsend.pas @@ -0,0 +1,218 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: ClamAV-daemon client | +|==============================================================================| +| Copyright (c)2005, 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. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract( ClamAV-daemon client) + +This unit is capable to do antivirus scan of your data by TCP channel to ClamD +daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net) +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$H+} + +unit clamsend; + +interface + +uses + SysUtils, Classes, + synsock, blcksock, synautil; + +const + cClamProtocol = '3310'; + +type + + {:@abstract(Implementation of ClamAV-daemon client protocol) + By this class you can scan any your data by ClamAV opensource antivirus. + + This class can connect to ClamD by TCP channel, send your data to ClamD + and read result.} + TClamSend = class(TSynaClient) + private + FSock: TTCPBlockSocket; + FDSock: TTCPBlockSocket; + FSession: boolean; + function Login: boolean; virtual; + function Logout: Boolean; virtual; + function OpenStream: Boolean; virtual; + public + constructor Create; + destructor Destroy; override; + + {:Call any command to ClamD. Used internally by other methods.} + function DoCommand(const Value: AnsiString): AnsiString; virtual; + + {:Return ClamAV version and version of loaded databases.} + function GetVersion: AnsiString; virtual; + + {:Scan content of TStrings.} + function ScanStrings(const Value: TStrings): AnsiString; virtual; + + {:Scan content of TStream.} + function ScanStream(const Value: TStream): AnsiString; virtual; + published + {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} + property Sock: TTCPBlockSocket read FSock; + + {:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.} + property DSock: TTCPBlockSocket read FDSock; + + {:Can turn-on session mode of communication with ClamD. Default is @false, + because ClamAV developers design their TCP code very badly and session mode + is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs + and this mode will be possible in future.} + property Session: boolean read FSession write FSession; + end; + +implementation + +constructor TClamSend.Create; +begin + inherited Create; + FSock := TTCPBlockSocket.Create; + FDSock := TTCPBlockSocket.Create; + FTimeout := 60000; + FTargetPort := cClamProtocol; + FSession := false; +end; + +destructor TClamSend.Destroy; +begin + Logout; + FDSock.Free; + FSock.Free; + inherited Destroy; +end; + +function TClamSend.DoCommand(const Value: AnsiString): AnsiString; +begin + Result := ''; + if not FSession then + FSock.CloseSocket + else + FSock.SendString(Value + LF); + if not FSession or (FSock.LastError <> 0) then + begin + if Login then + FSock.SendString(Value + LF) + else + Exit; + end; + Result := FSock.RecvTerminated(FTimeout, LF); +end; + +function TClamSend.Login: boolean; +begin + Result := False; + Sock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError <> 0 then + Exit; + FSock.Connect(FTargetHost, FTargetPort); + if FSock.LastError <> 0 then + Exit; + if FSession then + FSock.SendString('SESSION' + LF); + Result := FSock.LastError = 0; +end; + +function TClamSend.Logout: Boolean; +begin + FSock.SendString('END' + LF); + Result := FSock.LastError = 0; + FSock.CloseSocket; +end; + +function TClamSend.GetVersion: AnsiString; +begin + Result := DoCommand('VERSION'); +end; + +function TClamSend.OpenStream: Boolean; +var + S: AnsiString; +begin + Result := False; + s := DoCommand('STREAM'); + if (s <> '') and (Copy(s, 1, 4) = 'PORT') then + begin + s := SeparateRight(s, ' '); + FDSock.CloseSocket; + FDSock.Bind(FIPInterface, cAnyPort); + if FDSock.LastError <> 0 then + Exit; + FDSock.Connect(FTargetHost, s); + if FDSock.LastError <> 0 then + Exit; + Result := True; + end; +end; + +function TClamSend.ScanStrings(const Value: TStrings): AnsiString; +begin + Result := ''; + if OpenStream then + begin + DSock.SendString(Value.Text); + DSock.CloseSocket; + Result := FSock.RecvTerminated(FTimeout, LF); + end; +end; + +function TClamSend.ScanStream(const Value: TStream): AnsiString; +begin + Result := ''; + if OpenStream then + begin + DSock.SendStreamRaw(Value); + DSock.CloseSocket; + Result := FSock.RecvTerminated(FTimeout, LF); + end; +end; + +end. diff --git a/dnssend.pas b/dnssend.pas index 2e21865..16f0cb9 100644 --- a/dnssend.pas +++ b/dnssend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 002.007.000 | +| Project : Ararat Synapse | 002.007.003 | |==============================================================================| | Content: DNS client | |==============================================================================| @@ -60,7 +60,7 @@ interface uses SysUtils, Classes, - blcksock, synautil, synsock; + blcksock, synautil, synaip, synsock; const cDnsProtocol = 'domain'; @@ -120,13 +120,11 @@ type FSock: TUDPBlockSocket; FTCPSock: TTCPBlockSocket; FUseTCP: Boolean; - FAnsferInfo: TStringList; + FAnswerInfo: TStringList; FNameserverInfo: TStringList; FAdditionalInfo: TStringList; FAuthoritative: Boolean; FTruncated: Boolean; - function ReverseIP(Value: AnsiString): AnsiString; - function ReverseIP6(Value: AnsiString): AnsiString; function CompressName(const Value: AnsiString): AnsiString; function CodeHeader: AnsiString; function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; @@ -177,16 +175,16 @@ type 4-not implemented, 5-refused.} property RCode: Integer read FRCode; - {:@True, if ansfer is authoritative.} + {:@True, if answer is authoritative.} property Authoritative: Boolean read FAuthoritative; - {:@True, if ansfer is truncated to 512 bytes.} + {:@True, if answer is truncated to 512 bytes.} property Truncated: Boolean read FTRuncated; {:Detailed informations from name server reply. One record per line. Record have comma delimited entries with type number, TTL and data filelds. This information contains detailed information about query reply.} - property AnsferInfo: TStringList read FAnsferInfo; + property AnswerInfo: TStringList read FAnswerInfo; {:Detailed informations from name server reply. One record per line. Record have comma delimited entries with type number, TTL and data filelds. @@ -218,7 +216,7 @@ begin FUseTCP := False; FTimeout := 10000; FTargetPort := cDnsProtocol; - FAnsferInfo := TStringList.Create; + FAnswerInfo := TStringList.Create; FNameserverInfo := TStringList.Create; FAdditionalInfo := TStringList.Create; Randomize; @@ -226,7 +224,7 @@ end; destructor TDNSSend.Destroy; begin - FAnsferInfo.Free; + FAnswerInfo.Free; FNameserverInfo.Free; FAdditionalInfo.Free; FTCPSock.Free; @@ -234,44 +232,6 @@ begin inherited Destroy; end; -function TDNSSend.ReverseIP(Value: AnsiString): AnsiString; -var - x: Integer; -begin - Result := ''; - repeat - x := LastDelimiter('.', Value); - Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x); - Delete(Value, x, Length(Value) - x + 1); - until x < 1; - if Length(Result) > 0 then - if Result[1] = '.' then - Delete(Result, 1, 1); -end; - -function TDNSSend.ReverseIP6(Value: AnsiString): AnsiString; -var - ip6: TSockAddrIn6; -begin - ip6 := FSock.StrToIP6(Value); - Result := ip6.sin6_addr.S_un_b.s_b16 - + '.' + ip6.sin6_addr.S_un_b.s_b15 - + '.' + ip6.sin6_addr.S_un_b.s_b14 - + '.' + ip6.sin6_addr.S_un_b.s_b13 - + '.' + ip6.sin6_addr.S_un_b.s_b12 - + '.' + ip6.sin6_addr.S_un_b.s_b11 - + '.' + ip6.sin6_addr.S_un_b.s_b10 - + '.' + ip6.sin6_addr.S_un_b.s_b9 - + '.' + ip6.sin6_addr.S_un_b.s_b8 - + '.' + ip6.sin6_addr.S_un_b.s_b7 - + '.' + ip6.sin6_addr.S_un_b.s_b6 - + '.' + ip6.sin6_addr.S_un_b.s_b5 - + '.' + ip6.sin6_addr.S_un_b.s_b4 - + '.' + ip6.sin6_addr.S_un_b.s_b3 - + '.' + ip6.sin6_addr.S_un_b.s_b2 - + '.' + ip6.sin6_addr.S_un_b.s_b1; -end; - function TDNSSend.CompressName(const Value: AnsiString): AnsiString; var n: Integer; @@ -363,7 +323,7 @@ var RType, Len, j, x, y, z, n: Integer; R: AnsiString; t1, t2, ttl: integer; - ip6: TSockAddrIn6; + ip6: TIp6bytes; begin Result := ''; R := ''; @@ -393,28 +353,9 @@ begin end; QTYPE_AAAA: begin -// FillChar(ip6, SizeOf(ip6), 0); - ip6.sin6_addr.S_un_b.s_b1 := Char(FBuffer[j]); - ip6.sin6_addr.S_un_b.s_b2 := Char(FBuffer[j + 1]); - ip6.sin6_addr.S_un_b.s_b3 := Char(FBuffer[j + 2]); - ip6.sin6_addr.S_un_b.s_b4 := Char(FBuffer[j + 3]); - ip6.sin6_addr.S_un_b.s_b5 := Char(FBuffer[j + 4]); - ip6.sin6_addr.S_un_b.s_b6 := Char(FBuffer[j + 5]); - ip6.sin6_addr.S_un_b.s_b7 := Char(FBuffer[j + 6]); - ip6.sin6_addr.S_un_b.s_b8 := Char(FBuffer[j + 7]); - ip6.sin6_addr.S_un_b.s_b9 := Char(FBuffer[j + 8]); - ip6.sin6_addr.S_un_b.s_b10 := Char(FBuffer[j + 9]); - ip6.sin6_addr.S_un_b.s_b11 := Char(FBuffer[j + 10]); - ip6.sin6_addr.S_un_b.s_b12 := Char(FBuffer[j + 11]); - ip6.sin6_addr.S_un_b.s_b13 := Char(FBuffer[j + 12]); - ip6.sin6_addr.S_un_b.s_b14 := Char(FBuffer[j + 13]); - ip6.sin6_addr.S_un_b.s_b15 := Char(FBuffer[j + 14]); - ip6.sin6_addr.S_un_b.s_b16 := Char(FBuffer[j + 15]); - ip6.sin6_family := word(AF_INET6); - ip6.sin6_port := 0; - ip6.sin6_flowinfo := 0; - ip6.sin6_scope_id := 0; - R := FSock.IP6ToStr(ip6); + for n := 0 to 15 do + ip6[n] := ord(FBuffer[j + n]); + R := IP6ToStr(ip6); end; QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB, QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP, @@ -514,7 +455,7 @@ var begin Result := False; Reply.Clear; - FAnsferInfo.Clear; + FAnswerInfo.Clear; FNameserverInfo.Clear; FAdditionalInfo.Clear; FAuthoritative := False; @@ -542,7 +483,7 @@ begin if (ancount > 0) and (Length(Buf) > i) then // decode reply for n := 1 to ancount do begin - s := DecodeResource(i, FAnsferInfo, QType); + s := DecodeResource(i, FAnswerInfo, QType); if s <> '' then Reply.Add(s); end; @@ -588,11 +529,11 @@ begin try repeat b := DecodeResponse(FBuffer, Reply, QType); - if (t.Count > 1) and (AnsferInfo.Count > 0) then //find end of transfer - b := b and (t[0] <> AnsferInfo[AnsferInfo.count - 1]); + if (t.Count > 1) and (AnswerInfo.Count > 0) then //find end of transfer + b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]); if b then begin - t.AddStrings(AnsferInfo); + t.AddStrings(AnswerInfo); FBuffer := RecvTCPResponse(WorkSock); if FBuffer = '' then Break; diff --git a/ftpsend.pas b/ftpsend.pas index 1c1ff1c..2ec6f7f 100644 --- a/ftpsend.pas +++ b/ftpsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 003.004.005 | +| Project : Ararat Synapse | 003.004.008 | |==============================================================================| | Content: FTP client | |==============================================================================| @@ -59,7 +59,7 @@ interface uses SysUtils, Classes, - blcksock, synautil, synsock; + blcksock, synautil, synaip, synsock; const cFtpProtocol = 'ftp'; @@ -1220,6 +1220,7 @@ begin //VMS FMasks.add('v*$ DD TTT YYYY hh mm'); FMasks.add('v*$!DD TTT YYYY hh mm'); + FMasks.add('n*$ YYYY MM DD hh mm$S*'); //AS400 FMasks.add('!S*$MM DD YY hh mm ss !n*'); FMasks.add('!S*$DD MM YY hh mm ss !n*'); @@ -1246,7 +1247,7 @@ begin //tandem FMasks.add('nnnnnnnn SSSSSSS DD TTT YY hh mm ss'); //MVS - FMasks.add('- YYYY MM DD SSSSS d=O n*'); + FMasks.add('- YYYY MM DD SSSSS d=O n*'); //BullGCOS8 FMasks.add(' $S* MM DD YY hh mm ss !n*'); FMasks.add('d $S* MM DD YY !n*'); @@ -1738,14 +1739,14 @@ begin if Value[1] = '+' then begin os := Value; + Delete(Value, 1, 1); flr := TFTPListRec.create; + flr.FileName := SeparateRight(Value, #9); s := Fetch(Value, ','); while s <> '' do begin if s[1] = #9 then - begin - flr.FileName := Copy(s, 2, Length(s) - 1); - end; + Break; case s[1] of '/': flr.Directory := true; diff --git a/httpsend.pas b/httpsend.pas index 2e9e937..b23812d 100644 --- a/httpsend.pas +++ b/httpsend.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 003.010.001 | +| Project : Ararat Synapse | 003.010.005 | |==============================================================================| | Content: HTTP client | |==============================================================================| -| Copyright (c)1999-2005, Lukas Gebauer | +| Copyright (c)1999-2006, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2005. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2006. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -58,7 +58,7 @@ interface uses SysUtils, Classes, - blcksock, synautil, synacode; + blcksock, synautil, synaip, synacode, synsock; const cHttpProtocol = '80'; @@ -97,6 +97,9 @@ type function ReadIdentity(Size: Integer): Boolean; function ReadChunked: Boolean; procedure ParseCookies; + function PrepareHeaders: string; + function InternalDoConnect(needssl: Boolean): Boolean; + function InternalConnect(needssl: Boolean): Boolean; public constructor Create; destructor Destroy; override; @@ -302,6 +305,51 @@ begin FResultString := ''; end; +function THTTPSend.PrepareHeaders: string; +begin + if FProtocol = '0.9' then + Result := FHeaders[0] + CRLF + else +{$IFNDEF WIN32} + Result := AdjustLineBreaks(FHeaders.Text, tlbsCRLF); +{$ELSE} + Result := FHeaders.Text; +{$ENDIF} +end; + +function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean; +begin + Result := False; + FSock.CloseSocket; + FSock.Bind(FIPInterface, cAnyPort); + if FSock.LastError <> 0 then + Exit; + FSock.Connect(FTargetHost, FTargetPort); + if FSock.LastError <> 0 then + Exit; + if needssl then + begin + FSock.SSLDoConnect; + if FSock.LastError <> 0 then + Exit; + end; + FAliveHost := FTargetHost; + FAlivePort := FTargetPort; + Result := True; +end; + +function THTTPSend.InternalConnect(needssl: Boolean): Boolean; +begin + if FSock.Socket = INVALID_SOCKET then + Result := InternalDoConnect(needssl) + else + if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort) + or FSock.CanRead(0) then + Result := InternalDoConnect(needssl) + else + Result := True; +end; + function THTTPSend.HTTPMethod(const Method, URL: string): Boolean; var Sending, Receiving: Boolean; @@ -344,14 +392,14 @@ begin FSock.HTTPTunnelPass := ''; end; - Sending := Document.Size > 0; + Sending := FDocument.Size > 0; {Headers for Sending data} status100 := FStatus100 and Sending and (FProtocol = '1.1'); if status100 then FHeaders.Insert(0, 'Expect: 100-continue'); - FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size)); if Sending then begin + FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size)); if FMimeType <> '' then FHeaders.Insert(0, 'Content-Type: ' + FMimeType); end; @@ -415,91 +463,68 @@ begin FHeaders.Add(''); { connect } - if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort) then + if not InternalConnect(UpperCase(Prot) = 'HTTPS') then begin FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError <> 0 then - Exit; - if FSock.LastError <> 0 then - Exit; - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError <> 0 then - Exit; - if UpperCase(Prot) = 'HTTPS' then - FSock.SSLDoConnect; - if FSock.LastError <> 0 then - Exit; - FAliveHost := FTargetHost; - FAlivePort := FTargetPort; - end - else - begin - if FSock.CanRead(0) then - begin - FSock.CloseSocket; - FSock.Bind(FIPInterface, cAnyPort); - if FSock.LastError <> 0 then - Exit; - if FSock.LastError <> 0 then - Exit; - FSock.Connect(FTargetHost, FTargetPort); - if FSock.LastError = 0 then - if UpperCase(Prot) = 'HTTPS' then - FSock.SSLDoConnect; - if FSock.LastError <> 0 then - begin - FSock.CloseSocket; - FAliveHost := ''; - FAlivePort := ''; - Exit; - end; - end; + FAliveHost := ''; + FAlivePort := ''; + Exit; end; - { send Headers } - if FProtocol = '0.9' then - FSock.SendString(FHeaders[0] + CRLF) - else -{$IFDEF LINUX} - FSock.SendString(AdjustLineBreaks(FHeaders.Text, tlbsCRLF)); -{$ELSE} - FSock.SendString(FHeaders.Text); -{$ENDIF} - if FSock.LastError <> 0 then - Exit; - { reading Status } + FDocument.Position := 0; Status100Error := ''; if status100 then begin + { send Headers } + FSock.SendString(PrepareHeaders); + if FSock.LastError <> 0 then + Exit; repeat s := FSock.RecvString(FTimeout); if s <> '' then Break; until FSock.LastError <> 0; DecodeStatus(s); + Status100Error := s; + repeat + s := FSock.recvstring(FTimeout); + if s = '' then + Break; + until FSock.LastError <> 0; if (FResultCode >= 100) and (FResultCode < 200) then - repeat - s := FSock.recvstring(FTimeout); - if s = '' then - Break; - until FSock.LastError <> 0 + begin + { we can upload content } + Status100Error := ''; + FUploadSize := FDocument.Size; + FSock.SendBuffer(FDocument.Memory, FDocument.Size); + end; + end + else + { upload content } + if sending then + begin + if FDocument.Size >= c64k then + begin + FSock.SendString(PrepareHeaders); + FUploadSize := FDocument.Size; + FSock.SendBuffer(FDocument.Memory, FDocument.Size); + end + else + begin + s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size); + FUploadSize := Length(s); + FSock.SendString(s); + end; + end else begin - Sending := False; - Status100Error := s; + { we not need to upload document, send headers only } + FSock.SendString(PrepareHeaders); end; - end; - { send document } - if Sending then - begin - FUploadSize := FDocument.Size; - FSock.SendBuffer(FDocument.Memory, FDocument.Size); - if FSock.LastError <> 0 then - Exit; - end; + if FSock.LastError <> 0 then + Exit; Clear; Size := -1; @@ -556,6 +581,8 @@ begin ToClose := True; until FSock.LastError <> 0; Result := FSock.LastError = 0; + if not Result then + Exit; {if need receive response body, read it} Receiving := Method <> 'HEAD'; @@ -590,7 +617,7 @@ begin if FSock.LastError = 0 then WriteStrToStream(FDocument, s); until FSock.LastError <> 0; - Result := True; + Result := FSock.LastError = WSAECONNRESET; end; function THTTPSend.ReadIdentity(Size: Integer): Boolean; diff --git a/ldapsend.pas b/ldapsend.pas index efac6b6..2b6532d 100644 --- a/ldapsend.pas +++ b/ldapsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.004.000 | +| Project : Ararat Synapse | 001.004.001 | |==============================================================================| | Content: LDAP client | |==============================================================================| @@ -344,7 +344,9 @@ var begin s := Value; if FIsbinary then - s := EncodeBase64(Value); + s := EncodeBase64(Value) + else + s :=UnquoteStr(s, '"'); inherited Put(Index, s); end; @@ -1091,7 +1093,7 @@ begin while n < i do begin u := ASNItem(n, t, x); - a.Add(UnquoteStr(u, '"')); + a.Add(u); end; end; end; diff --git a/mimepart.pas b/mimepart.pas index f3e91a3..9aad90e 100644 --- a/mimepart.pas +++ b/mimepart.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 002.007.002 | +| Project : Ararat Synapse | 002.007.005 | |==============================================================================| | Content: MIME support procedures and functions | |==============================================================================| @@ -61,13 +61,7 @@ interface uses SysUtils, Classes, -{$IFDEF LINUX} - {$IFDEF FPC} synafpc, - {$ENDIF} -{$ELSE} - Windows, -{$ENDIF} synachar, synacode, synautil, mimeinln; type @@ -542,6 +536,7 @@ begin Result.DefaultCharset := FDefaultCharset; FSubParts.Add(Result); Result.SubLevel := FSubLevel + 1; + Result.MaxSubLevel := FMaxSubLevel; end; {==============================================================================} @@ -762,12 +757,16 @@ begin if FConvertCharset and (FPrimaryCode = MP_TEXT) then if (not FForcedHTMLConvert) and (uppercase(FSecondary) = 'HTML') then begin + b := false; t := uppercase(s); t := SeparateLeft(t, ''); - t := SeparateRight(t, ''); - t := ReplaceString(t, '"', ''); - t := ReplaceString(t, ' ', ''); - b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; + if length(t) <> length(s) then + begin + t := SeparateRight(t, ''); + t := ReplaceString(t, '"', ''); + t := ReplaceString(t, ' ', ''); + b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0; + end; if not b then s := CharsetConversion(s, FCharsetCode, FTargetCharset); end diff --git a/pingsend.pas b/pingsend.pas index 2ab07c3..5e88fc8 100644 --- a/pingsend.pas +++ b/pingsend.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 003.001.006 | +| Project : Ararat Synapse | 003.001.008 | |==============================================================================| | Content: PING sender | |==============================================================================| @@ -59,16 +59,15 @@ Note: IPv6 not working under .NET. It is lack of Microsoft's .NET framework. {$R-} {$H+} +{$IFDEF CIL} + Sorry, this unit is not for .NET! +{$ENDIF} + unit pingsend; interface uses -{$IFDEF LINUX} - Libc, -{$ELSE} - Windows, -{$ENDIF} SysUtils, synsock, blcksock, synautil; @@ -91,7 +90,7 @@ type i_checkSum: Word; i_Id: Word; i_seq: Word; - TimeStamp: ULong; + TimeStamp: integer; end; {:record used internally by TPingSend for compute checksum of ICMPv6 packet @@ -274,7 +273,7 @@ begin break; if fSock.IP6used then begin -{$IFDEF LINUX} +{$IFNDEF WIN32} IcmpEchoHeaderPtr := Pointer(FBuffer); {$ELSE} //WinXP SP1 with networking update doing this think by another way ;-O @@ -289,6 +288,12 @@ begin IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4; IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1]; end; + //check for timeout + if TickDelta(x, GetTick) > FTimeout then + begin + t := false; + Break; + end; //it discard sometimes possible 'echoes' of previosly sended packet //or other unwanted ICMP packets... until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho) @@ -307,7 +312,7 @@ end; function TPINGSend.Checksum(Value: string): Word; var - CkSum: DWORD; + CkSum: integer; Num, Remain: Integer; n, i: Integer; begin @@ -341,9 +346,8 @@ var ip6: TSockAddrIn6; x: integer; begin -{$IFDEF LINUX} Result := 0; -{$ELSE} +{$IFDEF WIN32} s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value; ICMP6Ptr := Pointer(s); x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY, diff --git a/pop3send.pas b/pop3send.pas index 33d35b9..790b921 100644 --- a/pop3send.pas +++ b/pop3send.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 002.004.000 | +| Project : Ararat Synapse | 002.005.000 | |==============================================================================| | Content: POP3 client | |==============================================================================| @@ -84,6 +84,7 @@ type FFullResult: TStringList; FStatCount: Integer; FStatSize: Integer; + FListSize: Integer; FTimeStamp: string; FAuthType: TPOP3AuthType; FPOP3cap: TStringList; @@ -125,6 +126,10 @@ type @link(FullResult). If all OK, result is @true.} function Retr(Value: Integer): Boolean; + {:Send RETR command. After successful operation dowloaded message in + @link(Stream). If all OK, result is @true.} + function RetrStream(Value: Integer; Stream: TStream): Boolean; + {:Send DELE command for delete specified message. If all OK, result is @true.} function Dele(Value: Integer): Boolean; @@ -161,6 +166,9 @@ type {:After STAT command is there size of all messages in inbox.} property StatSize: Integer read FStatSize; + {:After LIST 0 command size of all messages on server, After LIST x size of message x on server} + property ListSize: Integer read FListSize; + {:If server support this, after comnnect is in this property timestamp of remote server.} property TimeStamp: string read FTimeStamp; @@ -195,6 +203,7 @@ begin FTargetPort := cPop3Protocol; FStatCount := 0; FStatSize := 0; + FListSize := 0; FAuthType := POP3AuthAll; FAutoTLS := False; FFullSSL := False; @@ -351,12 +360,25 @@ begin end; function TPOP3Send.List(Value: Integer): Boolean; +var + s: string; + n: integer; begin if Value = 0 then FSock.SendString('LIST' + CRLF) else FSock.SendString('LIST ' + IntToStr(Value) + CRLF); Result := ReadResult(Value = 0) = 1; + FListSize := 0; + if Result then + if Value <> 0 then + begin + s := SeparateRight(ResultString, '+OK '); + FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); + end + else + for n := 0 to FFullResult.Count - 1 do + FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); end; function TPOP3Send.Retr(Value: Integer): Boolean; @@ -365,6 +387,40 @@ begin Result := ReadResult(True) = 1; end; +//based on code by Miha Vrhovnik +function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean; +var + s: string; +begin + Result := False; + FFullResult.Clear; + Stream.Size := 0; + FSock.SendString('RETR ' + IntToStr(Value) + CRLF); + + s := FSock.RecvString(FTimeout); + if Pos('+OK', s) = 1 then + Result := True; + FResultString := s; + if Result then begin + repeat + s := FSock.RecvString(FTimeout); + if s = '.' then + Break; + if s <> '' then begin + if s[1] = '.' then + Delete(s, 1, 1); + end; + WriteStrToStream(Stream, s); + WriteStrToStream(Stream, CRLF); + until FSock.LastError <> 0; + end; + + if Result then + FResultCode := 1 + else + FResultCode := 0; +end; + function TPOP3Send.Dele(Value: Integer): Boolean; begin FSock.SendString('DELE ' + IntToStr(Value) + CRLF); diff --git a/snmpsend.pas b/snmpsend.pas index fc39c9b..e5c2939 100644 --- a/snmpsend.pas +++ b/snmpsend.pas @@ -62,7 +62,7 @@ interface uses Classes, SysUtils, - blcksock, synautil, asn1util, synacode; + blcksock, synautil, asn1util, synaip, synacode; const cSnmpProtocol = '161'; diff --git a/ssdotnet.pas b/ssdotnet.pas index 799ea28..8a54cd8 100644 --- a/ssdotnet.pas +++ b/ssdotnet.pas @@ -49,7 +49,7 @@ interface uses - SyncObjs, SysUtils, + SyncObjs, SysUtils, Classes, System.Net, System.Net.Sockets; @@ -73,6 +73,7 @@ type TMemory = Array of byte; TLinger = LingerOption; TSocket = socket; + TAddrFamily = AddressFamily; const WSADESCRIPTION_LEN = 256; @@ -89,33 +90,10 @@ type // lpVendorInfo: PChar; end; - SunB6 = packed record - s_b1, s_b2, s_b3, s_b4, - s_b5, s_b6, s_b7, s_b8, - s_b9, s_b10, s_b11, s_b12, - s_b13, s_b14, s_b15, s_b16: u_char; - end; - - S6_Bytes = SunB6; - S6_Addr = SunB6; - - TInAddr6 = packed record - S_un_b: SunB6; - end; - - TSockAddrIn6 = packed 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; - - const MSG_NOSIGNAL = 0; INVALID_SOCKET = nil; + AF_UNSPEC = AddressFamily.Unspecified; AF_INET = AddressFamily.InterNetwork; AF_INET6 = AddressFamily.InterNetworkV6; SOCKET_ERROR = integer(-1); @@ -387,7 +365,7 @@ function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarS function ntohs(netshort: u_short): u_short; function ntohl(netlong: u_long): u_long; function Listen(s: TSocket; backlog: Integer): Integer; - function IoctlSocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer; + function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; function htons(hostshort: u_short): u_short; function htonl(hostlong: u_long): u_long; // function GetSockName(s: TSocket; name: PSockAddr; var namelen: Integer): Integer; @@ -414,6 +392,14 @@ function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarS function GetPortService(value: string): integer; +function IsNewApi(Family: TAddrFamily): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word; + var SynSockCS: SyncObjs.TCriticalSection; SockEnhancedApi: Boolean; @@ -826,7 +812,7 @@ begin end; end; -function IoctlSocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer; +function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; var inv, outv: TMemory; begin @@ -840,7 +826,7 @@ begin inv := BitConverter.GetBytes(arg); outv := BitConverter.GetBytes(integer(0)); s.IOControl(cmd, inv, outv); - arg := BitConverter.ToUInt32(outv, 0); + arg := BitConverter.ToInt32(outv, 0); end; except on e: System.Net.Sockets.SocketException do @@ -985,6 +971,106 @@ begin Result := StrToIntDef(value, 0); end; +{=============================================================================} +function IsNewApi(Family: TAddrFamily): Boolean; +begin + Result := true; +end; + +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family: TAddrFamily; SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +var + IPs: array of IPAddress; + n: integer; + ip4, ip6: string; + sip: string; +begin + sip := ''; + ip4 := ''; + ip6 := ''; + IPs := Dns.Resolve(IP).AddressList; + for n :=low(IPs) to high(IPs) do begin + if (ip4 = '') and (IPs[n].AddressFamily = AF_INET) then + ip4 := IPs[n].toString; + if (ip6 = '') and (IPs[n].AddressFamily = AF_INET6) then + ip6 := IPs[n].toString; + if (ip4 <> '') and (ip6 <> '') then + break; + end; + case Family of + AF_UNSPEC: + begin + if (ip4 <> '') and (ip6 <> '') then + begin + if PreferIP4 then + sip := ip4 + else + Sip := ip6; + end + else + begin + sip := ip4; + if (ip6 <> '') then + sip := ip6; + end; + end; + AF_INET: + sip := ip4; + AF_INET6: + sip := ip6; + end; + sin := TVarSin.Create(IPAddress.Parse(sip), GetPortService(Port)); +end; + +function GetSinIP(Sin: TVarSin): string; +begin + Result := Sin.Address.ToString; +end; + +function GetSinPort(Sin: TVarSin): Integer; +begin + Result := Sin.Port; +end; + +procedure ResolveNameToIP(Name: string; Family: TAddrFamily; SockProtocol, SockType: integer; const IPList: TStrings); +var + IPs :array of IPAddress; + n: integer; +begin + IPList.Clear; + IPs := Dns.Resolve(Name).AddressList; + for n := low(IPs) to high(IPs) do + begin + if not(((Family = AF_INET6) and (IPs[n].AddressFamily = AF_INET)) + or ((Family = AF_INET) and (IPs[n].AddressFamily = AF_INET6))) then + begin + IPList.Add(IPs[n].toString); + end; + end; +end; + +function ResolvePort(Port: string; Family: TAddrFamily; SockProtocol, SockType: integer): Word; +var + n: integer; +begin + Result := StrToIntDef(port, 0); + if Result = 0 then + begin + port := Lowercase(port); + for n := 0 to High(Services) do + if services[n, 0] = port then + begin + Result := strtointdef(services[n, 1], 0); + break; + end; + end; +end; + +function ResolveIPToName(IP: string; Family: TAddrFamily; SockProtocol, SockType: integer): string; +begin + Result := Dns.GetHostByAddress(IP).HostName; +end; + + {=============================================================================} function InitSocketInterface(stack: string): Boolean; begin diff --git a/ssfpc.pas b/ssfpc.pas new file mode 100644 index 0000000..6957bbf --- /dev/null +++ b/ssfpc.pas @@ -0,0 +1,868 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.003 | +|==============================================================================| +| Content: Socket Independent Platform Layer - FreePascal definition include | +|==============================================================================| +| Copyright (c)2006, 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)2006. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@exclude} + +{$IFDEF FPC} + +//{$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 FreeBSD} +{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr +{$endif} +{$ifdef darwin} +{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr +{$endif} + +interface + +uses + SyncObjs, SysUtils, Classes, + synafpc, BaseUnix, Unix, termio, sockets, netdb; + +function InitSocketInterface(stack: string): Boolean; +function DestroySocketInterface: Boolean; + +const + DLLStackName = ''; + WinsockLevel = $0202; + + cLocalHost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + c6AnyHost = '::0'; + +type + TSocket = longint; + TAddrFamily = integer; + + TMemory = pointer; + + +type + TFDSet = Baseunix.TFDSet; + PFDSet = ^TFDSet; + Ptimeval = Baseunix.ptimeval; + Ttimeval = Baseunix.ttimeval; + +const + FIONREAD = termio.FIONREAD; + FIONBIO = termio.FIONBIO; + FIOASYNC = termio.FIOASYNC; + +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_RAW = 255; + IPPROTO_MAX = 256; + +type + PInAddr = ^TInAddr; + TInAddr = sockets.in_addr; + + PSockAddrIn = ^TSockAddrIn; + TSockAddrIn = sockets.TInetSockAddr; + + + TIP_mreq = record + imr_multiaddr: TInAddr; // IP multicast address of group + imr_interface: TInAddr; // local IP address of interface + end; + + + PInAddr6 = ^TInAddr6; + TInAddr6 = sockets.Tin6_addr; + + PSockAddrIn6 = ^TSockAddrIn6; + TSockAddrIn6 = sockets.TInetSockAddr6; + + + TIPv6_mreq = record + ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. + ipv6mr_interface: integer; // Interface index. + 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 + IP_TOS = sockets.IP_TOS; { int; IP type of service and precedence. } + IP_TTL = sockets.IP_TTL; { int; IP time to live. } + IP_HDRINCL = sockets.IP_HDRINCL; { int; Header is included with data. } + IP_OPTIONS = sockets.IP_OPTIONS; { ip_opts; IP per-packet options. } +// IP_ROUTER_ALERT = sockets.IP_ROUTER_ALERT; { bool } + IP_RECVOPTS = sockets.IP_RECVOPTS; { bool } + IP_RETOPTS = sockets.IP_RETOPTS; { bool } +// IP_PKTINFO = sockets.IP_PKTINFO; { bool } +// IP_PKTOPTIONS = sockets.IP_PKTOPTIONS; +// IP_PMTUDISC = sockets.IP_PMTUDISC; { obsolete name? } +// IP_MTU_DISCOVER = sockets.IP_MTU_DISCOVER; { int; see below } +// IP_RECVERR = sockets.IP_RECVERR; { bool } +// IP_RECVTTL = sockets.IP_RECVTTL; { bool } +// IP_RECVTOS = sockets.IP_RECVTOS; { bool } + IP_MULTICAST_IF = sockets.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f } + IP_MULTICAST_TTL = sockets.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl } + IP_MULTICAST_LOOP = sockets.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback } + IP_ADD_MEMBERSHIP = sockets.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership } + IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership } + + SOL_SOCKET = sockets.SOL_SOCKET; + + SO_DEBUG = sockets.SO_DEBUG; + SO_REUSEADDR = sockets.SO_REUSEADDR; + SO_TYPE = sockets.SO_TYPE; + SO_ERROR = sockets.SO_ERROR; + SO_DONTROUTE = sockets.SO_DONTROUTE; + SO_BROADCAST = sockets.SO_BROADCAST; + SO_SNDBUF = sockets.SO_SNDBUF; + SO_RCVBUF = sockets.SO_RCVBUF; + SO_KEEPALIVE = sockets.SO_KEEPALIVE; + SO_OOBINLINE = sockets.SO_OOBINLINE; +// SO_NO_CHECK = sockets.SO_NO_CHECK; +// SO_PRIORITY = sockets.SO_PRIORITY; + SO_LINGER = sockets.SO_LINGER; +// SO_BSDCOMPAT = sockets.SO_BSDCOMPAT; +// SO_REUSEPORT = sockets.SO_REUSEPORT; +// SO_PASSCRED = sockets.SO_PASSCRED; +// SO_PEERCRED = sockets.SO_PEERCRED; + SO_RCVLOWAT = sockets.SO_RCVLOWAT; + SO_SNDLOWAT = sockets.SO_SNDLOWAT; + SO_RCVTIMEO = sockets.SO_RCVTIMEO; + SO_SNDTIMEO = sockets.SO_SNDTIMEO; +{ Security levels - as per NRL IPv6 - don't actually do anything } +// SO_SECURITY_AUTHENTICATION = sockets.SO_SECURITY_AUTHENTICATION; +// SO_SECURITY_ENCRYPTION_TRANSPORT = sockets.SO_SECURITY_ENCRYPTION_TRANSPORT; +// SO_SECURITY_ENCRYPTION_NETWORK = sockets.SO_SECURITY_ENCRYPTION_NETWORK; +// SO_BINDTODEVICE = sockets.SO_BINDTODEVICE; +{ Socket filtering } +// SO_ATTACH_FILTER = sockets.SO_ATTACH_FILTER; +// SO_DETACH_FILTER = sockets.SO_DETACH_FILTER; + + SOMAXCONN = 1024; + + IPV6_UNICAST_HOPS = sockets.IPV6_UNICAST_HOPS; + IPV6_MULTICAST_IF = sockets.IPV6_MULTICAST_IF; + IPV6_MULTICAST_HOPS = sockets.IPV6_MULTICAST_HOPS; + IPV6_MULTICAST_LOOP = sockets.IPV6_MULTICAST_LOOP; + IPV6_JOIN_GROUP = sockets.IPV6_JOIN_GROUP; + IPV6_LEAVE_GROUP = sockets.IPV6_LEAVE_GROUP; + +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 = 10; { 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 for manipulating linger option. } + PLinger = ^TLinger; + TLinger = packed record + l_onoff: integer; + l_linger: integer; + end; + +const + + MSG_OOB = sockets.MSG_OOB; // Process out-of-band data. + MSG_PEEK = sockets.MSG_PEEK; // Peek at incoming messages. + MSG_NOSIGNAL = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE. + +const + WSAEINTR = ESysEINTR; + WSAEBADF = ESysEBADF; + WSAEACCES = ESysEACCES; + WSAEFAULT = ESysEFAULT; + WSAEINVAL = ESysEINVAL; + WSAEMFILE = ESysEMFILE; + WSAEWOULDBLOCK = ESysEWOULDBLOCK; + WSAEINPROGRESS = ESysEINPROGRESS; + WSAEALREADY = ESysEALREADY; + WSAENOTSOCK = ESysENOTSOCK; + WSAEDESTADDRREQ = ESysEDESTADDRREQ; + WSAEMSGSIZE = ESysEMSGSIZE; + WSAEPROTOTYPE = ESysEPROTOTYPE; + WSAENOPROTOOPT = ESysENOPROTOOPT; + WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT; + WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT; + WSAEOPNOTSUPP = ESysEOPNOTSUPP; + WSAEPFNOSUPPORT = ESysEPFNOSUPPORT; + WSAEAFNOSUPPORT = ESysEAFNOSUPPORT; + WSAEADDRINUSE = ESysEADDRINUSE; + WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL; + WSAENETDOWN = ESysENETDOWN; + WSAENETUNREACH = ESysENETUNREACH; + WSAENETRESET = ESysENETRESET; + WSAECONNABORTED = ESysECONNABORTED; + WSAECONNRESET = ESysECONNRESET; + WSAENOBUFS = ESysENOBUFS; + WSAEISCONN = ESysEISCONN; + WSAENOTCONN = ESysENOTCONN; + WSAESHUTDOWN = ESysESHUTDOWN; + WSAETOOMANYREFS = ESysETOOMANYREFS; + WSAETIMEDOUT = ESysETIMEDOUT; + WSAECONNREFUSED = ESysECONNREFUSED; + WSAELOOP = ESysELOOP; + WSAENAMETOOLONG = ESysENAMETOOLONG; + WSAEHOSTDOWN = ESysEHOSTDOWN; + WSAEHOSTUNREACH = ESysEHOSTUNREACH; + WSAENOTEMPTY = ESysENOTEMPTY; + WSAEPROCLIM = -1; + WSAEUSERS = ESysEUSERS; + WSAEDQUOT = ESysEDQUOT; + WSAESTALE = ESysESTALE; + WSAEREMOTE = ESysEREMOTE; + WSASYSNOTREADY = -2; + WSAVERNOTSUPPORTED = -3; + WSANOTINITIALISED = -4; + WSAEDISCON = -5; + WSAHOST_NOT_FOUND = 1; + WSATRY_AGAIN = 2; + WSANO_RECOVERY = 3; + WSANO_DATA = -6; + +const + WSADESCRIPTION_LEN = 256; + WSASYS_STATUS_LEN = 128; +type + PWSAData = ^TWSAData; + TWSAData = packed record + wVersion: Word; + wHighVersion: Word; + szDescription: array[0..WSADESCRIPTION_LEN] of Char; + szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char; + iMaxSockets: Word; + iMaxUdpDg: Word; + lpVendorInfo: PChar; + 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); + +{=============================================================================} + +var + SynSockCS: SyncObjs.TCriticalSection; + SockEnhancedApi: Boolean; + SockWship6Api: Boolean; + +type + TVarSin = packed record + {$ifdef SOCK_HAS_SINLEN} + sin_len : cuchar; + {$endif} + case integer of + 0: (AddressFamily: sa_family_t); + 1: ( + case sin_family: sa_family_t of + AF_INET: (sin_port: word; + sin_addr: TInAddr; + sin_zero: array[0..7] of Char); + AF_INET6: (sin6_port: word; + sin6_flowinfo: longword; + sin6_addr: TInAddr6; + sin6_scope_id: longword); + ); + end; + +function SizeOfVarSin(sin: TVarSin): integer; + + function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; + function WSACleanup: Integer; + function WSAGetLastError: Integer; + function GetHostName: string; + function Shutdown(s: TSocket; how: Integer): Integer; + function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + optlen: Integer): Integer; + function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory; + var optlen: Integer): Integer; + 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 ntohs(netshort: word): word; + function ntohl(netlong: longword): longword; + function Listen(s: TSocket; backlog: Integer): Integer; + function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; + function htons(hostshort: word): word; + function htonl(hostlong: longword): longword; + function GetSockName(s: TSocket; var name: TVarSin): Integer; + function GetPeerName(s: TSocket; var name: TVarSin): Integer; + function Connect(s: TSocket; const name: TVarSin): Integer; + function CloseSocket(s: TSocket): Integer; + function Bind(s: TSocket; const addr: TVarSin): Integer; + function Accept(s: TSocket; var addr: TVarSin): TSocket; + function Socket(af, Struc, Protocol: Integer): TSocket; + function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; + +function IsNewApi(Family: integer): Boolean; +function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; + + +{==============================================================================} +implementation + + +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; + +{=============================================================================} + +function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; +begin + with WSData do + begin + wVersion := wVersionRequired; + wHighVersion := $202; + szDescription := 'Synsock - Synapse Platform Independent Socket Layer'; + szSystemStatus := 'Running on Unix/Linux by FreePascal'; + iMaxSockets := 32768; + iMaxUdpDg := 8192; + end; + Result := 0; +end; + +function WSACleanup: Integer; +begin + Result := 0; +end; + +function WSAGetLastError: Integer; +begin + Result := fpGetErrno; +end; + +function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean; +begin + Result := fpFD_ISSET(socket, fdset) <> 0; +end; + +procedure FD_SET(Socket: TSocket; var fdset: TFDSet); +begin + fpFD_SET(Socket, fdset); +end; + +procedure FD_CLR(Socket: TSocket; var fdset: TFDSet); +begin + fpFD_CLR(Socket, fdset); +end; + +procedure FD_ZERO(var fdset: TFDSet); +begin + fpFD_ZERO(fdset); +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 + if sockets.Bind(s, addr, SizeOfVarSin(addr)) then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function Connect(s: TSocket; const name: TVarSin): Integer; +begin + if sockets.Connect(s, name, SizeOfVarSin(name)) then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function GetSockName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := sockets.GetSocketName(s, name, Len); +end; + +function GetPeerName(s: TSocket; var name: TVarSin): Integer; +var + len: integer; +begin + len := SizeOf(name); + FillChar(name, len, 0); + Result := sockets.GetPeerName(s, name, Len); +end; + +function GetHostName: string; +begin + Result := unix.GetHostName; +end; + +function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := sockets.Send(s, Buf^, len, flags); +end; + +function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer; +begin + Result := sockets.Recv(s, Buf^, len, flags); +end; + +function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer; +begin + Result := sockets.SendTo(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 + x := SizeOf(from); + Result := sockets.RecvFrom(s, Buf^, len, flags, from, x); +end; + +function Accept(s: TSocket; var addr: TVarSin): TSocket; +var + x: integer; +begin + x := SizeOf(addr); + Result := sockets.Accept(s, addr, x); +end; + +function Shutdown(s: TSocket; how: Integer): Integer; +begin + Result := sockets.Shutdown(s, how); +end; + +function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + optlen: Integer): Integer; +begin + Result := sockets.SetSocketOptions(s, level, optname, optval^, optlen); +end; + +function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory; + var optlen: Integer): Integer; +begin + Result := sockets.GetSocketOptions(s, level, optname, optval^, optlen); +end; + +function ntohs(netshort: word): word; +begin + Result := sockets.ntohs(NetShort); +end; + +function ntohl(netlong: longword): longword; +begin + Result := sockets.ntohl(NetLong); +end; + +function Listen(s: TSocket; backlog: Integer): Integer; +begin + if sockets.Listen(s, backlog) then + Result := 0 + else + Result := SOCKET_ERROR; +end; + +function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer; +begin + Result := fpIoctl(s, cmd, @arg); +end; + +function htons(hostshort: word): word; +begin + Result := sockets.htons(Hostshort); +end; + +function htonl(hostlong: longword): longword; +begin + Result := sockets.htonl(HostLong); +end; + +function CloseSocket(s: TSocket): Integer; +begin + Result := sockets.CloseSocket(s); +end; + +function Socket(af, Struc, Protocol: Integer): TSocket; +begin + Result := sockets.Socket(af, struc, protocol); +end; + +function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet; + timeout: PTimeVal): Longint; +begin + Result := fpSelect(nfds, readfds, writefds, exceptfds, timeout); +end; + +{=============================================================================} +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: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +var + TwoPass: boolean; + f1, f2: integer; + + function GetAddr(f:integer): integer; + var + a4: array [1..1] of in_addr; + a6: array [1..1] of Tin6_addr; + begin + Result := WSAEPROTONOSUPPORT; + case f of + AF_INET: + begin + if IP = cAnyHost then + begin + Sin.sin_family := AF_INET; + Result := 0; + end + else + begin + a4[1].s_addr := 0; + Result := WSAHOST_NOT_FOUND; + a4[1] := StrTonetAddr(IP); + if a4[1].s_addr = INADDR_ANY then + Resolvename(ip, a4); + if a4[1].s_addr <> INADDR_ANY then + begin + Sin.sin_family := AF_INET; + sin.sin_addr := a4[1]; + Result := 0; + end; + end; + end; + AF_INET6: + begin + if IP = c6AnyHost then + begin + Sin.sin_family := AF_INET6; + Result := 0; + end + else + begin + Result := WSAHOST_NOT_FOUND; + SET_IN6_IF_ADDR_ANY(@a6[1]); + a6[1] := StrTonetAddr6(IP); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + Resolvename6(ip, a6); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + begin + Sin.sin_family := AF_INET6; + sin.sin6_addr := a6[1]; + Result := 0; + end; + end; + end; + end; + end; +begin + Result := 0; + FillChar(Sin, Sizeof(Sin), 0); + Sin.sin_port := Resolveport(port, family, SockProtocol, SockType); + TwoPass := False; + if Family = AF_UNSPEC then + begin + if PreferIP4 then + begin + f1 := AF_INET; + f2 := AF_INET6; + TwoPass := True; + end + else + begin + f2 := AF_INET; + f1 := AF_INET6; + TwoPass := True; + end; + end + else + f1 := Family; + Result := GetAddr(f1); + if Result <> 0 then + if TwoPass then + Result := GetAddr(f2); +end; + +function GetSinIP(Sin: TVarSin): string; +begin + Result := ''; + case sin.AddressFamily of + AF_INET: + begin + result := NetAddrToStr(sin.sin_addr); + end; + AF_INET6: + begin + result := NetAddrToStr6(sin.sin6_addr); + end; + 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: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +var + x, n: integer; + a4: array [1..255] of in_addr; + a6: array [1..255] of Tin6_addr; +begin + IPList.Clear; + if (family = AF_INET) or (family = AF_UNSPEC) then + begin + a4[1] := StrTonetAddr(name); + if a4[1].s_addr = INADDR_ANY then + x := Resolvename(name, a4) + else + x := 1; + for n := 1 to x do + IpList.Add(netaddrToStr(a4[n])); + end; + + if (family = AF_INET6) or (family = AF_UNSPEC) then + begin + a6[1] := StrTonetAddr6(name); + if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then + x := Resolvename6(name, a6) + else + x := 1; + for n := 1 to x do + IpList.Add(netaddrToStr6(a6[n])); + end; + + if IPList.Count = 0 then + IPList.Add(cLocalHost); +end; + +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; +var + ProtoEnt: TProtocolEntry; + ServEnt: TServiceEntry; +begin + Result := synsock.htons(StrToIntDef(Port, 0)); + if Result = 0 then + begin + ProtoEnt.Name := ''; + GetProtocolByNumber(SockProtocol, ProtoEnt); + ServEnt.port := 0; + GetServiceByName(Port, ProtoEnt.Name, ServEnt); + Result := ServEnt.port; + end; +end; + +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +var + n: integer; + a4: array [1..1] of in_addr; + a6: array [1..1] of Tin6_addr; + a: array [1..1] of string; +begin + Result := IP; + a4[1] := StrToNetAddr(IP); + if a4[1].s_addr <> INADDR_ANY then + begin +//why ResolveAddress need address in HOST order? :-O + n := ResolveAddress(nettohost(a4[1]), a); + if n > 0 then + Result := a[1]; + end + else + begin + a6[1] := StrToNetAddr6(IP); + n := ResolveAddress6(a6[1], a); + if n > 0 then + Result := a[1]; + end; +end; + +{=============================================================================} + +function InitSocketInterface(stack: string): Boolean; +begin + SockEnhancedApi := False; + SockWship6Api := False; +// Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN)); + Result := True; +end; + +function DestroySocketInterface: Boolean; +begin + 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; + +{$ENDIF} + diff --git a/ssl_cryptlib.pas b/ssl_cryptlib.pas index ec76bae..84dd4d8 100644 --- a/ssl_cryptlib.pas +++ b/ssl_cryptlib.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.000.002 | +| Project : Ararat Synapse | 001.001.000 | |==============================================================================| | Content: SSL/SSH support by Peter Gutmann's CryptLib | |==============================================================================| @@ -97,12 +97,14 @@ type FCryptSession: CRYPT_SESSION; FPrivateKeyLabel: string; FDelCert: Boolean; + FReadBuffer: string; function SSLCheck(Value: integer): Boolean; function Init(server:Boolean): Boolean; function DeInit: Boolean; function Prepare(server:Boolean): Boolean; function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; function CreateSelfSignedCert(Host: string): Boolean; override; + function PopAll: string; public {:See @inherited} constructor Create(const Value: TTCPBlockSocket); override; @@ -203,6 +205,8 @@ function TSSLCryptLib.SSLCheck(Value: integer): Boolean; begin Result := true; FLastErrorDesc := ''; + if Value = CRYPT_ERROR_COMPLETE then + Value := 0; FLastError := Value; if FLastError <> 0 then begin @@ -243,6 +247,28 @@ begin Result := True; end; +function TSSLCryptLib.PopAll: string; +const + BufferMaxSize = 32768; +var + Outbuffer: string; + WriteLen: integer; +begin + Result := ''; + repeat + setlength(outbuffer, BufferMaxSize); + Writelen := 0; + SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen)); + if FLastError <> 0 then + Break; + if WriteLen > 0 then + begin + setlength(outbuffer, WriteLen); + Result := Result + outbuffer; + end; + until WriteLen = 0; +end; + function TSSLCryptLib.Init(server:Boolean): Boolean; var st: CRYPT_SESSION_TYPE; @@ -385,6 +411,7 @@ begin Exit; FSSLEnabled := True; Result := True; + FReadBuffer := ''; end; end; @@ -401,6 +428,7 @@ begin Exit; FSSLEnabled := True; Result := True; + FReadBuffer := ''; end; end; @@ -414,6 +442,7 @@ begin if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0); DeInit; + FReadBuffer := ''; Result := True; end; @@ -434,13 +463,18 @@ var begin FLastError := 0; FLastErrorDesc := ''; - SSLCheck(cryptPopData(FCryptSession, Buffer, Len, L)); - Result := l; + if Length(FReadBuffer) = 0 then + FReadBuffer := PopAll; + if Len > Length(FReadBuffer) then + Len := Length(FReadBuffer); + Move(Pointer(FReadBuffer)^, buffer^, Len); + Delete(FReadBuffer, 1, Len); + Result := Len; end; function TSSLCryptLib.WaitingData: Integer; begin - Result := 0; + Result := Length(FReadBuffer); end; function TSSLCryptLib.GetSSLVersion: string; diff --git a/ssl_openssl.pas b/ssl_openssl.pas index 5452705..12c2f1e 100644 --- a/ssl_openssl.pas +++ b/ssl_openssl.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.000.003 | +| Project : Ararat Synapse | 001.000.004 | |==============================================================================| | Content: SSL support by OpenSSL | |==============================================================================| @@ -643,6 +643,11 @@ begin Exit; end; cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; {$IFDEF CIL} sb := StringBuilder.Create(4096); Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096); @@ -676,6 +681,11 @@ begin Exit; end; cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; {$IFDEF CIL} sb := StringBuilder.Create(4096); Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096); @@ -700,6 +710,11 @@ begin Exit; end; cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; {$IFDEF CIL} sb := StringBuilder.Create(EVP_MAX_MD_SIZE); X509Digest(cert, EvpGetDigestByName('MD5'), sb, x); @@ -729,6 +744,11 @@ begin Exit; end; cert := SSLGetPeerCertificate(Fssl); + if not assigned(cert) then + begin + Result := ''; + Exit; + end; b := BioNew(BioSMem); try X509Print(b, cert); diff --git a/ssl_openssl_lib.pas b/ssl_openssl_lib.pas index 0a2db22..bb26a8a 100644 --- a/ssl_openssl_lib.pas +++ b/ssl_openssl_lib.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 003.004.000 | +| Project : Ararat Synapse | 003.004.001 | |==============================================================================| | Content: SSL support by OpenSSL | |==============================================================================| @@ -76,10 +76,8 @@ uses System.Text, {$ENDIF} Classes, -{$IFDEF LINUX} - {$IFDEF FPC} synafpc, - {$ENDIF} +{$IFNDEF WIN32} Libc, SysUtils; {$ELSE} Windows; @@ -97,7 +95,7 @@ const {$ENDIF} {$ELSE} var - {$IFDEF LINUX} + {$IFNDEF WIN32} DLLSSLName: string = 'libssl.so'; DLLUtilName: string = 'libcrypto.so'; {$ELSE} @@ -205,8 +203,8 @@ const EVP_PKEY_RSA = 6; var - SSLLibHandle: Integer = 0; - SSLUtilHandle: Integer = 0; + SSLLibHandle: TLibHandle = 0; + SSLUtilHandle: TLibHandle = 0; SSLLibFile: string = ''; SSLUtilFile: string = ''; diff --git a/ssl_sbb.pas b/ssl_sbb.pas new file mode 100644 index 0000000..5692fd6 --- /dev/null +++ b/ssl_sbb.pas @@ -0,0 +1,594 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.001 | +|==============================================================================| +| Content: SSL support for SecureBlackBox | +|==============================================================================| +| Copyright (c)1999-2005, 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)2005. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +| Allen Drennan (adrennan@wiredred.com) | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(SSL plugin for Eldos SecureBlackBox) + +For handling keys and certificates you can use this properties: +@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA), +@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate), +@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey), +@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate), +@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats +of keys and certificates refer to SecureBlackBox documentation. +} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$H+} + +unit ssl_sbb; + +interface + +uses + SysUtils, Classes, Windows, blcksock, synsock, synautil, synacode, + SBClient, SBServer, SBX509, SBWinCertStorage, SBCustomCertStorage, + SBUtils, SBConstants, SBSessionPool; + +const + DEFAULT_RECV_BUFFER=32768; + +type + {:@abstract(class implementing SecureBlackbox SSL plugin.) + Instance of this class will be created for each @link(TTCPBlockSocket). + You not need to create instance of this class, all is done by Synapse itself!} + TSSLSBB=class(TCustomSSL) + protected + FServer: Boolean; + FElSecureClient:TElSecureClient; + FElSecureServer:TElSecureServer; + FElCertStorage:TElMemoryCertStorage; + FElX509Certificate:TElX509Certificate; + private + FRecvBuffer:String; + FRecvBuffers:String; + FRecvDecodedBuffers:String; + function Init(Server:Boolean):Boolean; + function DeInit:Boolean; + function Prepare(Server:Boolean):Boolean; + procedure OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); + procedure OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); + procedure OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;out Written:LongInt); + procedure OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); + public + constructor Create(const Value: TTCPBlockSocket); override; + destructor Destroy; override; + {:See @inherited} + function LibVersion: String; override; + {:See @inherited} + function LibName: String; override; + {:See @inherited and @link(ssl_sbb) for more details.} + function Connect: boolean; override; + {:See @inherited and @link(ssl_sbb) for more details.} + function Accept: boolean; override; + {:See @inherited} + function Shutdown: boolean; override; + {:See @inherited} + function BiShutdown: boolean; override; + {:See @inherited} + function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; + {:See @inherited} + function WaitingData: Integer; override; + {:See @inherited} + function GetSSLVersion: string; override; + {:See @inherited} + function GetPeerSubject: string; override; + {:See @inherited} + function GetPeerIssuer: string; override; + {:See @inherited} + function GetPeerName: string; override; + {:See @inherited} + function GetPeerFingerprint: string; override; + {:See @inherited} + function GetCertInfo: string; override; + published + property ELSecureClient:TElSecureClient read FElSecureClient write FElSecureClient; + property ELSecureServer:TElSecureServer read FElSecureServer write FElSecureServer; + end; + +implementation + +// on error +procedure TSSLSBB.OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean); + +begin + FLastErrorDesc:=''; + FLastError:=ErrorCode; +end; + +// on send +procedure TSSLSBB.OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt); + +var + lResult:Integer; + +begin + lResult:=Send(FSocket.Socket,Buffer,Size,0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end; +end; + +// on receive +procedure TSSLSBB.OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;out Written:LongInt); + +begin + if Length(FRecvBuffers)<=MaxSize then + begin + Written:=Length(FRecvBuffers); + Move(FRecvBuffers[1],Buffer^,Written); + FRecvBuffers:=''; + end + else + begin + Written:=MaxSize; + Move(FRecvBuffers[1],Buffer^,Written); + Delete(FRecvBuffers,1,Written); + end; +end; + +// on data +procedure TSSLSBB.OnData(Sender:TObject;Buffer:Pointer;Size:LongInt); + +var + lString:String; + +begin + SetLength(lString,Size); + Move(Buffer^,lString[1],Size); + FRecvDecodedBuffers:=FRecvDecodedBuffers+lString; +end; + +{ inherited } + +constructor TSSLSBB.Create(const Value: TTCPBlockSocket); + +begin + inherited Create(Value); + FServer:=FALSE; + FElSecureClient:=NIL; + FElSecureServer:=NIL; + FElCertStorage:=NIL; + FElX509Certificate:=NIL; + SetLength(FRecvBuffer,DEFAULT_RECV_BUFFER); + FRecvBuffers:=''; + FRecvDecodedBuffers:=''; +end; + +destructor TSSLSBB.Destroy; + +begin + DeInit; + inherited Destroy; +end; + +function TSSLSBB.LibVersion: String; + +begin + Result:='SecureBlackBox'; +end; + +function TSSLSBB.LibName: String; + +begin + Result:='ssl_sbb'; +end; + +function FileToString(lFile:String):String; + +var + lStream:TMemoryStream; + +begin + Result:=''; + lStream:=TMemoryStream.Create; + if lStream<>NIL then + begin + lStream.LoadFromFile(lFile); + if lStream.Size>0 then + begin + lStream.Position:=0; + SetLength(Result,lStream.Size); + Move(lStream.Memory^,Result[1],lStream.Size); + end; + lStream.Free; + end; +end; + +function TSSLSBB.Init(Server:Boolean):Boolean; + +var + loop1:Integer; + lStream:TMemoryStream; + lCertificate,lPrivateKey:String; + +begin + Result:=FALSE; + FServer:=Server; + + // init, certificate + if FCertificateFile<>'' then + lCertificate:=FileToString(FCertificateFile) + else + lCertificate:=FCertificate; + if FPrivateKeyFile<>'' then + lPrivateKey:=FileToString(FPrivateKeyFile) + else + lPrivateKey:=FPrivateKey; + if (lCertificate<>'') and (lPrivateKey<>'') then + begin + FElX509Certificate:=TElX509Certificate.Create(NIL); + if FElX509Certificate<>NIL then + begin + with FElX509Certificate do + begin + lStream:=TMemoryStream.Create; + try + WriteStrToStream(lStream,lCertificate); + lStream.Seek(0,soFromBeginning); + LoadFromStream(lStream); + finally + lStream.Free; + end; + lStream:=TMemoryStream.Create; + try + WriteStrToStream(lStream,lPrivateKey); + lStream.Seek(0,soFromBeginning); + LoadKeyFromStream(lStream); + finally + lStream.Free; + end; + FElCertStorage:=TElMemoryCertStorage.Create(NIL); + if FElCertStorage<>NIL then + begin + FElCertStorage.Clear; + FElCertStorage.Add(FElX509Certificate); + end; + end; + end; + end; + + // init, as server + if FServer then + begin + FElSecureServer:=TElSecureServer.Create(NIL); + if FElSecureServer<>NIL then + begin + // init, ciphers + for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do + FElSecureServer.CipherSuites[loop1]:=TRUE; + FElSecureServer.Versions:=[sbSSL2,sbSSL3,sbTLS1]; + FElSecureServer.ClientAuthentication:=FALSE; + FElSecureServer.OnError:=OnError; + FElSecureServer.OnSend:=OnSend; + FElSecureServer.OnReceive:=OnReceive; + FElSecureServer.OnData:=OnData; + FElSecureServer.CertStorage:=FElCertStorage; + Result:=TRUE; + end; + end + else + // init, as client + begin + FElSecureClient:=TElSecureClient.Create(NIL); + if FElSecureClient<>NIL then + begin + // init, ciphers + for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do + FElSecureClient.CipherSuites[loop1]:=TRUE; + FElSecureClient.Versions:=[sbSSL3,sbTLS1]; + FElSecureClient.OnError:=OnError; + FElSecureClient.OnSend:=OnSend; + FElSecureClient.OnReceive:=OnReceive; + FElSecureClient.OnData:=OnData; + FElSecureClient.CertStorage:=FElCertStorage; + Result:=TRUE; + end; + end; +end; + +function TSSLSBB.DeInit:Boolean; + +begin + Result:=TRUE; + if FElSecureServer<>NIL then + FreeAndNIL(FElSecureServer); + if FElSecureClient<>NIL then + FreeAndNIL(FElSecureClient); + if FElX509Certificate<>NIL then + FreeAndNIL(FElX509Certificate); + if FElCertStorage<>NIL then + FreeAndNIL(FElCertStorage); + FSSLEnabled:=FALSE; +end; + +function TSSLSBB.Prepare(Server:Boolean): Boolean; + +begin + Result:=FALSE; + DeInit; + if Init(Server) then + Result:=TRUE + else + DeInit; +end; + +function TSSLSBB.Connect: boolean; + +var + lResult:Integer; + +begin + Result:=FALSE; + if FSocket.Socket=INVALID_SOCKET then + Exit; + if Prepare(FALSE) then + begin + FElSecureClient.Open; + + // wait for open or error + while (not FElSecureClient.Active) and + (FLastError=0) do + begin + // data available? + if FRecvBuffers<>'' then + FElSecureClient.DataAvailable + else + begin + // socket recv + lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end + else + begin + if lResult>0 then + FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) + else + Break; + end; + end; + end; + if FLastError<>0 then + Exit; + FSSLEnabled:=FElSecureClient.Active; + Result:=FSSLEnabled; + end; +end; + +function TSSLSBB.Accept: boolean; + +var + lResult:Integer; + +begin + Result:=FALSE; + if FSocket.Socket=INVALID_SOCKET then + Exit; + if Prepare(TRUE) then + begin + FElSecureServer.Open; + + // wait for open or error + while (not FElSecureServer.Active) and + (FLastError=0) do + begin + // data available? + if FRecvBuffers<>'' then + FElSecureServer.DataAvailable + else + begin + // socket recv + lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end + else + begin + if lResult>0 then + FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult) + else + Break; + end; + end; + end; + if FLastError<>0 then + Exit; + FSSLEnabled:=FElSecureServer.Active; + Result:=FSSLEnabled; + end; +end; + +function TSSLSBB.Shutdown: boolean; + +begin + Result:=BiShutdown; +end; + +function TSSLSBB.BiShutdown: boolean; + +begin + DeInit; + Result:=TRUE; +end; + +function TSSLSBB.SendBuffer(Buffer: TMemory; Len: Integer): Integer; + +begin + if FServer then + FElSecureServer.SendData(Buffer,Len) + else + FElSecureClient.SendData(Buffer,Len); + Result:=Len; +end; + +function TSSLSBB.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; + +begin + if Length(FRecvDecodedBuffers)'' then + begin + if FServer then + FElSecureServer.DataAvailable + else + FElSecureClient.DataAvailable; + end + else + begin + // socket recv + lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0); + if lResult=SOCKET_ERROR then + begin + FLastErrorDesc:=''; + FLastError:=WSAGetLastError; + end + else + FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult); + + // data available? + if FRecvBuffers<>'' then + begin + if FServer then + FElSecureServer.DataAvailable + else + FElSecureClient.DataAvailable; + end; + end; + Result:=Length(FRecvDecodedBuffers); +end; + +function TSSLSBB.GetSSLVersion: string; + +begin + Result:='SSLv3 or TLSv1'; +end; + +function TSSLSBB.GetPeerSubject: string; + +begin + Result := ''; +// if FServer then + // must return subject of the client certificate +// else + // must return subject of the server certificate +end; + +function TSSLSBB.GetPeerName: string; + +begin + Result := ''; +// if FServer then + // must return commonname of the client certificate +// else + // must return commonname of the server certificate +end; + +function TSSLSBB.GetPeerIssuer: string; + +begin + Result := ''; +// if FServer then + // must return issuer of the client certificate +// else + // must return issuer of the server certificate +end; + +function TSSLSBB.GetPeerFingerprint: string; + +begin + Result := ''; +// if FServer then + // must return a unique hash string of the client certificate +// else + // must return a unique hash string of the server certificate +end; + +function TSSLSBB.GetCertInfo: string; + +begin + Result := ''; +// if FServer then + // must return a text representation of the ASN of the client certificate +// else + // must return a text representation of the ASN of the server certificate +end; + +{==============================================================================} + +initialization + SSLImplementation := TSSLSBB; + +finalization + +end. diff --git a/sslinux.pas b/sslinux.pas index 536c54f..887b666 100644 --- a/sslinux.pas +++ b/sslinux.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 002.000.005 | +| Project : Ararat Synapse | 002.000.007 | |==============================================================================| | Content: Socket Independent Platform Layer - Linux definition include | |==============================================================================| @@ -62,10 +62,8 @@ For IPv6 support you must have new API! interface uses - SyncObjs, SysUtils, - {$IFDEF FPC} + SyncObjs, SysUtils, Classes, synafpc, - {$ENDIF} Libc; function InitSocketInterface(stack: string): Boolean; @@ -82,6 +80,7 @@ type pu_long = ^u_long; pu_short = ^u_short; TSocket = u_int; + TAddrFamily = integer; TMemory = pointer; @@ -89,6 +88,14 @@ type const DLLStackName = 'libc.so.6'; + cLocalhost = '127.0.0.1'; + cAnyHost = '0.0.0.0'; + cBroadcast = '255.255.255.255'; + c6Localhost = '::1'; + c6AnyHost = '::0'; + c6Broadcast = 'ffff::1'; + cAnyPort = '0'; + type DWORD = Integer; __fd_mask = LongWord; @@ -127,20 +134,11 @@ const IPPROTO_MAX = 256; type - SunB = packed record - s_b1, s_b2, s_b3, s_b4: u_char; - end; - - SunW = packed record - s_w1, s_w2: u_short; - end; - PInAddr = ^TInAddr; TInAddr = packed record case integer of - 0: (S_un_b: SunB); - 1: (S_un_w: SunW); - 2: (S_addr: u_long); + 0: (S_bytes: packed array [0..3] of byte); + 1: (S_addr: u_long); end; PSockAddrIn = ^TSockAddrIn; @@ -159,33 +157,13 @@ type imr_interface: TInAddr; { local IP address of interface } end; - SunB6 = packed record - s_b1, s_b2, s_b3, s_b4, - s_b5, s_b6, s_b7, s_b8, - s_b9, s_b10, s_b11, s_b12, - s_b13, s_b14, s_b15, s_b16: u_char; - end; - - SunW6 = packed record - s_w1, s_w2, s_w3, s_w4, - s_w5, s_w6, s_w7, s_w8: u_short; - end; - - SunDW6 = packed record - s_dw1, s_dw2, s_dw3, s_dw4: longint; - end; - - S6_Bytes = SunB6; - S6_Words = SunW6; - S6_DWords = SunDW6; - S6_Addr = SunB6; - PInAddr6 = ^TInAddr6; TInAddr6 = packed record case integer of - 0: (S_un_b: SunB6); - 1: (S_un_w: SunW6); - 2: (S_un_dw: SunDW6); + 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..7] of integer); end; PSockAddrIn6 = ^TSockAddrIn6; @@ -200,7 +178,7 @@ type TIPv6_mreq = record ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. - ipv6mr_interface: u_long; // Interface index. + ipv6mr_interface: integer; // Interface index. padding: u_long; end; @@ -378,8 +356,8 @@ type { Structure used for manipulating linger option. } PLinger = ^TLinger; TLinger = packed record - l_onoff: u_short; - l_linger: u_short; + l_onoff: integer; + l_linger: integer; end; const @@ -530,7 +508,7 @@ type cdecl; TListen = function(s: TSocket; backlog: Integer): Integer; cdecl; - TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: u_long): Integer; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: integer): Integer; cdecl; TInet_ntoa = function(inaddr: TInAddr): PChar; cdecl; @@ -644,41 +622,49 @@ function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): 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: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; + {==============================================================================} implementation var SynSockCount: Integer = 0; - LibHandle: THandle = 0; - Libwship6Handle: THandle = 0; + LibHandle: TLibHandle = 0; + Libwship6Handle: TLibHandle = 0; function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; begin - Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and - (a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0)); + 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^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and - (a^.s_un_dw.s_dw3 = 0) and - (a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and - (a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1))); + 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^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80))); + 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^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0))); + 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^.s_un_b.s_b1 = char($FF)); + Result := (a^.u6_addr8[0] = $FF); end; function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; @@ -694,7 +680,7 @@ end; procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); begin FillChar(a^, sizeof(TInAddr6), 0); - a^.s_un_b.s_b16 := char(1); + a^.u6_addr8[15] := 1; end; {=============================================================================} @@ -851,6 +837,369 @@ begin Result := ssAccept(s, @addr, x); end; +{=============================================================================} +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: string; 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: string; 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(PChar(IP), nil, @Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + end + else + begin + Result := synsock.GetAddrInfo(PChar(IP), PChar(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 then + ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Sin.sin_port := synsock.htons(StrToIntDef(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(PChar(IP)); + if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then + begin + HostEnt := synsock.GetHostByName(PChar(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): string; +var + p: PChar; + host, serv: string; + 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), PChar(host), hostlen, + PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + Result := PChar(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: string; 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: string; + 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(PChar(Name)); + if IP = u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := synsock.GetHostByName(PChar(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(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(PChar(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, + PChar(host), hostlen, PChar(serv), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + begin + host := PChar(host); + IPList.Add(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: string; 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(PChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Result := StrToIntDef(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, PChar(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: string; Family, SockProtocol, SockType: integer): string; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; + host, serv: string; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: u_long; +begin + Result := IP; + if not IsNewApi(Family) then + begin + IPn := synsock.inet_addr(PChar(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(PChar(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, + PChar(host), hostlen, PChar(serv), servlen, + NI_NUMERICSERV); + if r = 0 then + Result := PChar(host); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + {=============================================================================} function InitSocketInterface(stack: string): Boolean; diff --git a/sswin32.pas b/sswin32.pas index 6964718..2e0824c 100644 --- a/sswin32.pas +++ b/sswin32.pas @@ -241,7 +241,7 @@ For IPv6 support you must have new API! interface uses - SyncObjs, SysUtils, + SyncObjs, SysUtils, Classes, Windows; function InitSocketInterface(stack: string): Boolean; @@ -262,6 +262,7 @@ type pu_long = ^u_long; pu_short = ^u_short; TSocket = u_int; + TAddrFamily = integer; TMemory = pointer; @@ -273,6 +274,15 @@ const {$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 @@ -307,20 +317,12 @@ const IPPROTO_MAX = 256; type - SunB = packed record - s_b1, s_b2, s_b3, s_b4: u_char; - end; - - SunW = packed record - s_w1, s_w2: u_short; - end; PInAddr = ^TInAddr; TInAddr = packed record case integer of - 0: (S_un_b: SunB); - 1: (S_un_w: SunW); - 2: (S_addr: u_long); + 0: (S_bytes: packed array [0..3] of byte); + 1: (S_addr: u_long); end; PSockAddrIn = ^TSockAddrIn; @@ -339,33 +341,13 @@ type imr_interface: TInAddr; { local IP address of interface } end; - SunB6 = packed record - s_b1, s_b2, s_b3, s_b4, - s_b5, s_b6, s_b7, s_b8, - s_b9, s_b10, s_b11, s_b12, - s_b13, s_b14, s_b15, s_b16: u_char; - end; - - SunW6 = packed record - s_w1, s_w2, s_w3, s_w4, - s_w5, s_w6, s_w7, s_w8: u_short; - end; - - SunDW6 = packed record - s_dw1, s_dw2, s_dw3, s_dw4: longint; - end; - - S6_Bytes = SunB6; - S6_Words = SunW6; - S6_DWords = SunDW6; - S6_Addr = SunB6; - PInAddr6 = ^TInAddr6; TInAddr6 = packed record case integer of - 0: (S_un_b: SunB6); - 1: (S_un_w: SunW6); - 2: (S_un_dw: SunDW6); + 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..7] of integer); end; PSockAddrIn6 = ^TSockAddrIn6; @@ -380,8 +362,8 @@ type TIPv6_mreq = record ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address. - ipv6mr_interface: u_long; // Interface index. - padding: u_long; + ipv6mr_interface: integer; // Interface index. + padding: integer; end; PHostEnt = ^THostEnt; @@ -807,7 +789,7 @@ type stdcall; TListen = function(s: TSocket; backlog: Integer): Integer; stdcall; - TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: u_long): Integer; + TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: Integer): Integer; stdcall; TInet_ntoa = function(inaddr: TInAddr): PChar; stdcall; @@ -930,6 +912,14 @@ function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): 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: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer; +function GetSinIP(Sin: TVarSin): string; +function GetSinPort(Sin: TVarSin): Integer; +procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings); +function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string; +function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word; + {==============================================================================} implementation @@ -940,31 +930,31 @@ var function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean; begin - Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and - (a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0)); + 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^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and - (a^.s_un_dw.s_dw3 = 0) and - (a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and - (a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1))); + 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^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80))); + 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^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0))); + 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^.s_un_b.s_b1 = char($FF)); + Result := (a^.u6_addr8[0] = $FF); end; function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean; @@ -980,7 +970,7 @@ end; procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6); begin FillChar(a^, sizeof(TInAddr6), 0); - a^.s_un_b.s_b16 := char(1); + a^.u6_addr8[15] := 1; end; {=============================================================================} @@ -1109,6 +1099,369 @@ begin Result := ssAccept(s, @addr, x); end; +{=============================================================================} +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: string; 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: string; 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(PChar(IP), nil, @Hints, Addr); + end + else + begin + if (IP = cAnyHost) or (IP = c6AnyHost) then + begin + Hints.ai_flags := AI_PASSIVE; + Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + end + else + if (IP = cLocalhost) or (IP = c6Localhost) then + begin + Result := synsock.GetAddrInfo(nil, PChar(Port), @Hints, Addr); + end + else + begin + Result := synsock.GetAddrInfo(PChar(IP), PChar(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 then + ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Sin.sin_port := synsock.htons(StrToIntDef(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(PChar(IP)); + if Sin.sin_addr.s_addr = u_long(INADDR_NONE) then + begin + HostEnt := synsock.GetHostByName(PChar(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): string; +var + p: PChar; + host, serv: string; + 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), PChar(host), hostlen, + PChar(serv), servlen, NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + Result := PChar(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: string; 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: string; + 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(PChar(Name)); + if IP = u_long(INADDR_NONE) then + begin + SynSockCS.Enter; + try + RemoteHost := synsock.GetHostByName(PChar(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(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(PChar(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, + PChar(host), hostlen, PChar(serv), servlen, + NI_NUMERICHOST + NI_NUMERICSERV); + if r = 0 then + begin + host := PChar(host); + IPList.Add(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: string; 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(PChar(Port), ProtoEnt^.p_name); + if ServEnt = nil then + Result := StrToIntDef(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, PChar(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: string; Family, SockProtocol, SockType: integer): string; +var + Hints: TAddrInfo; + Addr: PAddrInfo; + r: integer; + host, serv: string; + hostlen, servlen: integer; + RemoteHost: PHostEnt; + IPn: u_long; +begin + Result := IP; + if not IsNewApi(Family) then + begin + IPn := synsock.inet_addr(PChar(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(PChar(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, + PChar(host), hostlen, PChar(serv), servlen, + NI_NUMERICSERV); + if r = 0 then + Result := PChar(host); + end; + finally + if Assigned(Addr) then + synsock.FreeAddrInfo(Addr); + end; + end; +end; + {=============================================================================} function InitSocketInterface(stack: string): Boolean; diff --git a/synachar.pas b/synachar.pas index 102fd20..586341e 100644 --- a/synachar.pas +++ b/synachar.pas @@ -65,7 +65,7 @@ unit synachar; interface uses -{$IFDEF LINUX} +{$IFNDEF WIN32} Libc, {$ELSE} Windows, @@ -1469,7 +1469,7 @@ begin end; {==============================================================================} -{$IFDEF LINUX} +{$IFNDEF WIN32} function GetCurCP: TMimeChar; begin diff --git a/synafpc.pas b/synafpc.pas index c31f01e..0370d5e 100644 --- a/synafpc.pas +++ b/synafpc.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 001.000.000 | +| Project : Ararat Synapse | 001.001.000 | |==============================================================================| | Content: Utils for FreePascal compatibility | |==============================================================================| -| Copyright (c)1999-2003, Lukas Gebauer | +| Copyright (c)1999-2006, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c)2003. | +| Portions created by Lukas Gebauer are Copyright (c)2003-2006. | | All Rights Reserved. | |==============================================================================| | Contributor(s): | @@ -53,56 +53,79 @@ unit synafpc; interface -{$IFDEF LINUX} - {$IFDEF FPC} uses - Libc, - dynlibs; - -type - HMODULE = Longint; - -function LoadLibrary(ModuleName: PChar): HMODULE; -function FreeLibrary(Module: HMODULE): LongBool; -function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer; -function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; -procedure Sleep(milliseconds: Cardinal); - +{$IFDEF FPC} + dynlibs, sysutils; +{$ELSE} + {$IFDEF WIN32} + Windows; + {$ELSE} + Sysutils; {$ENDIF} {$ENDIF} +{$IFDEF FPC} +type + TLibHandle = dynlibs.TLibHandle; + +function LoadLibrary(ModuleName: PChar): TLibHandle; +function FreeLibrary(Module: TLibHandle): LongBool; +function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; +function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; +{$ELSE} +type + {$IFDEF CIL} + TLibHandle = Integer; + {$ELSE} + TLibHandle = HModule; + {$ENDIF} + {$IFDEF VER100} + LongWord = DWord; + {$ENDIF} +{$ENDIF} + +procedure Sleep(milliseconds: Cardinal); + implementation {==============================================================================} -{$IFDEF LINUX} - {$IFDEF FPC} -function LoadLibrary(ModuleName: PChar): HMODULE; -begin - Result := HMODULE(dynlibs.LoadLibrary(Modulename)); -end; - -function FreeLibrary(Module: HMODULE): LongBool; +{$IFDEF FPC} +function LoadLibrary(ModuleName: PChar): TLibHandle; begin - Result := dynlibs.UnloadLibrary(pointer(Module)); + Result := dynlibs.LoadLibrary(Modulename); end; -function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer; +function FreeLibrary(Module: TLibHandle): LongBool; begin - Result := dynlibs.GetProcedureAddress(pointer(Module), Proc); + Result := dynlibs.UnloadLibrary(Module); end; -function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; -begin - Result := 0; -end; - -procedure Sleep(milliseconds: Cardinal); -begin - usleep(milliseconds * 1000); // usleep is in microseconds +function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; +begin + Result := dynlibs.GetProcedureAddress(Module, Proc); end; - - {$ENDIF} + +function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; +begin + Result := 0; +end; + +{$ELSE} {$ENDIF} +procedure Sleep(milliseconds: Cardinal); +begin +{$IFDEF WIN32} + {$IFDEF FPC} + sysutils.sleep(milliseconds); + {$ELSE} + windows.sleep(milliseconds); + {$ENDIF} +{$ELSE} + sysutils.sleep(milliseconds); +{$ENDIF} + +end; + end. diff --git a/synaicnv.pas b/synaicnv.pas index de1cc4a..72a0623 100644 --- a/synaicnv.pas +++ b/synaicnv.pas @@ -62,10 +62,8 @@ uses System.Runtime.InteropServices, System.Text, {$ENDIF} -{$IFDEF LINUX} - {$IFDEF FPC} synafpc, - {$ENDIF} +{$IFNDEF WIN32} Libc, SysUtils; {$ELSE} Windows; @@ -73,7 +71,7 @@ uses const - {$IFDEF LINUX} + {$IFNDEF WIN32} DLLIconvName = 'libiconv.so'; {$ELSE} DLLIconvName = 'iconv.dll'; @@ -89,7 +87,7 @@ type argptr = iconv_t; var - iconvLibHandle: Integer = 0; + iconvLibHandle: TLibHandle = 0; function SynaIconvOpen(const tocode, fromcode: string): iconv_t; function SynaIconvOpenTranslit(const tocode, fromcode: string): iconv_t; diff --git a/synaip.pas b/synaip.pas new file mode 100644 index 0000000..9d93c9c --- /dev/null +++ b/synaip.pas @@ -0,0 +1,390 @@ +{==============================================================================| +| Project : Ararat Synapse | 001.000.000 | +|==============================================================================| +| Content: IP address support procedures and functions | +|==============================================================================| +| Copyright (c)2006, 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) 2006. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(IP adress support procedures and functions)} + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$H+} + +unit synaip; + +interface + +uses + SysUtils, SynaUtil; + +type +{:binary form of IPv6 adress (for string conversion routines)} + TIp6Bytes = array [0..15] of Byte; +{:binary form of IPv6 adress (for string conversion routines)} + TIp6Words = array [0..7] of Word; + +{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!} +function IsIP(const Value: string): Boolean; + +{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!} +function IsIP6(const Value: string): Boolean; + +{:Returns a string with the "Host" ip address converted to binary form.} +function IPToID(Host: string): string; + +{:Convert IPv6 address from their string form to binary byte array.} +function StrToIp6(value: string): TIp6Bytes; + +{:Convert IPv6 address from binary byte array to string form.} +function Ip6ToStr(value: TIp6Bytes): string; + +{:Convert IPv4 address from their string form to binary.} +function StrToIp(value: string): integer; + +{:Convert IPv4 address from binary to string form.} +function IpToStr(value: integer): string; + +{:Convert IPv4 address to reverse form.} +function ReverseIP(Value: AnsiString): AnsiString; + +{:Convert IPv6 address to reverse form.} +function ReverseIP6(Value: AnsiString): AnsiString; + + +implementation + +{==============================================================================} + +function IsIP(const Value: string): Boolean; +var + TempIP: string; + function ByteIsOk(const Value: string): Boolean; + var + x, n: integer; + begin + x := StrToIntDef(Value, -1); + Result := (x >= 0) and (x < 256); + // X may be in correct range, but value still may not be correct value! + // i.e. "$80" + if Result then + for n := 1 to length(Value) do + if not (Value[n] in ['0'..'9']) then + begin + Result := False; + Break; + end; + end; +begin + TempIP := Value; + Result := False; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if not ByteIsOk(Fetch(TempIP, '.')) then + Exit; + if ByteIsOk(TempIP) then + Result := True; +end; + +{==============================================================================} + +function IsIP6(const Value: string): Boolean; +var + TempIP: string; + s,t: string; + x: integer; + partcount: integer; + zerocount: integer; + First: Boolean; +begin + TempIP := Value; + Result := False; + if Value = '::' then + begin + Result := True; + Exit; + end; + partcount := 0; + zerocount := 0; + First := True; + while tempIP <> '' do + begin + s := fetch(TempIP, ':'); + if not(First) and (s = '') then + Inc(zerocount); + First := False; + if zerocount > 1 then + break; + Inc(partCount); + if s = '' then + Continue; + if partCount > 8 then + break; + if tempIP = '' then + begin + t := SeparateRight(s, '%'); + s := SeparateLeft(s, '%'); + x := StrToIntDef('$' + t, -1); + if (x < 0) or (x > $ffff) then + break; + end; + x := StrToIntDef('$' + s, -1); + if (x < 0) or (x > $ffff) then + break; + if tempIP = '' then + if not((PartCount = 1) and (ZeroCount = 0)) then + Result := True; + end; +end; + +{==============================================================================} +function IPToID(Host: string): string; +var + s: string; + i, x: Integer; +begin + Result := ''; + for x := 0 to 3 do + begin + s := Fetch(Host, '.'); + i := StrToIntDef(s, 0); + Result := Result + Chr(i); + end; +end; + +{==============================================================================} + +function StrToIp(value: string): integer; +var + s: string; + i, x: Integer; +begin + Result := 0; + for x := 0 to 3 do + begin + s := Fetch(value, '.'); + i := StrToIntDef(s, 0); + Result := (256 * Result) + i; + end; +end; + +{==============================================================================} + +function IpToStr(value: integer): string; +var + x1, x2: word; + y1, y2: byte; +begin + Result := ''; + x1 := value div $10000; + x2 := value mod $10000; + y1 := x1 div $100; + y2 := x1 mod $100; + Result := inttostr(y1) + '.' + inttostr(y2) + '.'; + y1 := x2 div $100; + y2 := x2 mod $100; + Result := Result + inttostr(y1) + '.' + inttostr(y2); +end; + +{==============================================================================} + +function StrToIp6(Value: string): TIp6Bytes; +var + IPv6: TIp6Words; + Index: Integer; + ZeroAt: Integer; + n: integer; + b1, b2: byte; + s: string; + x: integer; +begin + for n := 0 to 15 do + Result[n] := 0; + for n := 0 to 7 do + Ipv6[n] := 0; + Index := 0; + ZeroAt := -1; + + while Value <> '' do + begin + if Index > 7 then + Exit; + s := fetch(value, ':'); + if s = '@' then + break; + if s = '' then + begin + ZeroAt := Index; + IPv6[Index] := 0; + end + else + begin + x := StrToIntDef('$' + s, -1); + if (x > 65535) or (x < 0) then + Exit; + IPv6[Index] := x; + end; + Inc(Index); + end; + if ZeroAt >= 0 then + Begin + x := Index - ZeroAt - 1; + for n := 1 to x do + IPv6[7 - n + 1] := Ipv6[ZeroAt + x - 1 + n]; + for n := ZeroAt + 1 to Index - 1 do + IPv6[n] := 0; + End; + for n := 0 to 7 do + begin + b1 := ipv6[n] div 256; + b2 := ipv6[n] mod 256; + Result[n * 2] := b1; + Result[(n * 2) + 1] := b2; + end; +end; + +{==============================================================================} +//based on routine by the Free Pascal development team +function Ip6ToStr(value: TIp6Bytes): string; +var + i, x: byte; + zr1,zr2: set of byte; + zc1,zc2: byte; + have_skipped: boolean; + ip6w: TIp6words; +begin + zr1 := []; + zr2 := []; + zc1 := 0; + zc2 := 0; + for i := 0 to 7 do + begin + x := i * 2; + ip6w[i] := value[x] * 256 + value[x + 1]; + if ip6w[i] = 0 then + begin + include(zr2, i); + inc(zc2); + end + else + begin + if zc1 < zc2 then + begin + zc1 := zc2; + zr1 := zr2; + zc2 := 0; + zr2 := []; + end; + end; + end; + if zc1 < zc2 then + begin + zr1 := zr2; + end; + SetLength(Result, 8*5-1); + SetLength(Result, 0); + have_skipped := false; + for i := 0 to 7 do + begin + if not(i in zr1) then + begin + if have_skipped then + begin + if Result = '' then + Result := '::' + else + Result := Result + ':'; + have_skipped := false; + end; + Result := Result + IntToHex(Ip6w[i], 1) + ':'; + end + else + begin + have_skipped := true; + end; + end; + if have_skipped then + if Result = '' then + Result := '::0' + else + Result := Result + ':'; + + if Result = '' then + Result := '::0'; + if not (7 in zr1) then + SetLength(Result, Length(Result)-1); + Result := LowerCase(result); +end; + +{==============================================================================} +function ReverseIP(Value: AnsiString): AnsiString; +var + x: Integer; +begin + Result := ''; + repeat + x := LastDelimiter('.', Value); + Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x); + Delete(Value, x, Length(Value) - x + 1); + until x < 1; + if Length(Result) > 0 then + if Result[1] = '.' then + Delete(Result, 1, 1); +end; + +{==============================================================================} +function ReverseIP6(Value: AnsiString): AnsiString; +var + ip6: TIp6bytes; + n: integer; +begin + ip6 := StrToIP6(Value); + Result := char(ip6[15]); + for n := 14 downto 0 do + Result := Result + '.' + char(ip6[n]); +end; + +{==============================================================================} +end. diff --git a/synamisc.pas b/synamisc.pas index 312d834..8b861a9 100644 --- a/synamisc.pas +++ b/synamisc.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 001.001.003 | +| Project : Ararat Synapse | 001.001.004 | |==============================================================================| | Content: misc. procedures and functions | |==============================================================================| @@ -67,9 +67,6 @@ uses {$IFDEF LINUX} Libc; {$ELSE} -{$IFDEF FPC} - winver, -{$ENDIF} Windows; {$ENDIF} diff --git a/synautil.pas b/synautil.pas index fab0f16..863fc2f 100644 --- a/synautil.pas +++ b/synautil.pas @@ -1,9 +1,9 @@ {==============================================================================| -| Project : Ararat Synapse | 004.008.001 | +| Project : Ararat Synapse | 004.010.001 | |==============================================================================| | Content: support procedures and functions | |==============================================================================| -| Copyright (c)1999-2004, Lukas Gebauer | +| Copyright (c)1999-2005, Lukas Gebauer | | All rights reserved. | | | | Redistribution and use in source and binary forms, with or without | @@ -33,7 +33,7 @@ | DAMAGE. | |==============================================================================| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| -| Portions created by Lukas Gebauer are Copyright (c) 1999-2004. | +| Portions created by Lukas Gebauer are Copyright (c) 1999-2005. | | Portions created by Hernan Sanchez are Copyright (c) 2000. | | All Rights Reserved. | |==============================================================================| @@ -58,15 +58,19 @@ unit synautil; interface uses -{$IFDEF LINUX} - Libc, -{$ELSE} +{$IFDEF WIN32} Windows, +{$ELSE} + {$IFDEF FPC} + UnixUtil, Unix, BaseUnix, + {$ELSE} + Libc, + {$ENDIF} {$ENDIF} {$IFDEF CIL} System.IO, {$ENDIF} - SysUtils, Classes; + SysUtils, Classes, SynaFpc; {:Return your timezone bias from UTC time in minutes.} function TimeZoneBias: integer; @@ -131,11 +135,11 @@ function SetUTTime(Newdt: TDateTime): Boolean; {:Return current value of system timer with precizion 1 millisecond. Good for measure time difference.} -function GetTick: ULong; +function GetTick: LongWord; {:Return difference between two timestamps. It working fine only for differences smaller then maxint. (difference must be smaller then 24 days.)} -function TickDelta(TickOld, TickNew: ULong): ULong; +function TickDelta(TickOld, TickNew: LongWord): LongWord; {:Return two characters, which ordinal values represents the value in byte format. (High-endian)} @@ -153,15 +157,6 @@ function CodeLongInt(Value: LongInt): Ansistring; string to LongInt values.} function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt; -{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!} -function IsIP(const Value: string): Boolean; - -{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!} -function IsIP6(const Value: string): Boolean; - -{:Returns a string with the "Host" ip address converted to binary form.} -function IPToID(Host: string): string; - {:Dump binary buffer stored in a string to a result string.} function DumpStr(const Buffer: Ansistring): string; @@ -341,19 +336,18 @@ var {==============================================================================} function TimeZoneBias: integer; -{$IFDEF LINUX} +{$IFNDEF WIN32} +{$IFNDEF FPC} var t: TTime_T; UT: TUnixTime; begin -{$IFNDEF FPC} __time(@T); localtime_r(@T, UT); Result := ut.__tm_gmtoff div 60; {$ELSE} - __time(T); - localtime_r(T, UT); - Result := ut.tm_gmtoff div 60; +begin + Result := TZSeconds div 60; {$ENDIF} {$ELSE} var @@ -688,7 +682,7 @@ end; {==============================================================================} function GetUTTime: TDateTime; -{$IFNDEF LINUX} +{$IFDEF WIN32} {$IFNDEF FPC} var st: TSystemTime; @@ -711,23 +705,26 @@ begin result := SystemTimeToDateTime(st); {$ENDIF} {$ELSE} +{$IFNDEF FPC} var TV: TTimeVal; - TZ: Ttimezone; - PZ: PTimeZone; begin - TZ.tz_minuteswest := 0; - TZ.tz_dsttime := 0; - PZ := @TZ; - gettimeofday(TV, PZ); + gettimeofday(TV, nil); Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; +{$ELSE} +var + TV: TimeVal; +begin + fpgettimeofday(@TV, nil); + Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400; +{$ENDIF} {$ENDIF} end; {==============================================================================} function SetUTTime(Newdt: TDateTime): Boolean; -{$IFNDEF LINUX} +{$IFDEF WIN32} {$IFNDEF FPC} var st: TSystemTime; @@ -750,6 +747,7 @@ begin Result := SetSystemTime(stw); {$ENDIF} {$ELSE} +{$IFNDEF FPC} var TV: TTimeVal; d: double; @@ -764,13 +762,23 @@ begin TV.tv_sec := trunc(d); TV.tv_usec := trunc(frac(d) * 1000000); Result := settimeofday(TV, TZ) <> -1; +{$ELSE} +var + TV: TimeVal; + d: double; +begin + d := (newdt - UnixDateDelta) * 86400; + TV.tv_sec := trunc(d); + TV.tv_usec := trunc(frac(d) * 1000000); + Result := fpsettimeofday(@TV, nil) <> -1; +{$ENDIF} {$ENDIF} end; {==============================================================================} -{$IFDEF LINUX} -function GetTick: ULong; +{$IFNDEF WIN32} +function GetTick: LongWord; var Stamp: TTimeStamp; begin @@ -778,15 +786,31 @@ begin Result := Stamp.Time; end; {$ELSE} -function GetTick: ULong; +function GetTick: LongWord; +var + tick, freq: TLargeInteger; +{$IFDEF VER100} + x: TLargeInteger; +{$ENDIF} begin - Result := Windows.GetTickCount; + if Windows.QueryPerformanceFrequency(freq) then + begin + Windows.QueryPerformanceCounter(tick); +{$IFDEF VER100} + x.QuadPart := (tick.QuadPart / freq.QuadPart) * 1000; + Result := x.LowPart; +{$ELSE} + Result := Trunc((tick / freq) * 1000) and High(LongWord) +{$ENDIF} + end + else + Result := Windows.GetTickCount; end; {$ENDIF} {==============================================================================} -function TickDelta(TickOld, TickNew: ULong): ULong; +function TickDelta(TickOld, TickNew: LongWord): LongWord; begin //if DWord is signed type (older Deplhi), // then it not work properly on differencies larger then maxint! @@ -795,8 +819,8 @@ begin begin if TickNew < TickOld then begin - TickNew := TickNew + ULong(MaxInt) + 1; - TickOld := TickOld + ULong(MaxInt) + 1; + TickNew := TickNew + LongWord(MaxInt) + 1; + TickOld := TickOld + LongWord(MaxInt) + 1; end; Result := TickNew - TickOld; if TickNew < TickOld then @@ -876,103 +900,6 @@ end; {==============================================================================} -function IsIP(const Value: string): Boolean; -var - TempIP: string; - function ByteIsOk(const Value: string): Boolean; - var - x, n: integer; - begin - x := StrToIntDef(Value, -1); - Result := (x >= 0) and (x < 256); - // X may be in correct range, but value still may not be correct value! - // i.e. "$80" - if Result then - for n := 1 to length(Value) do - if not (Value[n] in ['0'..'9']) then - begin - Result := False; - Break; - end; - end; -begin - TempIP := Value; - Result := False; - if not ByteIsOk(Fetch(TempIP, '.')) then - Exit; - if not ByteIsOk(Fetch(TempIP, '.')) then - Exit; - if not ByteIsOk(Fetch(TempIP, '.')) then - Exit; - if ByteIsOk(TempIP) then - Result := True; -end; - -{==============================================================================} - -function IsIP6(const Value: string): Boolean; -var - TempIP: string; - s,t: string; - x: integer; - partcount: integer; - zerocount: integer; - First: Boolean; -begin - TempIP := Value; - Result := False; - partcount := 0; - zerocount := 0; - First := True; - while tempIP <> '' do - begin - s := fetch(TempIP, ':'); - if not(First) and (s = '') then - Inc(zerocount); - First := False; - if zerocount > 1 then - break; - Inc(partCount); - if s = '' then - Continue; - if partCount > 8 then - break; - if tempIP = '' then - begin - t := SeparateRight(s, '%'); - s := SeparateLeft(s, '%'); - x := StrToIntDef('$' + t, -1); - if (x < 0) or (x > $ffff) then - break; - end; - x := StrToIntDef('$' + s, -1); - if (x < 0) or (x > $ffff) then - break; - if tempIP = '' then - Result := True; - end; -end; - -{==============================================================================} -//Hernan Sanchez -function IPToID(Host: string): string; -var - s: string; - i, x: Integer; -begin - Result := ''; - for x := 1 to 3 do - begin - s := Fetch(Host, '.'); - i := StrToIntDef(s, 0); - Result := Result + Chr(i); - end; - i := StrToIntDef(Host, 0); - Result := Result + Chr(i); -end; - -{==============================================================================} - function DumpStr(const Buffer: Ansistring): string; var n: Integer; @@ -1040,6 +967,9 @@ function TrimSPLeft(const S: string): string; var I, L: Integer; begin + Result := ''; + if S = '' then + Exit; L := Length(S); I := 1; while (I <= L) and (S[I] = ' ') do @@ -1053,6 +983,9 @@ function TrimSPRight(const S: string): string; var I: Integer; begin + Result := ''; + if S = '' then + Exit; I := Length(S); while (I > 0) and (S[I] = ' ') do Dec(I); @@ -1471,38 +1404,26 @@ end; function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer; var - p1, p2, p3, p4: integer; -const - t1 = #$0d + #$0a; - t2 = #$0a + #$0d; - t3 = #$0d; - t4 = #$0a; + n, l: integer; begin + Result := -1; Terminator := ''; - p1 := Pos(t1, Value); - p2 := Pos(t2, Value); - p3 := Pos(t3, Value); - p4 := Pos(t4, Value); - if p1 > 0 then - Terminator := t1; - Result := p1; - if (p2 > 0) then - if (Result = 0) or (p2 < Result) then + l := length(value); + for n := 1 to l do + if value[n] in [#$0d, #$0a] then begin - Result := p2; - Terminator := t2; - end; - if (p3 > 0) then - if (Result = 0) or (p3 < Result) then - begin - Result := p3; - Terminator := t3; - end; - if (p4 > 0) then - if (Result = 0) or (p4 < Result) then - begin - Result := p4; - Terminator := t4; + Result := n; + Terminator := Value[n]; + if n <> l then + case value[n] of + #$0d: + if value[n + 1] = #$0a then + Terminator := #$0d + #$0a; + #$0a: + if value[n + 1] = #$0d then + Terminator := #$0a + #$0d; + end; + Break; end; end; @@ -1553,7 +1474,7 @@ end; {$IFNDEF CIL} function IncPoint(const p: pointer; Value: integer): pointer; begin - Result := pointer(integer(p) + Value); + Result := PChar(p) + Value; end; {$ENDIF} @@ -1686,7 +1607,7 @@ end; procedure HeadersToList(const Value: TStrings); var - n, x: integer; + n, x, y: integer; s: string; begin for n := 0 to Value.Count -1 do @@ -1695,8 +1616,12 @@ begin x := Pos(':', s); if x > 0 then begin - s[x] := '='; - Value[n] := s; + y:= Pos('=',s); + if not ((y > 0) and (y < x)) then + begin + s[x] := '='; + Value[n] := s; + end; end; end; end; @@ -1775,7 +1700,7 @@ end; {==============================================================================} function GetTempFile(const Dir, prefix: AnsiString): AnsiString; {$IFNDEF FPC} -{$IFNDEF LINUX} +{$IFDEF WIN32} var Path: AnsiString; x: integer; @@ -1785,7 +1710,7 @@ begin {$IFDEF FPC} Result := GetTempFileName(Dir, Prefix); {$ELSE} - {$IFDEF LINUX} + {$IFNDEF WIN32} Result := tempnam(Pointer(Dir), Pointer(prefix)); {$ELSE} {$IFDEF CIL} diff --git a/synsock.pas b/synsock.pas index 4b4fc46..c4bc977 100644 --- a/synsock.pas +++ b/synsock.pas @@ -1,5 +1,5 @@ {==============================================================================| -| Project : Ararat Synapse | 005.000.000 | +| Project : Ararat Synapse | 005.001.000 | |==============================================================================| | Content: Socket Independent Platform Layer | |==============================================================================| @@ -52,13 +52,16 @@ unit synsock; {$I ssdotnet.pas} {$ENDIF} -{$IFDEF LINUX} - {$I sslinux.pas} -{$ENDIF} - {$IFDEF WIN32} {$I sswin32.pas} +{$ELSE} + {$IFDEF FPC} + {$I ssfpc.pas} + {$ELSE} + {$I sslinux.pas} + {$ENDIF} {$ENDIF} + end. diff --git a/winver.pp b/winver.pp deleted file mode 100644 index ae1e140..0000000 --- a/winver.pp +++ /dev/null @@ -1,76 +0,0 @@ -{ - $Id: header,v 1.1.2.1 2003/01/05 20:47:31 michael Exp $ - This file is part of the Free Pascal run time library. - Copyright (c) 2003 by the Free Pascal development team - - Windows Version detection functionality. - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} - -{$mode objfpc} -unit winver; - -Interface - -Uses Windows; - -const - Win32Platform : Integer = 0; - Win32MajorVersion : Integer = 0; - Win32MinorVersion : Integer = 0; - Win32BuildNumber : Integer = 0; - - Win32CSDVersion : string = ''; - -function CheckWin32Version(Major,Minor : Integer ): Boolean; -function CheckWin32Version(Major : Integer): Boolean; - -Implementation - - -uses sysutils; - -procedure InitVersion; - -var - Info: TOSVersionInfo; - -begin - Info.dwOSVersionInfoSize := SizeOf(Info); - if GetVersionEx(Info) then - with Info do - begin - Win32Platform:=dwPlatformId; - Win32MajorVersion:=dwMajorVersion; - Win32MinorVersion:=dwMinorVersion; - if (Win32Platform=VER_PLATFORM_WIN32_WINDOWS) then - Win32BuildNumber:=dwBuildNumber and $FFFF - else - Win32BuildNumber := dwBuildNumber; - Win32CSDVersion := StrPas(szCSDVersion); - end; -end; - -function CheckWin32Version(Major : Integer): Boolean; - -begin - Result:=CheckWin32Version(Major,0) -end; - -function CheckWin32Version(Major,Minor: Integer): Boolean; - -begin - Result := (Win32MajorVersion>Major) or - ((Win32MajorVersion=Major) and (Win32MinorVersion>=Minor)); -end; - -initialization - InitVersion; -end. \ No newline at end of file