pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 32

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@70 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 07:25:18 +00:00
parent 7960ad4609
commit 02ab154a09
27 changed files with 4012 additions and 683 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
asn1util.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.003.006 |
| Project : Ararat Synapse | 001.004.002 |
|==============================================================================|
| Content: support for ASN.1 BER coding and decoding |
|==============================================================================|
@ -45,20 +45,27 @@
|==============================================================================}
{$Q-}
{$H+}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
unit ASN1Util;
unit asn1util;
interface
uses
SysUtils;
SysUtils, Classes;
const
ASN1_BOOL = $01;
ASN1_INT = $02;
ASN1_OCTSTR = $04;
ASN1_NULL = $05;
ASN1_OBJID = $06;
ASN1_ENUM = $0a;
ASN1_SEQ = $30;
ASN1_SETOF = $31;
ASN1_IPADDR = $40;
ASN1_COUNTER = $41;
ASN1_GAUGE = $42;
@ -77,6 +84,7 @@ function ASNItem(var Start: Integer; const Buffer: string;
function MibToId(Mib: string): string;
function IdToMib(const Id: string): string;
function IntMibToStr(const Value: string): string;
function ASNdump(const Value: string): string;
implementation
@ -233,10 +241,11 @@ begin
if (Start + ASNSize - 1) > l then
Exit;
if (ASNType and $20) > 0 then
Result := '$' + IntToHex(ASNType, 2)
// Result := '$' + IntToHex(ASNType, 2)
Result := Copy(Buffer, Start, ASNSize)
else
case ASNType of
ASN1_INT:
ASN1_INT, ASN1_ENUM, ASN1_BOOL:
begin
y := 0;
neg := False;
@ -297,10 +306,20 @@ begin
end;
Result := s;
end;
else // NULL
ASN1_NULL:
begin
Result := '';
Start := Start + ASNSize;
end;
else // unknown
begin
Result := '';
Start := Start + ASNSize;
for n := 1 to ASNSize do
begin
c := Char(Buffer[Start]);
Inc(Start);
s := s + c;
end;
Result := s;
end;
end;
end;
@ -372,6 +391,75 @@ begin
Result := IntToStr(y);
end;
{==============================================================================}
function ASNdump(const Value: string): string;
var
i, at, x, n: integer;
s, indent: string;
il: TStringList;
begin
il := TStringList.Create;
try
Result := '';
i := 1;
indent := '';
while i < Length(Value) do
begin
for n := il.Count - 1 downto 0 do
begin
x := StrToIntDef(il[n], 0);
if x <= i then
begin
il.Delete(n);
Delete(indent, 1, 2);
end;
end;
s := ASNItem(i, Value, at);
Result := Result + indent + '$' + IntToHex(at, 2);
if (at and $20) > 0 then
begin
x := Length(s);
Result := Result + ' constructed: length ' + IntToStr(x);
indent := indent + ' ';
il.Add(IntToStr(x + i - 1));
end
else
begin
case at of
ASN1_BOOL:
Result := Result + ' BOOL: ';
ASN1_INT:
Result := Result + ' INT: ';
ASN1_ENUM:
Result := Result + ' ENUM: ';
ASN1_COUNTER:
Result := Result + ' COUNTER: ';
ASN1_GAUGE:
Result := Result + ' GAUGE: ';
ASN1_TIMETICKS:
Result := Result + ' TIMETICKS: ';
ASN1_OCTSTR:
Result := Result + ' OCTSTR: ';
ASN1_OPAQUE:
Result := Result + ' OPAQUE: ';
ASN1_OBJID:
Result := Result + ' OBJID: ';
ASN1_IPADDR:
Result := Result + ' IPADDR: ';
ASN1_NULL:
Result := Result + ' NULL: ';
else // other
Result := Result + ' unknown: ';
end;
Result := Result + s;
end;
Result := Result + #$0d + #$0a;
end;
finally
il.Free;
end;
end;
{==============================================================================}
end.

659
blcksock.pas
View File

File diff suppressed because it is too large Load Diff

32
dnssend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.002.002 |
| Project : Ararat Synapse | 002.003.004 |
|==============================================================================|
| Content: DNS client |
|==============================================================================|
@ -44,15 +44,19 @@
// RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit DNSsend;
unit dnssend;
interface
uses
SysUtils, Classes,
blcksock, SynaUtil, synsock;
blcksock, synautil, synsock;
const
cDnsProtocol = 'domain';
@ -89,7 +93,7 @@ const
QTYPE_LOC = 29; // RFC-1876
QTYPE_NXT = 30; // RFC-2065
QTYPE_SRV = 33; // RFC-2052
QTYPE_SRV = 33;
QTYPE_NAPTR = 35; // RFC-2168
QTYPE_KX = 36;
@ -294,7 +298,7 @@ function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList;
QType: Integer): string;
var
Rname: string;
RType, Len, j, x, n: Integer;
RType, Len, j, x, y, z, n: Integer;
R: string;
t1, t2, ttl: integer;
ip6: TSockAddrIn6;
@ -313,7 +317,7 @@ begin
Inc(i, 2); // i point to begin of data
j := i;
i := i + len; // i point to next record
if Length(FBuffer) >= i then
if Length(FBuffer) >= (i - 1) then
case RType of
QTYPE_A:
begin
@ -401,6 +405,20 @@ begin
R := R + ',' + DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_SRV:
// Author: Dan <ml@mutox.org>
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
y := DecodeInt(FBuffer, j);
Inc(j, 2);
z := DecodeInt(FBuffer, j);
Inc(j, 2);
R := IntToStr(x); // Priority
R := R + ',' + IntToStr(y); // Weight
R := R + ',' + IntToStr(z); // Port
R := R + ',' + DecodeLabels(j); // Server DNS Name
end;
end;
if R <> '' then
Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R);
@ -433,6 +451,7 @@ begin
FAuthoritative := False;
if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then
begin
Result := True;
flag := DecodeInt(Buf, 3);
FRCode := Flag and $000F;
FAuthoritative := (Flag and $0400) > 0;
@ -463,7 +482,6 @@ begin
if (arcount > 0) and (Length(Buf) > i) then // decode additional info
for n := 1 to arcount do
DecodeResource(i, FAdditionalInfo, QType);
Result := True;
end;
end;
end;

