pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 37

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@80 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 07:40:57 +00:00
parent a96a758414
commit 316ed093f8
26 changed files with 3601 additions and 1311 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

852
blcksock.pas
View File

File diff suppressed because it is too large Load Diff

218
clamsend.pas Normal file
View File

@ -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.

93
dnssend.pas
View File

@ -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;

13
ftpsend.pas
View File

@ -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;

173
httpsend.pas
View File

@ -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;

8
ldapsend.pas
View File

@ -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;

21
mimepart.pas
View File

@ -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, '</HEAD>');
t := SeparateRight(t, '<HEAD>');
t := ReplaceString(t, '"', '');
t := ReplaceString(t, ' ', '');
b := Pos('HTTP-EQUIV=CONTENT-TYPE', t) > 0;
if length(t) <> length(s) then
begin
t := SeparateRight(t, '<HEAD>');
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

26
pingsend.pas
View File

@ -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,

58
pop3send.pas
View File

@ -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);

2
snmpsend.pas
View File

@ -62,7 +62,7 @@ interface
uses
Classes, SysUtils,
blcksock, synautil, asn1util, synacode;
blcksock, synautil, asn1util, synaip, synacode;
const
cSnmpProtocol = '161';

142
ssdotnet.pas
View File

@ -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

868
ssfpc.pas Normal file
View File

@ -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}

42
ssl_cryptlib.pas
View File

@ -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;

22
ssl_openssl.pas
View File

@ -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);

12
ssl_openssl_lib.pas
View File

@ -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 = '';

594
ssl_sbb.pas Normal file
View File

@ -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)<Len then
begin
Result:=Length(FRecvDecodedBuffers);
Move(FRecvDecodedBuffers[1],Buffer^,Result);
FRecvDecodedBuffers:='';
end
else
begin
Result:=Len;
Move(FRecvDecodedBuffers[1],Buffer^,Result);
Delete(FRecvDecodedBuffers,1,Result);
end;
end;
function TSSLSBB.WaitingData: Integer;
var
lResult:Integer;
begin
// data available?
if FRecvBuffers<>'' 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.

459
sslinux.pas
View File

@ -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;

449
sswin32.pas
View File

@ -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;

4
synachar.pas
View File

@ -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

99
synafpc.pas
View File

@ -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.

8
synaicnv.pas
View File

@ -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;

390
synaip.pas Normal file
View File

@ -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.

5
synamisc.pas
View File

@ -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}

265
synautil.pas
View File

@ -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}

13
synsock.pas
View File

@ -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.

76
winver.pp
View File

@ -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.