102
ftpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.006.006 |
| Project : Ararat Synapse | 002.007.000 |
|==============================================================================|
| Content: FTP client |
|==============================================================================|
@ -43,13 +43,23 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
unit FTPsend;
// RFC-959, RFC-2228, RFC-2428
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ftpsend;
interface
uses
SysUtils, Classes,
blcksock, SynaUtil, SynaCode;
{$IFDEF STREAMSEC}
TlsInternalServer, TlsSynaSock,
{$ENDIF}
blcksock, synautil, synacode;
const
cFtpProtocol = 'ftp';
@ -88,8 +98,14 @@ type
TFTPSend = class(TSynaClient)
private
FOnStatus: TFTPStatus;
{$IFDEF STREAMSEC}
FSock: TSsTCPBlockSocket;
FDSock: TSsTCPBlockSocket;
FTLSServer: TCustomTLSInternalServer;
{$ELSE}
FSock: TTCPBlockSocket;
FDSock: TTCPBlockSocket;
{$ENDIF}
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
@ -113,6 +129,8 @@ type
FBinaryMode: Boolean;
FAutoTLS: Boolean;
FIsTLS: Boolean;
FIsDataTLS: Boolean;
FTLSonData: Boolean;
FFullSSL: Boolean;
function Auth(Mode: integer): Boolean;
function Connect: Boolean;
@ -160,8 +178,14 @@ type
property FWUsername: string read FFWUsername Write FFWUsername;
property FWPassword: string read FFWPassword Write FFWPassword;
property FWMode: integer read FFWMode Write FFWMode;
{$IFDEF STREAMSEC}
property Sock: TSsTCPBlockSocket read FSock;
property DSock: TSsTCPBlockSocket read FDSock;
property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
{$ELSE}
property Sock: TTCPBlockSocket read FSock;
property DSock: TTCPBlockSocket read FDSock;
{$ENDIF}
property DataStream: TMemoryStream read FDataStream;
property DataIP: string read FDataIP;
property DataPort: string read FDataPort;
@ -176,6 +200,8 @@ type
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
property FullSSL: Boolean read FFullSSL Write FFullSSL;
property IsTLS: Boolean read FIsTLS;
property IsDataTLS: Boolean read FIsDataTLS;
property TLSonData: Boolean read FTLSonData write FTLSonData;
end;
function FtpGetFile(const IP, Port, FileName, LocalFile,
@ -193,9 +219,18 @@ begin
inherited Create;
FFullResult := TStringList.Create;
FDataStream := TMemoryStream.Create;
{$IFDEF STREAMSEC}
FTLSServer := GlobalTLSInternalServer;
FSock := TSsTCPBlockSocket.Create;
FSock.BlockingRead := True;
FSock.ConvertLineEnd := True;
FDSock := TSsTCPBlockSocket.Create;
FDSock.BlockingRead := True;
{$ELSE}
FSock := TTCPBlockSocket.Create;
FSock.ConvertLineEnd := True;
FDSock := TTCPBlockSocket.Create;
{$ENDIF}
FFtpList := TFTPList.Create;
FTimeout := 300000;
FTargetPort := cFtpProtocol;
@ -214,6 +249,8 @@ begin
FAutoTLS := False;
FFullSSL := False;
FIsTLS := False;
FIsDataTLS := False;
FTLSonData := True;
end;
destructor TFTPSend.Destroy;
@ -447,8 +484,23 @@ function TFTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
{$IFDEF STREAMSEC}
if FFullSSL then
begin
if assigned(FTLSServer) then
FSock.TLSServer := FTLSServer
else
begin
result := False;
Exit;
end;
end
else
FSock.TLSServer := nil;
{$ELSE}
if FFullSSL then
FSock.SSLEnabled := True;
{$ENDIF}
if FSock.LastError = 0 then
if FFWHost = '' then
FSock.Connect(FTargetHost, FTargetPort)
@ -464,19 +516,37 @@ begin
if not Connect then
Exit;
FIsTLS := FFullSSL;
FIsDataTLS := False;
if (ReadResult div 100) <> 2 then
Exit;
if FAutoTLS and not(FIsTLS) then
if (FTPCommand('AUTH TLS') div 100) = 2 then
begin
{$IFDEF STREAMSEC}
if Assigned(FTLSServer) then
begin
Fsock.TLSServer := FTLSServer;
Fsock.Connect('','');
FIsTLS := FSock.LastError = 0;
end
else
Result := False;
{$ELSE}
FSock.SSLDoConnect;
FIsTLS := True;
FIsTLS := FSock.LastError = 0;
FDSock.SSLCertificateFile := FSock.SSLCertificateFile;
FDSock.SSLPrivateKeyFile := FSock.SSLPrivateKeyFile;
FDSock.SSLCertCAFile := FSock.SSLCertCAFile;
{$ENDIF}
end;
if not Auth(FFWMode) then
Exit;
if FIsTLS then
begin
FTPCommand('PROT P');
if FTLSonData then
FIsDataTLS := (FTPCommand('PROT P') div 100) = 2;
if not FIsDataTLS then
FTPCommand('PROT C');
FTPCommand('PBSZ 0');
end;
FTPCommand('TYPE I');
@ -627,8 +697,22 @@ begin
Result := True;
end;
end;
if FIsTLS then
if Result and FIsDataTLS then
begin
{$IFDEF STREAMSEC}
if Assigned(FTLSServer) then
begin
FDSock.TLSServer := FTLSServer;
FDSock.Connect('','');
Result := FDSock.LastError = 0;
end
else
Result := False;
{$ELSE}
FDSock.SSLDoConnect;
Result := FDSock.LastError = 0;
{$ENDIF}
end;
end;
function TFTPSend.DataRead(const DestStream: TStream): Boolean;
@ -908,7 +992,7 @@ end;
procedure TFTPSend.Abort;
begin
FDSock.CloseSocket;
FDSock.AbortSocket;
end;
{==============================================================================}
@ -1072,6 +1156,10 @@ begin
else Exit;
if (year = 0) or (month = 0) or (mday = 0) then
Exit;
// for date 2-29 find last leap year. (fix for non-existent year)
if (month = 2) and (mday = 29) then
while not IsLeapYear(year) do
Dec(year);
flr.FileTime := t + Encodedate(year, month, mday);
end;
3 : begin

352
ftptsend.pas Normal file
View File

@ -0,0 +1,352 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.002 |
|==============================================================================|
| Content: Trivial FTP (TFTP) client and server |
|==============================================================================|
| Copyright (c)1999-2003, 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/) |
|==============================================================================}
// RFC-1350
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit ftptsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cTFTPProtocol = '69';
type
TTFTPSend = class(TSynaClient)
private
FSock: TUDPBlockSocket;
FErrorCode: integer;
FErrorString: string;
FData: TMemoryStream;
FRequestIP: string;
FRequestPort: string;
function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
function RecvPacket(Serial: word; var Value: string): Boolean;
public
constructor Create;
destructor Destroy; override;
function SendFile(const Filename: string): Boolean;
function RecvFile(const Filename: string): Boolean;
function WaitForRequest(var Req: word; var filename: string): Boolean;
procedure ReplyError(Error: word; Description: string);
function ReplyRecv: Boolean;
function ReplySend: Boolean;
published
property ErrorCode: integer read FErrorCode;
property ErrorString: string read FErrorString;
property Data: TMemoryStream read FData;
property RequestIP: string read FRequestIP write FRequestIP;
property RequestPort: string read FRequestPort write FRequestPort;
end;
implementation
constructor TTFTPSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FTargetPort := cTFTPProtocol;
FData := TMemoryStream.Create;
FErrorCode := 0;
FErrorString := '';
end;
destructor TTFTPSend.Destroy;
begin
FSock.Free;
FData.Free;
inherited Destroy;
end;
function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
var
s, sh: string;
begin
FErrorCode := 0;
FErrorString := '';
Result := false;
if Cmd <> 2 then
s := CodeInt(Cmd) + CodeInt(Serial) + Value
else
s := CodeInt(Cmd) + Value;
FSock.SendString(s);
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
if length(s) >= 4 then
begin
sh := CodeInt(4) + CodeInt(Serial);
if Pos(sh, s) = 1 then
Result := True
else
if s[1] = #5 then
begin
FErrorCode := DecodeInt(s, 3);
Delete(s, 1, 4);
FErrorString := SeparateLeft(s, #0);
end;
end;
end;
function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
var
s: string;
ser: word;
begin
FErrorCode := 0;
FErrorString := '';
Result := False;
Value := '';
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
if length(s) >= 4 then
if DecodeInt(s, 1) = 3 then
begin
ser := DecodeInt(s, 3);
if ser = Serial then
begin
Delete(s, 1, 4);
Value := s;
S := CodeInt(4) + CodeInt(ser);
FSock.SendString(s);
Result := FSock.LastError = 0;
end
else
begin
S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
FSock.SendString(s);
end;
end;
if DecodeInt(s, 1) = 5 then
begin
FErrorCode := DecodeInt(s, 3);
Delete(s, 1, 4);
FErrorString := SeparateLeft(s, #0);
end;
end;
function TTFTPSend.SendFile(const Filename: string): Boolean;
var
s: string;
ser: word;
n, n1, n2: integer;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FTargetHost, FTargetPort);
try
if FSock.LastError = 0 then
begin
s := Filename + #0 + 'octet' + #0;
if not Sendpacket(2, 0, s) then
Exit;
ser := 1;
FData.Position := 0;
n1 := FData.Size div 512;
n2 := FData.Size mod 512;
for n := 1 to n1 do
begin
SetLength(s, 512);
FData.Read(pointer(s)^, 512);
if not Sendpacket(3, ser, s) then
Exit;
inc(ser);
end;
SetLength(s, n2);
FData.Read(pointer(s)^, n2);
if not Sendpacket(3, ser, s) then
Exit;
Result := True;
end;
finally
FSock.CloseSocket;
end;
end;
function TTFTPSend.RecvFile(const Filename: string): Boolean;
var
s: string;
ser: word;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FTargetHost, FTargetPort);
try
if FSock.LastError = 0 then
begin
s := CodeInt(1) + Filename + #0 + 'octet' + #0;
FSock.SendString(s);
if FSock.LastError <> 0 then
Exit;
FData.Clear;
ser := 1;
repeat
if not RecvPacket(ser, s) then
Exit;
inc(ser);
FData.Write(pointer(s)^, length(s));
until length(s) <> 512;
FData.Position := 0;
Result := true;
end;
finally
FSock.CloseSocket;
end;
end;
function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
var
s: string;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Bind('0.0.0.0', FTargetPort);
if FSock.LastError = 0 then
begin
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
if Length(s) >= 4 then
begin
FRequestIP := FSock.GetRemoteSinIP;
FRequestPort := IntToStr(FSock.GetRemoteSinPort);
Req := DecodeInt(s, 1);
delete(s, 1, 2);
filename := SeparateLeft(s, #0);
s := SeparateRight(s, #0);
s := SeparateLeft(s, #0);
Result := lowercase(s) = 'octet';
end;
end;
end;
procedure TTFTPSend.ReplyError(Error: word; Description: string);
var
s: string;
begin
FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort);
s := CodeInt(5) + CodeInt(Error) + Description + #0;
FSock.SendString(s);
FSock.CloseSocket;
end;
function TTFTPSend.ReplyRecv: Boolean;
var
s: string;
ser: integer;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort);
try
s := CodeInt(4) + CodeInt(0);
FSock.SendString(s);
FData.Clear;
ser := 1;
repeat
if not RecvPacket(ser, s) then
Exit;
inc(ser);
FData.Write(pointer(s)^, length(s));
until length(s) <> 512;
FData.Position := 0;
Result := true;
finally
FSock.CloseSocket;
end;
end;
function TTFTPSend.ReplySend: Boolean;
var
s: string;
ser: word;
n, n1, n2: integer;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort);
try
ser := 1;
FData.Position := 0;
n1 := FData.Size div 512;
n2 := FData.Size mod 512;
for n := 1 to n1 do
begin
SetLength(s, 512);
FData.Read(pointer(s)^, 512);
if not Sendpacket(3, ser, s) then
Exit;
inc(ser);
end;
SetLength(s, n2);
FData.Read(pointer(s)^, n2);
if not Sendpacket(3, ser, s) then
Exit;
Result := True;
finally
FSock.CloseSocket;
end;
end;
{==============================================================================}
end.

15
httpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 003.006.004 |
| Project : Ararat Synapse | 003.006.007 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
@ -42,7 +42,14 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
unit HTTPSend;
//RFC-1867, RFC-1947, RFC-2388, RFC-2616
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit httpsend;
interface
@ -51,7 +58,7 @@ uses
{$IFDEF STREAMSEC}
TlsInternalServer, TlsSynaSock,
{$ENDIF}
blcksock, SynaUtil, SynaCode;
blcksock, synautil, synacode;
const
cHttpProtocol = '80';
@ -530,7 +537,7 @@ end;
procedure THTTPSend.Abort;
begin
FSock.CloseSocket;
FSock.AbortSocket;
end;
{==============================================================================}

39
imapsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.003.005 |
| Project : Ararat Synapse | 002.004.002 |
|==============================================================================|
| Content: IMAP4rev1 client |
|==============================================================================|
@ -42,10 +42,14 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-2060
//RFC-2595
//RFC-2060, RFC-2595
unit IMAPsend;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit imapsend;
interface
@ -54,7 +58,7 @@ uses
{$IFDEF STREAMSEC}
TlsInternalServer, TlsSynaSock,
{$ENDIF}
blcksock, SynaUtil, SynaCode;
blcksock, synautil, synacode;
const
cIMAPProtocol = '143';
@ -121,6 +125,8 @@ type
function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
function SetFlagsMess(MessID: integer; Flags: string): Boolean;
function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
function AddFlagsMess(MessID: integer; Flags: string): Boolean;
function DelFlagsMess(MessID: integer; Flags: string): Boolean;
function StartTLS: Boolean;
function GetUID(MessID: integer; var UID : Integer): Boolean;
function FindCap(const Value: string): string;
@ -556,7 +562,8 @@ begin
ProcessLiterals;
for n := 0 to FFullResult.Count - 1 do
begin
s := UpperCase(FFullResult[n]);
s := FFullResult[n];
// s := UpperCase(FFullResult[n]);
if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then
begin
t := SeparateRight(s, Value);
@ -674,6 +681,26 @@ begin
Result := IMAPcommand(s) = 'OK';
end;
function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean;
var
s: string;
begin
s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')';
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
end;
function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean;
var
s: string;
begin
s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')';
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
end;
function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean;
var
s: string;

1095
ldapsend.pas Normal file
View File

File diff suppressed because it is too large Load Diff

39
mimeinln.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.007 |
| Project : Ararat Synapse | 001.001.002 |
|==============================================================================|
| Content: Inline MIME support procedures and functions |
|==============================================================================|
@ -42,18 +42,27 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
unit MIMEinLn;
//RFC-1522
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit mimeinln;
interface
uses
SysUtils, Classes,
SynaChar, SynaCode, SynaUtil;
synachar, synacode, synautil;
function InlineDecode(const Value: string; CP: TMimeChar): string;
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
function NeedInline(const Value: string): boolean;
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
function InlineCode(const Value: string): string;
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
function InlineEmail(const Value: string): string;
implementation
@ -166,16 +175,16 @@ end;
{==============================================================================}
function InlineCode(const Value: string): string;
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
var
c: TMimeChar;
begin
if NeedInline(Value) then
begin
c := IdealCharsetCoding(Value, GetCurCP,
c := IdealCharsetCoding(Value, FromCP,
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
Result := InlineEncode(Value, GetCurCP, c);
Result := InlineEncode(Value, FromCP, c);
end
else
Result := Value;
@ -183,7 +192,14 @@ end;
{==============================================================================}
function InlineEmail(const Value: string): string;
function InlineCode(const Value: string): string;
begin
Result := InlineCodeEx(Value, GetCurCP);
end;
{==============================================================================}
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
var
sd, se: string;
begin
@ -192,7 +208,14 @@ begin
if sd = '' then
Result := se
else
Result := '"' + InlineCode(sd) + '"<' + se + '>';
Result := '"' + InlineCodeEx(sd, FromCP) + '"<' + se + '>';
end;
{==============================================================================}
function InlineEmail(const Value: string): string;
begin
Result := InlineEmailEx(Value, GetCurCP);
end;
end.

34
mimemess.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.001.003 |
| Project : Ararat Synapse | 002.002.003 |
|==============================================================================|
| Content: MIME message object |
|==============================================================================|
@ -42,13 +42,18 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
unit MIMEmess;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit mimemess;
interface
uses
Classes, SysUtils,
MIMEpart, SynaChar, SynaUtil, MIMEinLn;
mimepart, synachar, synautil, mimeinln;
type
TMessHeader = class(TObject)
@ -61,6 +66,7 @@ type
FCustomHeaders: TStringList;
FDate: TDateTime;
FXMailer: string;
FCharsetCode: TMimeChar;
public
constructor Create;
destructor Destroy; override;
@ -78,6 +84,7 @@ type
property CustomHeaders: TStringList read FCustomHeaders;
property Date: TDateTime read FDate Write FDate;
property XMailer: string read FXMailer Write FXMailer;
property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
end;
TMimeMess = class(TObject)
@ -117,6 +124,7 @@ begin
FToList := TStringList.Create;
FCCList := TStringList.Create;
FCustomHeaders := TStringList.Create;
FCharsetCode := GetCurCP;
end;
destructor TMessHeader.Destroy;
@ -157,27 +165,27 @@ begin
Value.Insert(0, 'X-mailer: ' + FXMailer);
Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
if FOrganization <> '' then
Value.Insert(0, 'Organization: ' + InlineCode(FOrganization));
Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode));
s := '';
for n := 0 to FCCList.Count - 1 do
if s = '' then
s := InlineEmail(FCCList[n])
s := InlineEmailEx(FCCList[n], FCharsetCode)
else
s := s + ' , ' + InlineEmail(FCCList[n]);
s := s + ' , ' + InlineEmailEx(FCCList[n], FCharsetCode);
if s <> '' then
Value.Insert(0, 'CC: ' + s);
Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
if FSubject <> '' then
Value.Insert(0, 'Subject: ' + InlineCode(FSubject));
Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode));
s := '';
for n := 0 to FToList.Count - 1 do
if s = '' then
s := InlineEmail(FToList[n])
s := InlineEmailEx(FToList[n], FCharsetCode)
else
s := s + ' , ' + InlineEmail(FToList[n]);
s := s + ' , ' + InlineEmailEx(FToList[n], FCharsetCode);
if s <> '' then
Value.Insert(0, 'To: ' + s);
Value.Insert(0, 'From: ' + InlineEmail(FFrom));
Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
end;
procedure TMessHeader.DecodeHeaders(const Value: TStrings);
@ -186,7 +194,7 @@ var
x: Integer;
cp: TMimeChar;
begin
cp := GetCurCP;
cp := FCharsetCode;
Clear;
x := 0;
while Value.Count > x do
@ -218,7 +226,7 @@ begin
begin
s := SeparateRight(s, ':');
repeat
t := InlineDecode(fetch(s, ','), cp);
t := InlineDecode(FetchEx(s, ',', '"'), cp);
if t <> '' then
FToList.Add(t);
until s = '';
@ -228,7 +236,7 @@ begin
begin
s := SeparateRight(s, ':');
repeat
t := InlineDecode(fetch(s, ','), cp);
t := InlineDecode(FetchEx(s, ',', '"'), cp);
if t <> '' then
FCCList.Add(t);
until s = '';

191
mimepart.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.003.004 |
| Project : Ararat Synapse | 002.004.008 |
|==============================================================================|
| Content: MIME support procedures and functions |
|==============================================================================|
@ -42,16 +42,25 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
unit MIMEpart;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit mimepart;
interface
uses
SysUtils, Classes,
{$IFNDEF LINUX}
{$IFDEF LINUX}
{$IFDEF FPC}
synafpc,
{$ENDIF}
{$ELSE}
Windows,
{$ENDIF}
SynaChar, SynaCode, SynaUtil, MIMEinLn;
synachar, synacode, synautil, mimeinln;
type
@ -89,9 +98,13 @@ type
FSubParts: TList;
FOnWalkPart: THookWalkPart;
FMaxLineLength: integer;
FSubLevel: integer;
FMaxSubLevel: integer;
FAttachInside: boolean;
procedure SetPrimary(Value: string);
procedure SetEncoding(Value: string);
procedure SetCharset(Value: string);
function IsUUcode(Value: string): boolean;
public
constructor Create;
destructor Destroy; override;
@ -111,6 +124,7 @@ type
procedure DecomposeParts;
procedure ComposeParts;
procedure WalkPart;
function CanSubPart: boolean;
published
property Primary: string read FPrimary write SetPrimary;
property Encoding: string read FEncoding write SetEncoding;
@ -132,6 +146,9 @@ type
property PrePart: TStringList read FPrePart;
property PostPart: TStringList read FPostPart;
property DecodedLines: TMemoryStream read FDecodedLines;
property SubLevel: integer read FSubLevel write FSubLevel;
property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel;
property AttachInside: boolean read FAttachInside;
property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart;
property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength;
end;
@ -216,6 +233,9 @@ begin
FTargetCharset := GetCurCP;
FDefaultCharset := 'US-ASCII';
FMaxLineLength := 78;
FSubLevel := 0;
FMaxSubLevel := -1;
FAttachInside := false;
end;
destructor TMIMEPart.Destroy;
@ -248,6 +268,7 @@ begin
FDescription := '';
FBoundary := '';
FFileName := '';
FAttachInside := False;
FPartBody.Clear;
FHeaders.Clear;
FPrePart.Clear;
@ -280,6 +301,7 @@ begin
PrePart.Assign(Value.PrePart);
PostPart.Assign(Value.PostPart);
MaxLineLength := Value.MaxLineLength;
FAttachInside := Value.AttachInside;
end;
{==============================================================================}
@ -342,6 +364,7 @@ begin
Result := TMimePart.Create;
Result.DefaultCharset := FDefaultCharset;
FSubParts.Add(Result);
Result.SubLevel := FSubLevel + 1;
end;
{==============================================================================}
@ -374,7 +397,6 @@ begin
Break;
FHeaders.Add(s);
end;
StringsTrim(FHeaders);
DecodePartHeader;
//extract prepart
if FPrimaryCode = MP_MULTIPART then
@ -387,29 +409,39 @@ begin
if s = '--' + FBoundary then
Break;
FPrePart.Add(s);
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
StringsTrim(FPrePart);
end;
//extract body part
if FPrimaryCode = MP_MULTIPART then
begin
repeat
Mime := AddSubPart;
while FLines.Count > x do
if CanSubPart then
begin
Mime := AddSubPart;
while FLines.Count > x do
begin
s := FLines[x];
Inc(x);
if Pos('--' + FBoundary, s) = 1 then
Break;
Mime.Lines.Add(s);
end;
StringsTrim(Mime.Lines);
Mime.DecomposeParts;
end
else
begin
s := FLines[x];
Inc(x);
if Pos('--' + FBoundary, s) = 1 then
Break;
Mime.Lines.Add(s);
FPartBody.Add(s);
end;
StringsTrim(Mime.Lines);
Mime.DecomposeParts;
if x >= FLines.Count then
break;
until s = '--' + FBoundary + '--';
end;
if FPrimaryCode = MP_MESSAGE then
if (FPrimaryCode = MP_MESSAGE) and CanSubPart then
begin
Mime := AddSubPart;
SkipEmpty;
@ -430,6 +462,8 @@ begin
s := TrimRight(FLines[x]);
Inc(x);
FPartBody.Add(s);
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
StringsTrim(FPartBody);
end;
@ -442,6 +476,8 @@ begin
s := TrimRight(FLines[x]);
Inc(x);
FPostPart.Add(s);
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
StringsTrim(FPostPart);
end;
@ -502,14 +538,12 @@ begin
if FPrimaryCode = MP_MULTIPART then
begin
Flines.AddStrings(FPrePart);
Flines.Add('');
for n := 0 to GetSubPartCount - 1 do
begin
Flines.Add('--' + FBoundary);
mime := GetSubPart(n);
mime.ComposeParts;
FLines.AddStrings(mime.Lines);
Flines.Add('');
end;
Flines.Add('--' + FBoundary + '--');
Flines.AddStrings(FPostPart);
@ -522,70 +556,43 @@ begin
mime := GetSubPart(0);
mime.ComposeParts;
FLines.AddStrings(mime.Lines);
Flines.Add('');
end;
end
else
//if normal part
begin
FLines.AddStrings(FPartBody);
Flines.Add('');
end;
end;
{==============================================================================}
procedure TMIMEPart.DecodePart;
const
CRLF = #13#10;
var
n: Integer;
s: string;
begin
FDecodedLines.Clear;
for n := 0 to FPartBody.Count - 1 do
begin
s := FPartBody[n];
case FEncodingCode of
ME_7BIT:
begin
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
s := s + CRLF;
end;
ME_8BIT:
begin
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
s := s + CRLF;
end;
ME_QUOTED_PRINTABLE:
begin
if s = '' then
s := CRLF
case FEncodingCode of
ME_QUOTED_PRINTABLE:
s := DecodeQuotedPrintable(FPartBody.Text);
ME_BASE64:
s := DecodeBase64(FPartBody.Text);
ME_UU, ME_XX:
begin
s := '';
for n := 0 to FPartBody.Count - 1 do
if FEncodingCode = ME_UU then
s := s + DecodeUU(FPartBody[n])
else
if s[Length(s)] <> '=' then
s := s + CRLF;
s := DecodeQuotedPrintable(s);
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end;
ME_BASE64:
begin
if s <> '' then
s := DecodeBase64(s);
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end;
ME_UU:
if s <> '' then
s := DecodeUU(s);
ME_XX:
if s <> '' then
s := DecodeXX(s);
end;
FDecodedLines.Write(Pointer(s)^, Length(s));
s := s + DecodeXX(FPartBody[n]);
end;
else
s := FPartBody.Text;
end;
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
FDecodedLines.Write(Pointer(s)^, Length(s));
FDecodedLines.Seek(0, soFromBeginning);
end;
@ -647,9 +654,9 @@ begin
if Pos('CONTENT-ID:', su) = 1 then
FContentID := SeparateRight(s, ':');
end;
if (PrimaryCode = MP_BINARY) and (FFileName = '') then
if FFileName = '' then
FFileName := fn;
FFileName := InlineDecode(FFileName, getCurCP);
FFileName := InlineDecode(FFileName, FTargetCharset);
FFileName := ExtractFileName(FFileName);
end;
@ -687,7 +694,15 @@ begin
end
else
begin
l.LoadFromStream(FDecodedLines);
if FPrimaryCode = MP_BINARY then
begin
SetLength(s, FDecodedLines.Size);
x := FDecodedLines.Read(pointer(s)^, FDecodedLines.Size);
Setlength(s, x);
l.Add(s);
end
else
l.LoadFromStream(FDecodedLines);
for n := 0 to l.Count - 1 do
begin
s := l[n];
@ -695,8 +710,10 @@ begin
s := CharsetConversion(s, FTargetCharset, FCharsetCode);
if FEncodingCode = ME_QUOTED_PRINTABLE then
begin
s := EncodeTriplet(s, '=', [Char(1)..Char(31), '=', Char(128)..Char(255)]);
// s := EncodeQuotedPrintable(s);
if FPrimaryCode = MP_BINARY then
s := EncodeQuotedPrintable(s)
else
s := EncodeTriplet(s, '=', [Char(0)..Char(31), '=', Char(127)..Char(255)]);
repeat
if Length(s) < FMaxLineLength then
begin
@ -717,7 +734,7 @@ begin
if x = 0 then
x := FMaxLineLength;
t := Copy(s, 1, x);
s := Copy(s, x + 1, Length(s) - x);
Delete(s, 1, x);
if s <> '' then
t := t + '=';
end;
@ -727,6 +744,9 @@ begin
else
FPartBody.Add(s);
end;
if (FPrimaryCode = MP_BINARY)
and (FEncodingCode = ME_QUOTED_PRINTABLE) then
FPartBody[FPartBody.Count - 1] := FPartBody[FPartBody.Count - 1] + '=';
end;
end;
finally
@ -758,7 +778,7 @@ begin
begin
s := '';
if FFileName <> '' then
s := '; FileName="' + InlineCode(FFileName) + '"';
s := '; FileName="' + InlineCodeEx(FileName, FTargetCharset) + '"';
FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
end;
if FContentID <> '' then
@ -783,11 +803,11 @@ begin
s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode);
MP_MULTIPART:
s := FPrimary + '/' + FSecondary + '; boundary="' + FBoundary + '"';
MP_MESSAGE:
s := FPrimary + '/' + FSecondary + '';
MP_BINARY:
s := FPrimary + '/' + FSecondary + '; name="' + FFileName + '"';
MP_MESSAGE, MP_BINARY:
s := FPrimary + '/' + FSecondary;
end;
if FFileName <> '' then
s := s + '; name="' + InlineCodeEx(FileName, FTargetCharset) + '"';
FHeaders.Insert(0, 'Content-type: ' + s);
end;
@ -878,16 +898,35 @@ begin
FCharsetCode := GetCPFromID(Value);
end;
function TMIMEPart.CanSubPart: boolean;
begin
Result := True;
if FMaxSubLevel <> -1 then
Result := FMaxSubLevel > FSubLevel;
end;
function TMIMEPart.IsUUcode(Value: string): boolean;
begin
Value := UpperCase(Value);
Result := (pos('BEGIN ', Value) = 1) and (SeparateRight(Value, ' ') <> '');
end;
{==============================================================================}
function GenerateBoundary: string;
var
x: Integer;
x, y: Integer;
begin
Sleep(1);
y := GetTick;
x := y;
while TickDelta(y, x) = 0 do
begin
Sleep(1);
x := GetTick;
end;
Randomize;
x := Random(MaxInt);
Result := IntToHex(x, 8) + '_Synapse_message_boundary';
y := Random(MaxInt);
Result := IntToHex(x, 8) + '_' + IntToHex(y, 8) + '_Synapse_boundary';
end;
end.

13
nntpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.003.001 |
| Project : Ararat Synapse | 001.003.003 |
|==============================================================================|
| Content: NNTP client |
|==============================================================================|
@ -42,7 +42,14 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
unit NNTPsend;
//RFC-977, RFC-2980
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit nntpsend;
interface
@ -51,7 +58,7 @@ uses
{$IFDEF STREAMSEC}
TlsInternalServer, TlsSynaSock,
{$ENDIF}
blcksock, SynaUtil, SynaCode;
blcksock, synautil, synacode;
const
cNNTPProtocol = 'nntp';

199
pingsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 003.000.002 |
| Project : Ararat Synapse | 003.001.005 |
|==============================================================================|
| Content: PING sender |
|==============================================================================|
@ -42,10 +42,14 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}
unit PINGsend;
unit pingsend;
interface
@ -56,13 +60,18 @@ uses
Windows,
{$ENDIF}
SysUtils,
synsock, blcksock, SynaUtil;
synsock, blcksock, synautil;
const
ICMP_ECHO = 8;
ICMP_ECHOREPLY = 0;
ICMP_UNREACH = 3;
ICMP_TIME_EXCEEDED = 11;
//rfc-2292
ICMP6_ECHO = 128;
ICMP6_ECHOREPLY = 129;
ICMP6_UNREACH = 1;
ICMP6_TIME_EXCEEDED = 3;
type
TIcmpEchoHeader = record
@ -84,6 +93,17 @@ type
proto: Byte;
end;
TICMPError = (
IE_NoError,
IE_Other,
IE_TTLExceed,
IE_UnreachOther,
IE_UnreachRoute,
IE_UnreachAdmin,
IE_UnreachAddr,
IE_UnreachPort
);
TPINGSend = class(TSynaClient)
private
FSock: TICMPBlockSocket;
@ -94,9 +114,16 @@ type
FPingTime: Integer;
FIcmpEcho: Byte;
FIcmpEchoReply: Byte;
FIcmpUnreach: Byte;
FReplyFrom: string;
FReplyType: byte;
FReplyCode: byte;
FReplyError: TICMPError;
FReplyErrorDesc: string;
function Checksum(Value: string): Word;
function Checksum6(Value: string): Word;
function ReadPacket: Boolean;
procedure TranslateError;
public
function Ping(const Host: string): Boolean;
constructor Create;
@ -104,10 +131,16 @@ type
published
property PacketSize: Integer read FPacketSize Write FPacketSize;
property PingTime: Integer read FPingTime;
property ReplyFrom: string read FReplyFrom;
property ReplyType: byte read FReplyType;
property ReplyCode: byte read FReplyCode;
property ReplyError: TICMPError read FReplyError;
property ReplyErrorDesc: string read FReplyErrorDesc;
property Sock: TICMPBlockSocket read FSock;
end;
function PingHost(const Host: string): Integer;
function TraceRouteHost(const Host: string): string;
implementation
@ -140,11 +173,16 @@ var
IPHeadPtr: ^TIPHeader;
IpHdrLen: Integer;
IcmpEchoHeaderPtr: ^TICMPEchoHeader;
n: Integer;
t: Boolean;
x: cardinal;
begin
Result := False;
FPingTime := -1;
FReplyFrom := '';
FReplyType := 0;
FReplyCode := 0;
FReplyError := IE_NoError;
FReplyErrorDesc := '';
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(Host, '0');
if FSock.LastError <> 0 then
@ -154,32 +192,33 @@ begin
begin
FIcmpEcho := ICMP6_ECHO;
FIcmpEchoReply := ICMP6_ECHOREPLY;
FIcmpUnreach := ICMP6_UNREACH;
end
else
begin
FIcmpEcho := ICMP_ECHO;
FIcmpEchoReply := ICMP_ECHOREPLY;
FIcmpUnreach := ICMP_UNREACH;
end;
FBuffer := StringOfChar(#0, SizeOf(TICMPEchoHeader) + FPacketSize);
FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
IcmpEchoHeaderPtr := Pointer(FBuffer);
with IcmpEchoHeaderPtr^ do
begin
i_type := FIcmpEcho;
i_code := 0;
i_CheckSum := 0;
FId := Random(32767);
FId := System.Random(32767);
i_Id := FId;
TimeStamp := GetTick;
Inc(FSeq);
i_Seq := FSeq;
for n := Succ(SizeOf(TIcmpEchoHeader)) to Length(FBuffer) do
FBuffer[n] := #$55;
if fSock.IP6used then
i_CheckSum := CheckSum6(FBuffer)
else
i_CheckSum := CheckSum(FBuffer);
end;
if fSock.IP6used then
IcmpEchoHeaderPtr^.i_CheckSum := CheckSum6(FBuffer)
else
IcmpEchoHeaderPtr^.i_CheckSum := CheckSum(FBuffer);
FSock.SendString(FBuffer);
x := GetTick;
repeat
t := ReadPacket;
if not t then
@ -200,31 +239,35 @@ begin
IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
end;
until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho) and (IcmpEchoHeaderPtr^.i_id = FId);
until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho)
and ((IcmpEchoHeaderPtr^.i_id = FId) or (IcmpEchoHeaderPtr^.i_id = 0));
//it discard sometimes possible 'echoes' of previosly sended packet...
if t then
if (IcmpEchoHeaderPtr^.i_type = FIcmpEchoReply) then
begin
FPingTime := TickDelta(IcmpEchoHeaderPtr^.TimeStamp, GetTick);
FPingTime := TickDelta(x, GetTick);
FReplyFrom := FSock.GetRemoteSinIP;
FReplyType := IcmpEchoHeaderPtr^.i_type;
FReplyCode := IcmpEchoHeaderPtr^.i_code;
TranslateError;
Result := True;
end;
end;
function TPINGSend.Checksum(Value: string): Word;
type
TWordArray = array[0..0] of Word;
var
WordArr: ^TWordArray;
CkSum: DWORD;
Num, Remain: Integer;
n: Integer;
n, i: Integer;
begin
Num := Length(Value) div 2;
Remain := Length(Value) mod 2;
WordArr := Pointer(Value);
CkSum := 0;
i := 1;
for n := 0 to Num - 1 do
CkSum := CkSum + WordArr^[n];
begin
CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i));
inc(i, 2);
end;
if Remain <> 0 then
CkSum := CkSum + Ord(Value[Length(Value)]);
CkSum := (CkSum shr 16) + (CkSum and $FFFF);
@ -252,30 +295,134 @@ begin
s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value;
ICMP6Ptr := Pointer(s);
x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY,
@FSock.RemoteSin.IP6, SizeOf(FSock.RemoteSin.IP6),
@FSock.RemoteSin, SizeOf(FSock.RemoteSin),
@ip6, SizeOf(ip6), @b, nil, nil);
if x <> -1 then
ICMP6Ptr^.in_dest := ip6.sin6_addr
else
ICMP6Ptr^.in_dest := FSock.LocalSin.IP6.sin6_addr;
ICMP6Ptr^.in_source := FSock.RemoteSin.IP6.sin6_addr;
ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr;
ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr;
ICMP6Ptr^.Length := synsock.htonl(Length(Value));
ICMP6Ptr^.proto := IPPROTO_ICMPV6;
Result := Checksum(s);
{$ENDIF}
end;
procedure TPINGSend.TranslateError;
begin
if fSock.IP6used then
begin
case FReplyType of
ICMP6_ECHOREPLY:
FReplyError := IE_NoError;
ICMP6_TIME_EXCEEDED:
FReplyError := IE_TTLExceed;
ICMP6_UNREACH:
case FReplyCode of
0:
FReplyError := IE_UnreachRoute;
3:
FReplyError := IE_UnreachAddr;
4:
FReplyError := IE_UnreachPort;
1:
FReplyError := IE_UnreachAdmin;
else
FReplyError := IE_UnreachOther;
end;
else
FReplyError := IE_Other;
end;
end
else
begin
case FReplyType of
ICMP_ECHOREPLY:
FReplyError := IE_NoError;
ICMP_TIME_EXCEEDED:
FReplyError := IE_TTLExceed;
ICMP_UNREACH:
case FReplyCode of
0:
FReplyError := IE_UnreachRoute;
1:
FReplyError := IE_UnreachAddr;
3:
FReplyError := IE_UnreachPort;
13:
FReplyError := IE_UnreachAdmin;
else
FReplyError := IE_UnreachOther;
end;
else
FReplyError := IE_Other;
end;
end;
case FReplyError of
IE_NoError:
FReplyErrorDesc := '';
IE_Other:
FReplyErrorDesc := 'Unknown error';
IE_TTLExceed:
FReplyErrorDesc := 'TTL Exceeded';
IE_UnreachOther:
FReplyErrorDesc := 'Unknown unreachable';
IE_UnreachRoute:
FReplyErrorDesc := 'No route to destination';
IE_UnreachAdmin:
FReplyErrorDesc := 'Administratively prohibited';
IE_UnreachAddr:
FReplyErrorDesc := 'Address unreachable';
IE_UnreachPort:
FReplyErrorDesc := 'Port unreachable';
end;
end;
{==============================================================================}
function PingHost(const Host: string): Integer;
begin
with TPINGSend.Create do
try
Ping(Host);
Result := PingTime;
Result := -1;
if Ping(Host) then
if ReplyError = IE_NoError then
Result := PingTime;
finally
Free;
end;
end;
function TraceRouteHost(const Host: string): string;
var
Ping: TPingSend;
ttl : byte;
begin
Result := '';
Ping := TPINGSend.Create;
try
ttl := 1;
repeat
ping.Sock.TTL := ttl;
inc(ttl);
if ttl > 30 then
Break;
if not ping.Ping(Host) then
begin
Result := Result + cAnyHost+ ' Timeout' + CRLF;
continue;
end;
if (ping.ReplyError <> IE_NoError)
and (ping.ReplyError <> IE_TTLExceed) then
begin
Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF;
break;
end;
Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF;
until ping.ReplyError = IE_NoError;
finally
Ping.Free;
end;
end;
end.

17
pop3send.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.001.008 |
| Project : Ararat Synapse | 002.001.010 |
|==============================================================================|
| Content: POP3 client |
|==============================================================================|
@ -42,13 +42,14 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-1734
//RFC-1939
//RFC-2195
//RFC-2449
//RFC-2595
//RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
unit POP3send;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit pop3send;
interface
@ -57,7 +58,7 @@ uses
{$IFDEF STREAMSEC}
TlsInternalServer, TlsSynaSock,
{$ENDIF}
blcksock, SynaUtil, SynaCode;
blcksock, synautil, synacode;
const
cPop3Protocol = 'pop3';

10
slogsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.001.004 |
| Project : Ararat Synapse | 001.001.006 |
|==============================================================================|
| Content: SysLog client |
|==============================================================================|
@ -44,15 +44,19 @@
// RFC-3164
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit SLogSend;
unit slogsend;
interface
uses
SysUtils, Classes,
blcksock, SynaUtil;
blcksock, synautil;
const
cSysLogProtocol = '514';

16
smtpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 003.002.008 |
| Project : Ararat Synapse | 003.002.011 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
@ -42,7 +42,15 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
unit SMTPsend;
//RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487,
//RFC-2554, RFC-2821
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit smtpsend;
interface
@ -51,7 +59,7 @@ uses
{$IFDEF STREAMSEC}
TlsInternalServer, TlsSynaSock,
{$ENDIF}
blcksock, SynaUtil, SynaCode;
blcksock, synautil, synacode;
const
cSmtpProtocol = 'smtp';
@ -561,7 +569,7 @@ begin
begin
s := MailTo;
repeat
t := GetEmailAddr(fetch(s, ','));
t := GetEmailAddr(FetchEx(s, ',', '"'));
if t <> '' then
Result := SMTP.MailTo(t);
if not Result then

10
snmpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.006.002 |
| Project : Ararat Synapse | 002.006.004 |
|==============================================================================|
| Content: SNMP client |
|==============================================================================|
@ -43,15 +43,19 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit SNMPSend;
unit snmpsend;
interface
uses
Classes, SysUtils,
blckSock, SynaUtil, ASN1Util;
blcksock, synautil, asn1util;
const
cSnmpProtocol = '161';

10
snmptrap.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.003.002 |
| Project : Ararat Synapse | 002.003.004 |
|==============================================================================|
| Content: SNMP traps |
|==============================================================================|
@ -43,15 +43,19 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit SNMPTrap;
unit snmptrap;
interface
uses
Classes, SysUtils,
blckSock, SynaUtil, ASN1Util, SNMPSend;
blcksock, synautil, asn1util, snmpsend;
const
cSnmpTrapProtocol = '162';

16
sntpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.002.003 |
| Project : Ararat Synapse | 002.002.007 |
|==============================================================================|
| Content: SNTP client |
|==============================================================================|
@ -43,15 +43,19 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit SNTPsend;
unit sntpsend;
interface
uses
SysUtils,
synsock, blcksock, SynaUtil;
synsock, blcksock, synautil;
const
cNtpProtocol = 'ntp';
@ -95,8 +99,8 @@ type
function GetSNTP: Boolean;
function GetNTP: Boolean;
function GetBroadcastNTP: Boolean;
published
property NTPReply: TNtp read FNTPReply;
published
property NTPTime: TDateTime read FNTPTime;
property NTPOffset: Double read FNTPOffset;
property NTPDelay: Double read FNTPDelay;
@ -171,12 +175,12 @@ var
x: Integer;
begin
Result := False;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Bind(FIPInterface, FTargetPort);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FTargetHost) then
if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
if x >= SizeOf(NTPReply) then
begin
NtpPtr := Pointer(FBuffer);

16
synachar.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 004.000.005 |
| Project : Ararat Synapse | 004.000.008 |
|==============================================================================|
| Content: Charset conversion support |
|==============================================================================|
@ -42,9 +42,13 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit SynaChar;
unit synachar;
interface
@ -644,7 +648,7 @@ const
(0);
//remove diakritics from Czech
Replace_Czech: array[0..55] of Word =
Replace_Czech: array[0..59] of Word =
(
$00E1, $0061,
$010D, $0063,
@ -653,6 +657,7 @@ const
$00E9, $0065,
$011B, $0065,
$00ED, $0069,
$0148, $006E,
$00F3, $006F,
$0159, $0072,
$0161, $0073,
@ -666,10 +671,11 @@ const
$00C9, $0045,
$011A, $0045,
$00CD, $0049,
$0147, $004E,
$00D3, $004F,
$0158, $0052,
$0160, $0053,
$0164, $0053,
$0164, $0054,
$00DA, $0055,
$016E, $0055,
$00DD, $0059,
@ -701,7 +707,7 @@ uses
Windows,
{$ENDIF}
SysUtils,
SynaUtil, SynaCode;
synautil, synacode;
const
NotFoundChar = '_';

192
synacode.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.007.001 |
| Project : Ararat Synapse | 001.008.007 |
|==============================================================================|
| Content: Coding and decoding support |
|==============================================================================|
@ -42,9 +42,14 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}
unit SynaCode;
unit synacode;
interface
@ -241,29 +246,72 @@ type
function DecodeTriplet(const Value: string; Delimiter: Char): string;
var
x, l: Integer;
x, l, lv: Integer;
c: Char;
s: string;
b: Byte;
bad: Boolean;
begin
SetLength(Result, Length(Value));
lv := Length(Value);
SetLength(Result, lv);
x := 1;
l := 1;
while x <= Length(Value) do
while x <= lv do
begin
c := Value[x];
Inc(x);
if c <> Delimiter then
Result[l] := c
begin
Result[l] := c;
Inc(l);
end
else
if x < Length(Value) then
if x < lv then
begin
s := Copy(Value, x, 2);
Inc(x, 2);
Result[l] := Char(StrToIntDef('$' + s, 32))
Case Value[x] Of
#13:
if (Value[x + 1] = #10) then
Inc(x, 2)
else
Inc(x);
#10:
if (Value[x + 1] = #13) then
Inc(x, 2)
else
Inc(x);
else
begin
bad := False;
Case Value[x] Of
'0'..'9': b := (Byte(Value[x]) - 48) Shl 4;
'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4;
else
begin
b := 0;
bad := True;
end;
end;
Case Value[x + 1] Of
'0'..'9': b := b Or (Byte(Value[x + 1]) - 48);
'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9);
else
bad := True;
end;
if bad then
begin
Result[l] := c;
Inc(l);
end
else
begin
Inc(x, 2);
Result[l] := Char(b);
Inc(l);
end;
end;
end;
end
else
break;
Inc(l);
end;
Dec(l);
SetLength(Result, l);
@ -322,7 +370,7 @@ end;
function EncodeQuotedPrintable(const Value: string): string;
begin
Result := EncodeTriplet(Value, '=', SpecialChar +
[Char(1)..Char(31), Char(128)..Char(255)]);
[Char(0)..Char(31), Char(127)..Char(255)]);
end;
{==============================================================================}
@ -349,7 +397,7 @@ begin
SetLength(Result, Length(Value));
x := 1;
l := 1;
while x < Length(Value) do
while x <= Length(Value) do
begin
for n := 0 to 3 do
begin
@ -382,45 +430,66 @@ begin
end;
{==============================================================================}
function Decode4to3Ex(const Value, Table: string): string;
var
x, y, n, l: Integer;
d: array[0..3] of Byte;
begin
SetLength(Result, Length(Value));
x := 1;
l := 1;
while x < Length(Value) do
begin
for n := 0 to 3 do
begin
if x > Length(Value) then
d[n] := 64
else
begin
y := Ord(Value[x]);
if (y < 33) or (y > 127) then
d[n] := 64
else
d[n] := Ord(Table[y - 32]);
end;
Inc(x);
end;
Result[l] := Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4);
Inc(l);
if d[2] <> 64 then
begin
Result[l] := Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2);
Inc(l);
if d[3] <> 64 then
begin
Result[l] := Char((D[2] and $03) shl 6 + (D[3] and $3F));
Inc(l);
end;
end;
type
TDconvert = record
case byte of
0: (a0, a1, a2, a3: char);
1: (i: integer);
end;
Dec(l);
var
x, y, l, lv: Integer;
d: TDconvert;
dl: integer;
c: byte;
p: ^char;
begin
lv := Length(Value);
SetLength(Result, lv);
x := 1;
dl := 4;
d.i := 0;
p := pointer(result);
while x <= lv do
begin
y := Ord(Value[x]);
if y in [33..127] then
c := Ord(Table[y - 32])
else
c := 64;
Inc(x);
if c > 63 then
continue;
d.i := (d.i shl 6) or c;
dec(dl);
if dl <> 0 then
continue;
p^ := d.a2;
inc(p);
p^ := d.a1;
inc(p);
p^ := d.a0;
inc(p);
d.i := 0;
dl := 4;
end;
case dl of
1:
begin
d.i := d.i shr 2;
p^ := d.a1;
inc(p);
p^ := d.a0;
inc(p);
end;
2:
begin
d.i := d.i shr 4;
p^ := d.a0;
inc(p);
end;
end;
l := integer(p) - integer(pointer(result));
SetLength(Result, l);
end;
@ -516,6 +585,7 @@ begin
s := Copy(Value, 2, x);
if s = '' then
Exit;
s := s + StringOfChar(' ', x - length(s));
Result := Decode4to3(s, uut);
end;
@ -554,6 +624,7 @@ begin
s := Copy(Value, 2, x);
if s = '' then
Exit;
s := s + StringOfChar(' ', x - length(s));
Result := Decode4to3(s, TableXX);
end;
@ -772,7 +843,7 @@ begin
Dec(Len, T);
Index := T;
end;
while Len >= 64 do
while Len > 64 do
begin
Move(Data[Index + 1], Bufchar, 64);
MD5Transform(State, Buflong);
@ -799,14 +870,15 @@ begin
BufChar[P] := $80;
Inc(P);
Cnt := 64 - 1 - Cnt;
if Cnt < 8 then
begin
FillChar(BufChar[P], Cnt, #0);
MD5Transform(State, BufLong);
FillChar(BufChar, 56, #0);
end
else
FillChar(BufChar[P], Cnt - 8, #0);
if Cnt > 0 then
if Cnt < 8 then
begin
FillChar(BufChar[P], Cnt, #0);
MD5Transform(State, BufLong);
FillChar(BufChar, 56, #0);
end
else
FillChar(BufChar[P], Cnt - 8, #0);
BufLong[14] := Count[0];
BufLong[15] := Count[1];
MD5Transform(State, BufLong);

106
synafpc.pas Normal file
View File

@ -0,0 +1,106 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.000 |
|==============================================================================|
| Content: Utils for FreePascal compatibility |
|==============================================================================|
| Copyright (c)1999-2003, 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/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
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);
{$ENDIF}
{$ENDIF}
implementation
{==============================================================================}
{$IFDEF LINUX}
{$IFDEF FPC}
function LoadLibrary(ModuleName: PChar): HMODULE;
begin
Result := HMODULE(dynlibs.LoadLibrary(Modulename));
end;
function FreeLibrary(Module: HMODULE): LongBool;
begin
Result := dynlibs.UnloadLibrary(pointer(Module));
end;
function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer;
begin
Result := dynlibs.GetProcedureAddress(pointer(Module), Proc);
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
end;
{$ENDIF}
{$ENDIF}
end.

25
synamisc.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.006 |
| Project : Ararat Synapse | 001.001.002 |
|==============================================================================|
| Content: misc. procedures and functions |
|==============================================================================|
@ -42,9 +42,13 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit SynaMisc;
unit synamisc;
interface
@ -57,11 +61,16 @@ interface
{$ENDIF}
uses
SynaUtil, blcksock, SysUtils, Classes,
synautil, blcksock, SysUtils, Classes,
{$IFDEF LINUX}
Libc;
{$ELSE}
Windows, Wininet;
{$IFDEF FPC}
winver,
{$ELSE}
Wininet,
{$ENDIF}
Windows;
{$ENDIF}
Type
@ -258,6 +267,13 @@ begin
Result.Bypass := '';
end;
{$ELSE}
{$IFDEF FPC}
begin
Result.Host := '';
Result.Port := '';
Result.Bypass := '';
end;
{$ELSE}
var
ProxyInfo: PInternetProxyInfo;
Err: Boolean;
@ -308,6 +324,7 @@ begin
end;
end;
{$ENDIF}
{$ENDIF}
{==============================================================================}

947
synassl.pas
View File

File diff suppressed because it is too large Load Diff

237
synautil.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 003.005.001 |
| Project : Ararat Synapse | 004.000.002 |
|==============================================================================|
| Content: support procedures and functions |
|==============================================================================|
@ -44,10 +44,14 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}
unit SynaUtil;
unit synautil;
interface
@ -78,11 +82,14 @@ function DecodeInt(const Value: string; Index: Integer): Word;
function IsIP(const Value: string): Boolean;
function IsIP6(const Value: string): Boolean;
function IPToID(Host: string): string;
function DumpStr(const Buffer: string): string;
function DumpExStr(const Buffer: string): string;
procedure Dump(const Buffer, DumpFile: string);
procedure DumpEx(const Buffer, DumpFile: string);
function SeparateLeft(const Value, Delimiter: string): string;
function SeparateRight(const Value, Delimiter: string): string;
function GetParameter(const Value, Parameter: string): string;
procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);
procedure ParseParameters(Value: string; const Parameters: TStrings);
function IndexByBegin(Value: string; const List: TStrings): integer;
function GetEmailAddr(const Value: string): string;
@ -96,11 +103,15 @@ function ReplaceString(Value, Search, Replace: string): string;
function RPosEx(const Sub, Value: string; From: integer): Integer;
function RPos(const Sub, Value: String): Integer;
function Fetch(var Value: string; const Delimiter: string): string;
function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
function IsBinaryString(const Value: string): Boolean;
function PosCRLF(const Value: string; var Terminator: string): integer;
Procedure StringsTrim(const value: TStrings);
function PosFrom(const SubStr, Value: String; From: integer): integer;
function IncPoint(const p: pointer; Value: integer): pointer;
function GetBetween(const PairBegin, PairEnd, Value: string): string;
function CountOfChar(const Value: string; Chr: char): integer;
function UnquoteStr(const Value: string; Quote: Char): string;
implementation
@ -121,8 +132,13 @@ var
t: TTime_T;
UT: TUnixTime;
begin
{$IFNDEF FPC}
__time(@T);
localtime_r(@T, UT);
{$ELSE}
__time(T);
localtime_r(T, UT);
{$ENDIF}
Result := ut.__tm_gmtoff div 60;
{$ELSE}
var
@ -430,6 +446,9 @@ begin
day := 1;
Result := Result + Encodedate(year, month, day);
zone := zone - TimeZoneBias;
x := zone div 1440;
Result := Result - x;
zone := zone mod 1440;
t := EncodeTime(Abs(zone) div 60, Abs(zone) mod 60, 0, 0);
if zone < 0 then
t := 0 - t;
@ -440,17 +459,36 @@ end;
function GetUTTime: TDateTime;
{$IFNDEF LINUX}
{$IFNDEF FPC}
var
st: TSystemTime;
begin
GetSystemTime(st);
result:=SystemTimeToDateTime(st);
GetSystemTime(st);
result := SystemTimeToDateTime(st);
{$ELSE}
var
st: SysUtils.TSystemTime;
stw: Windows.TSystemTime;
begin
GetSystemTime(stw);
st.Year := stw.wYear;
st.Month := stw.wMonth;
st.Day := stw.wDay;
st.Hour := stw.wHour;
st.Minute := stw.wMinute;
st.Second := stw.wSecond;
st.Millisecond := stw.wMilliseconds;
result := SystemTimeToDateTime(st);
{$ENDIF}
{$ELSE}
var
TV: TTimeVal;
TZ: Ttimezone;
begin
gettimeofday(TV, nil);
Result:=UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
TZ.tz_minuteswest := 0;
TZ.tz_dsttime := 0;
gettimeofday(TV, TZ);
Result := UnixDateDelta + (TV.tv_sec + TV.tv_usec / 1000000) / 86400;
{$ENDIF}
end;
@ -458,11 +496,27 @@ end;
function SetUTTime(Newdt: TDateTime): Boolean;
{$IFNDEF LINUX}
{$IFNDEF FPC}
var
st: TSystemTime;
begin
DateTimeToSystemTime(newdt,st);
Result:=SetSystemTime(st);
DateTimeToSystemTime(newdt,st);
Result := SetSystemTime(st);
{$ELSE}
var
st: SysUtils.TSystemTime;
stw: Windows.TSystemTime;
begin
DateTimeToSystemTime(newdt,st);
stw.wYear := st.Year;
stw.wMonth := st.Month;
stw.wDay := st.Day;
stw.wHour := st.Hour;
stw.wMinute := st.Minute;
stw.wSecond := st.Second;
stw.wMilliseconds := st.Millisecond;
Result := SetSystemTime(stw);
{$ENDIF}
{$ELSE}
var
TV: TTimeVal;
@ -470,6 +524,8 @@ var
TZ: Ttimezone;
begin
Result := false;
TZ.tz_minuteswest := 0;
TZ.tz_dsttime := 0;
gettimeofday(TV, TZ);
d := (newdt - UnixDateDelta) * 86400;
TV.tv_sec := trunc(d);
@ -642,21 +698,45 @@ end;
{==============================================================================}
procedure Dump(const Buffer, DumpFile: string);
function DumpStr(const Buffer: string): string;
var
n: Integer;
s: string;
begin
Result := '';
for n := 1 to Length(Buffer) do
Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
end;
{==============================================================================}
function DumpExStr(const Buffer: string): string;
var
n: Integer;
x: Byte;
begin
Result := '';
for n := 1 to Length(Buffer) do
begin
x := Ord(Buffer[n]);
if x in [65..90, 97..122] then
Result := Result + ' +''' + char(x) + ''''
else
Result := Result + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
end;
end;
{==============================================================================}
procedure Dump(const Buffer, DumpFile: string);
var
f: Text;
begin
s := '';
for n := 1 to Length(Buffer) do
s := s + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
AssignFile(f, DumpFile);
if FileExists(DumpFile) then
DeleteFile(PChar(DumpFile));
Rewrite(f);
try
Writeln(f, s);
Writeln(f, DumpStr(Buffer));
finally
CloseFile(f);
end;
@ -666,26 +746,14 @@ end;
procedure DumpEx(const Buffer, DumpFile: string);
var
n: Integer;
x: Byte;
s: string;
f: Text;
begin
s := '';
for n := 1 to Length(Buffer) do
begin
x := Ord(Buffer[n]);
if x in [65..90, 97..122] then
s := s + ' +''' + char(x) + ''''
else
s := s + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
end;
AssignFile(f, DumpFile);
if FileExists(DumpFile) then
DeleteFile(PChar(DumpFile));
Rewrite(f);
try
Writeln(f, s);
Writeln(f, DumpExStr(Buffer));
finally
CloseFile(f);
end;
@ -720,7 +788,7 @@ end;
function GetParameter(const Value, Parameter: string): string;
var
x, x1: Integer;
x: Integer;
s: string;
begin
x := Pos(UpperCase(Parameter), UpperCase(Value));
@ -730,43 +798,39 @@ begin
s := Copy(Value, x + Length(Parameter), Length(Value)
- (x + Length(Parameter)) + 1);
s := Trim(s);
x1 := Length(s);
if Length(s) > 1 then
begin
if s[1] = '"' then
begin
s := Copy(s, 2, Length(s) - 1);
x := Pos('"', s);
if x > 0 then
x1 := x - 1;
end
else
begin
x := Pos(' ', s);
if x > 0 then
x1 := x - 1;
end;
x := pos(';', s);
if x > 0 then
s := Copy(s, 1, x - 1);
Result := UnquoteStr(s, '"');
end;
Result := Copy(s, 1, x1);
end;
end;
{==============================================================================}
procedure ParseParameters(Value: string; const Parameters: TStrings);
procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);
var
s: string;
begin
Parameters.Clear;
while Value <> '' do
begin
s := Fetch(Value, ';');
s := Fetch(Value, Delimiter);
Parameters.Add(s);
end;
end;
{==============================================================================}
procedure ParseParameters(Value: string; const Parameters: TStrings);
begin
ParseParametersEx(Value, ';', Parameters);
end;
{==============================================================================}
function IndexByBegin(Value: string; const List: TStrings): integer;
var
n: integer;
@ -1033,6 +1097,40 @@ end;
{==============================================================================}
function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
var
n: integer;
b: Boolean;
begin
Result := '';
b := False;
n := 1;
while n <= Length(Value) do
begin
if b then
begin
if Pos(Quotation, Value) = 1 then
b := False;
Result := Result + Value[1];
Delete(Value, 1, 1);
end
else
begin
if Pos(Delimiter, Value) = 1 then
begin
Delete(Value, 1, Length(delimiter));
break;
end;
b := Pos(Quotation, Value) = 1;
Result := Result + Value[1];
Delete(Value, 1, 1);
end;
end;
Result := Trim(Result);
end;
{==============================================================================}
function IsBinaryString(const Value: string): Boolean;
var
n: integer;
@ -1132,4 +1230,53 @@ end;
{==============================================================================}
function GetBetween(const PairBegin, PairEnd, Value: string): string;
var
n: integer;
x: integer;
s: string;
begin
Result := '';
s := SeparateRight(Value, PairBegin);
x := 1;
for n := 1 to Length(s) do
begin
if s[n] = PairBegin then
Inc(x);
if s[n] = PairEnd then
begin
Dec(x);
if x <= 0 then
Break;
end;
Result := Result + s[n];
end;
end;
{==============================================================================}
function CountOfChar(const Value: string; Chr: char): integer;
var
n: integer;
begin
Result := 0;
for n := 1 to Length(Value) do
if Value[n] = chr then
Inc(Result);
end;
{==============================================================================}
function UnquoteStr(const Value: string; Quote: Char): string;
var
LText: PChar;
begin
LText := PChar(Value);
Result := AnsiExtractQuotedStr(LText, Quote);
if Result = '' then
Result := Value;
end;
{==============================================================================}
end.

208
synsock.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 003.001.003 |
| Project : Ararat Synapse | 004.001.000 |
|==============================================================================|
| Content: Socket Independent Platform Layer |
|==============================================================================|
@ -56,12 +56,16 @@ On Linux is level 2.2 always used!
//{$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 when new API
for name resolution. If you leave this directive inactive, then the new API
is used, when running system allows it.
For IPv6 support you must have new API!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF VER125}
{$DEFINE BCB}
{$ENDIF}
@ -234,6 +238,9 @@ interface
uses
SyncObjs, SysUtils,
{$IFDEF LINUX}
{$IFDEF FPC}
synafpc,
{$ENDIF}
Libc;
{$ELSE}
Windows;
@ -574,6 +581,15 @@ Const
MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE.
// getnameinfo constants
NI_MAXHOST = 1025;
NI_MAXSERV = 32;
NI_NOFQDN = $4;
NI_NUMERICHOST = $1;
NI_NAMEREQD = $8;
NI_NUMERICSERV = $2;
NI_DGRAM = $10;
{=============================================================================}
{$ELSE}
Const
@ -654,6 +670,15 @@ Const
MSG_NOSIGNAL = 0;
// getnameinfo constants
NI_MAXHOST = 1025;
NI_MAXSERV = 32;
NI_NOFQDN = $1;
NI_NUMERICHOST = $2;
NI_NAMEREQD = $4;
NI_NUMERICSERV = $8;
NI_DGRAM = $10;
{$ENDIF}
{=============================================================================}
@ -721,15 +746,6 @@ const
AI_CANONNAME = $2; // Return canonical name in first ai_canonname.
AI_NUMERICHOST = $4; // Nodename must be a numeric address string.
// getnameinfo constants
NI_MAXHOST = 1025;
NI_MAXSERV = 32;
NI_NOFQDN = $1;
NI_NUMERICHOST = $2;
NI_NAMEREQD = $4;
NI_NUMERICSERV = $8;
NI_DGRAM = $10;
type
{ Structure used for manipulating linger option. }
PLinger = ^TLinger;
@ -971,87 +987,133 @@ const
{=============================================================================}
var
WSAStartup: function(wVersionRequired: Word; var WSData: TWSAData): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
WSACleanup: function: Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
WSAGetLastError: function: Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetServByName: function(name, proto: PChar): PServEnt
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetServByPort: function(port: Integer; proto: PChar): PServEnt
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetProtoByName: function(name: PChar): PProtoEnt
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetProtoByNumber: function(proto: Integer): PProtoEnt
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetHostByName: function(name: PChar): PHostEnt
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetHostByAddr: function(addr: Pointer; len, Struc: Integer): PHostEnt
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetHostName: function(name: PChar; len: Integer): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Shutdown: function(s: TSocket; how: Integer): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
SetSockOpt: function(s: TSocket; level, optname: Integer; optval: PChar;
optlen: Integer): Integer {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
optlen: Integer): Integer
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetSockOpt: function(s: TSocket; level, optname: Integer; optval: PChar;
var optlen: Integer): Integer {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
SendTo: function(s: TSocket; var Buf; len, flags: Integer; addrto: PSockAddr;
tolen: Integer): Integer {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
Send: function(s: TSocket; var Buf; len, flags: Integer): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
var optlen: Integer): Integer
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
SendTo: function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr;
tolen: Integer): Integer
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Send: function(s: TSocket; const Buf; len, flags: Integer): Integer
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Recv: function(s: TSocket; var Buf; len, flags: Integer): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
RecvFrom: function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
var fromlen: Integer): Integer {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
var fromlen: Integer): Integer
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
ntohs: function(netshort: u_short): u_short
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
ntohl: function(netlong: u_long): u_long
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Listen: function(s: TSocket; backlog: Integer): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
IoctlSocket: function(s: TSocket; cmd: DWORD; var arg: u_long): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Inet_ntoa: function(inaddr: TInAddr): PChar
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Inet_addr: function(cp: PChar): u_long
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
htons: function(hostshort: u_short): u_short
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
htonl: function(hostlong: u_long): u_long
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetSockName: function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetPeerName: function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Connect: function(s: TSocket; name: PSockAddr; namelen: Integer): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
CloseSocket: function(s: TSocket): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Bind: function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Accept: function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Socket: function(af, Struc, Protocol: Integer): TSocket
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
Select: function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint {$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
timeout: PTimeVal): Longint
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetAddrInfo: function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo;
var Addrinfo: PAddrInfo): integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
FreeAddrInfo: procedure(ai: PAddrInfo)
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
GetNameInfo: function( addr: PSockAddr; namelen: Integer; host: PChar;
hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer
{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$IFNDEF FPC}{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF} = nil;
{$ELSE}= nil;{$IFDEF LINUX}cdecl{$ELSE}stdcall{$ENDIF};{$ENDIF}
{$IFNDEF LINUX}
__WSAFDIsSet: function (s: TSocket; var FDSet: TFDSet): Bool stdcall = nil;
__WSAFDIsSet: function (s: TSocket; var FDSet: TFDSet): Bool
{$IFNDEF FPC}stdcall = nil;
{$ELSE}= nil; stdcall;{$ENDIF}
WSAIoctl: function (s: TSocket; dwIoControlCode: DWORD; lpvInBuffer: Pointer;
cbInBuffer: DWORD; lpvOutBuffer: Pointer; cbOutBuffer: DWORD;
lpcbBytesReturned: PDWORD; lpOverlapped: Pointer;
lpCompletionRoutine: pointer): u_int stdcall = nil;
lpCompletionRoutine: pointer): u_int
{$IFNDEF FPC}stdcall = nil;
{$ELSE}= nil; stdcall;{$ENDIF}
{$ENDIF}
{$IFDEF LINUX}
@ -1061,10 +1123,24 @@ function LSWSAGetLastError: Integer; cdecl;
{$ENDIF}
var
SynSockCS: TCriticalSection;
SynSockCS: SyncObjs.TCriticalSection;
SockEnhancedApi: Boolean;
SockWship6Api: Boolean;
type
TVarSin = packed record
case sin_family: u_short of
AF_INET: (sin_port: u_short;
sin_addr: TInAddr;
sin_zero: array[0..7] of Char);
AF_INET6: (sin6_port: u_short;
sin6_flowinfo: u_long;
sin6_addr: TInAddr6;
sin6_scope_id: u_long);
end;
function SizeOfVarSin(sin: TVarSin): integer;
const
{$IFDEF LINUX}
DLLStackName = 'libc.so.6';
@ -1132,7 +1208,11 @@ end;
{=============================================================================}
{$IFDEF LINUX}
var
{$IFNDEF FPC}
errno_loc: function: PInteger cdecl = nil;
{$ELSE}
errno_loc: function: PInteger = nil; cdecl;
{$ENDIF}
function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
begin
@ -1154,8 +1234,11 @@ begin
end;
function LSWSAGetLastError: Integer;
var
p: PInteger;
begin
Result := errno_loc^;
p := errno_loc;
Result := p^;
end;
function __FDELT(Socket: TSocket): Integer;
@ -1237,6 +1320,19 @@ 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 InitSocketInterface(stack: string): Boolean;
begin
Result := False;
@ -1251,10 +1347,8 @@ begin
SockWship6Api := False;
{$IFDEF LINUX}
Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN));
LibHandle := HMODULE(dlopen(PChar(Stack), RTLD_GLOBAL));
{$ELSE}
LibHandle := LoadLibrary(PChar(Stack));
{$ENDIF}
LibHandle := LoadLibrary(PChar(Stack));
if LibHandle <> 0 then
begin
{$IFDEF LINUX}
@ -1362,7 +1456,7 @@ end;
initialization
begin
SynSockCS:= TCriticalSection.Create;
SynSockCS := SyncObjs.TCriticalSection.Create;
SET_IN6_IF_ADDR_ANY (@in6addr_any);
SET_LOOPBACK_ADDR6 (@in6addr_loopback);
end;

11
tlntsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.001.001 |
| Project : Ararat Synapse | 001.001.003 |
|==============================================================================|
| Content: TELNET client |
|==============================================================================|
@ -44,13 +44,18 @@
//RFC-854
unit TlntSend;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit tlntsend;
interface
uses
SysUtils, Classes,
blcksock, SynaUtil;
blcksock, synautil;
const
cTelnetProtocol = 'telnet';