pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 30

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@66 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 07:22:17 +00:00
parent f9140b8ecd
commit 9f400a899b
24 changed files with 1846 additions and 592 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
asn1util.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.003.004 |
| Project : Delphree - Synapse | 001.003.005 |
|==============================================================================|
| Content: support for ASN.1 BER coding and decoding |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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,2000,2001. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003 |
| Portions created by Hernan Sanchez are Copyright (c) 2000. |
| All Rights Reserved. |
|==============================================================================|
@ -301,7 +301,6 @@ begin
else // NULL
begin
Result := '';
Inc(Start);
Start := Start + ASNSize;
end;
end;

594
blcksock.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 006.001.004 |
| Project : Delphree - Synapse | 006.006.001 |
|==============================================================================|
| Content: Library base |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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-2002. |
| Portions created by Lukas Gebauer are Copyright (c)1999-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -48,7 +48,18 @@ Special thanks to Gregor Ibic <gregor.ibic@intelicom.si>
}
{$Q-}
{$WEAKPACKAGEUNIT ON}
{$DEFINE ONCEWINSOCK}
{Note about define ONCEWINSOCK:
If you remove this compiler directive, then socket interface is loaded and
initialized on constructor of TBlockSocket class for each socket separately.
Socket interface is used only if your need it.
If you leave this directive here, then socket interface is loaded and
initialized only once at start of your program! It boost performace on high
count of created and destroyed sockets. It eliminate possible small resource
leak on Windows systems too.
}
unit blcksock;
@ -68,13 +79,20 @@ const
cAnyHost = '0.0.0.0';
cBroadcast = '255.255.255.255';
cAnyPort = '0';
CR = #$0d;
LF = #$0a;
CRLF = CR + LF;
type
ESynapseError = class(Exception)
public
ErrorCode: Integer;
ErrorMessage: string;
private
FErrorCode: Integer;
FErrorMessage: string;
published
property ErrorCode: Integer read FErrorCode Write FErrorCode;
property ErrorMessage: string read FErrorMessage Write FErrorMessage;
end;
THookSocketReason = (
@ -89,15 +107,20 @@ type
HR_Listen,
HR_Accept,
HR_ReadCount,
HR_WriteCount
HR_WriteCount,
HR_Wait
);
THookSocketStatus = procedure(Sender: TObject; Reason: THookSocketReason;
const Value: string) of object;
THookDataFilter = procedure(Sender: TObject; var Value: string) of object;
TBlockSocket = class(TObject)
private
FOnStatus: THookSocketStatus;
FOnReadFilter: THookDataFilter;
FOnWriteFilter: THookDataFilter;
FWsaData: TWSADATA;
FLocalSin: TSockAddrIn;
FRemoteSin: TSockAddrIn;
@ -112,11 +135,16 @@ type
FMaxRecvBandwidth: Integer;
FNextRecv: Cardinal;
FConvertLineEnd: Boolean;
FLastCR: Boolean;
FLastLF: Boolean;
FBinded: Boolean;
function GetSizeRecvBuffer: Integer;
procedure SetSizeRecvBuffer(Size: Integer);
function GetSizeSendBuffer: Integer;
procedure SetSizeSendBuffer(Size: Integer);
procedure SetNonBlockMode(Value: Boolean);
procedure SetTTL(TTL: integer);
function GetTTL:integer;
protected
FSocket: TSocket;
FProtocol: Integer;
@ -126,6 +154,8 @@ type
function GetSinIP(Sin: TSockAddrIn): string;
function GetSinPort(Sin: TSockAddrIn): Integer;
procedure DoStatus(Reason: THookSocketReason; const Value: string);
procedure DoReadFilter(Buffer: Pointer; var Length: Integer);
procedure DoWriteFilter(Buffer: Pointer; var Length: Integer);
procedure LimitBandwidth(Length: Integer; MaxB: integer; var Next: Cardinal);
procedure SetBandwidth(Value: Integer);
public
@ -141,6 +171,7 @@ type
function RecvBuffer(Buffer: Pointer; Length: Integer): Integer; virtual;
function RecvBufferEx(Buffer: Pointer; Length: Integer;
Timeout: Integer): Integer; virtual;
function RecvBufferStr(Length: Integer; Timeout: Integer): String; virtual;
function RecvByte(Timeout: Integer): Byte; virtual;
function RecvString(Timeout: Integer): string; virtual;
function RecvTerminated(Timeout: Integer; const Terminator: string): string; virtual;
@ -189,13 +220,16 @@ type
property SizeRecvBuffer: Integer read GetSizeRecvBuffer write SetSizeRecvBuffer;
property SizeSendBuffer: Integer read GetSizeSendBuffer write SetSizeSendBuffer;
property WSAData: TWSADATA read FWsaData;
property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
property NonBlockMode: Boolean read FNonBlockMode Write SetNonBlockMode;
property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
property MaxSendBandwidth: Integer read FMaxSendBandwidth Write FMaxSendBandwidth;
property MaxRecvBandwidth: Integer read FMaxRecvBandwidth Write FMaxRecvBandwidth;
property MaxBandwidth: Integer Write SetBandwidth;
property ConvertLineEnd: Boolean read FConvertLineEnd Write FConvertLineEnd;
property TTL: Integer read GetTTL Write SetTTL;
property OnStatus: THookSocketStatus read FOnStatus write FOnStatus;
property OnReadFilter: THookDataFilter read FOnReadFilter write FOnReadFilter;
property OnWriteFilter: THookDataFilter read FOnWriteFilter write FOnWriteFilter;
end;
TSocksBlockSocket = class(TBlockSocket)
@ -304,6 +338,8 @@ type
protected
FSocksControlSock: TTCPBlockSocket;
function UdpAssociation: Boolean;
procedure SetMulticastTTL(TTL: integer);
function GetMulticastTTL:integer;
public
destructor Destroy; override;
procedure CreateSocket; override;
@ -315,6 +351,9 @@ type
function RecvBufferFrom(Buffer: Pointer; Length: Integer): Integer; override;
procedure AddMulticast(MCastIP:string);
procedure DropMulticast(MCastIP:string);
function EnableMulticastLoop(Value: Boolean): Boolean;
published
property MulticastTTL: Integer read GetMulticastTTL Write SetMulticastTTL;
end;
//See 'winsock2.txt' file in distribute package!
@ -366,9 +405,54 @@ type
MCastIfc : u_long;
end;
{$IFDEF ONCEWINSOCK}
var
WsaDataOnce: TWSADATA;
e: ESynapseError;
{$ENDIF}
constructor TBlockSocket.Create;
{$IFNDEF ONCEWINSOCK}
var
e: ESynapseError;
{$ENDIF}
begin
inherited Create;
FRaiseExcept := False;
FSocket := INVALID_SOCKET;
FProtocol := IPPROTO_IP;
FBuffer := '';
FLastCR := False;
FLastLF := False;
FBinded := False;
FNonBlockMode := False;
FMaxLineLength := 0;
FMaxSendBandwidth := 0;
FNextSend := 0;
FMaxRecvBandwidth := 0;
FNextRecv := 0;
FConvertLineEnd := False;
{$IFDEF ONCEWINSOCK}
FWsaData := WsaDataOnce;
{$ELSE}
if not InitSocketInterface('') then
begin
e := ESynapseError.Create('Error loading Winsock DLL!');
e.ErrorCode := 0;
e.ErrorMessage := 'Error loading Winsock DLL!';
raise e;
end;
SockCheck(synsock.WSAStartup($101, FWsaData));
ExceptCheck;
{$ENDIF}
end;
constructor TBlockSocket.CreateAlternate(Stub: string);
{$IFNDEF ONCEWINSOCK}
var
e: ESynapseError;
{$ENDIF}
begin
inherited Create;
FRaiseExcept := False;
@ -382,26 +466,9 @@ begin
FMaxRecvBandwidth := 0;
FNextRecv := 0;
FConvertLineEnd := False;
if not InitSocketInterface('') then
begin
e := ESynapseError.Create('Error loading Winsock DLL!');
e.ErrorCode := 0;
e.ErrorMessage := 'Error loading Winsock DLL!';
raise e;
end;
SockCheck(synsock.WSAStartup($101, FWsaData));
ExceptCheck;
end;
constructor TBlockSocket.CreateAlternate(Stub: string);
var
e: ESynapseError;
begin
inherited Create;
FRaiseExcept := False;
FSocket := INVALID_SOCKET;
FProtocol := IPPROTO_IP;
FBuffer := '';
{$IFDEF ONCEWINSOCK}
FWsaData := WsaDataOnce;
{$ELSE}
if not InitSocketInterface(Stub) then
begin
e := ESynapseError.Create('Error loading alternate Winsock DLL (' + Stub + ')!');
@ -411,13 +478,16 @@ begin
end;
SockCheck(synsock.WSAStartup($101, FWsaData));
ExceptCheck;
{$ENDIF}
end;
destructor TBlockSocket.Destroy;
begin
CloseSocket;
{$IFNDEF ONCEWINSOCK}
synsock.WSACleanup;
DestroySocketInterface;
{$ENDIF}
inherited Destroy;
end;
@ -430,27 +500,32 @@ var
HostEnt: PHostEnt;
begin
DoStatus(HR_ResolvingBegin, IP + ':' + Port);
FillChar(Sin, Sizeof(Sin), 0);
Sin.sin_family := AF_INET;
ProtoEnt := synsock.GetProtoByNumber(FProtocol);
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
SynSockCS.Enter;
try
FillChar(Sin, Sizeof(Sin), 0);
Sin.sin_family := AF_INET;
ProtoEnt := synsock.GetProtoByNumber(FProtocol);
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
HostEnt := synsock.GetHostByName(PChar(IP));
if HostEnt <> nil then
SIn.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^);
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));
if HostEnt <> nil then
SIn.sin_addr.S_addr := u_long(Pu_long(HostEnt^.h_addr_list^)^);
end;
end;
finally
SynSockCS.Leave;
end;
DoStatus(HR_ResolvingEnd, IP + ':' + Port);
end;
@ -474,6 +549,7 @@ end;
procedure TBlockSocket.CreateSocket;
begin
FBuffer := '';
FBinded := False;
if FSocket = INVALID_SOCKET then
FLastError := synsock.WSAGetLastError
else
@ -490,7 +566,6 @@ end;
procedure TBlockSocket.CloseSocket;
begin
synsock.Shutdown(FSocket, 2);
synsock.CloseSocket(FSocket);
FSocket := INVALID_SOCKET;
DoStatus(HR_SocketClose, '');
@ -507,6 +582,7 @@ begin
Len := SizeOf(FLocalSin);
synsock.GetSockName(FSocket, FLocalSin, Len);
FBuffer := '';
FBinded := True;
ExceptCheck;
DoStatus(HR_Bind, IP + ':' + Port);
end;
@ -520,6 +596,8 @@ begin
SockCheck(synsock.Connect(FSocket, Sin, SizeOf(Sin)));
GetSins;
FBuffer := '';
FLastCR := False;
FLastLF := False;
ExceptCheck;
DoStatus(HR_Connect, IP + ':' + Port);
end;
@ -552,7 +630,10 @@ begin
begin
x := Next - y;
if x > 0 then
begin
DoStatus(HR_Wait, IntToStr(x));
sleep(x);
end;
end;
Next := y + Trunc((Length / MaxB) * 1000);
end;
@ -561,6 +642,7 @@ end;
function TBlockSocket.SendBuffer(Buffer: Pointer; Length: Integer): Integer;
begin
LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
DoWriteFilter(Buffer, Length);
Result := synsock.Send(FSocket, Buffer^, Length, 0);
SockCheck(Result);
ExceptCheck;
@ -587,68 +669,46 @@ begin
SockCheck(Result);
ExceptCheck;
DoStatus(HR_ReadCount, IntToStr(Result));
DoReadFilter(Buffer, Result);
end;
function TBlockSocket.RecvBufferEx(Buffer: Pointer; Length: Integer;
Timeout: Integer): Integer;
var
s, ss, st: string;
x, l, lss: Integer;
fb, fs: Integer;
max: Integer;
s: string;
rl, l: integer;
begin
FLastError := 0;
x := System.Length(FBuffer);
if Length <= x then
rl := 0;
repeat
s := RecvPacket(Timeout);
l := System.Length(s);
if (rl + l) > Length then
l := Length - rl;
Move(Pointer(s)^, IncPoint(Buffer, rl)^, l);
rl := rl + l;
if FLastError <> 0 then
Break;
until rl >= Length;
delete(s, 1, l);
FBuffer := s;
Result := rl;
end;
function TBlockSocket.RecvBufferStr(Length: Integer; Timeout: Integer): string;
var
x: integer;
begin
Result := '';
if Length > 0 then
begin
fb := Length;
fs := 0;
end
else
begin
fb := x;
fs := Length - x;
Setlength(Result, Length);
x := RecvBufferEx(PChar(Result), Length , Timeout);
if FLastError = 0 then
SetLength(Result, x)
else
Result := '';
end;
ss := '';
if fb > 0 then
begin
s := Copy(FBuffer, 1, fb);
Delete(FBuffer, 1, fb);
end;
if fs > 0 then
begin
Max := GetSizeRecvBuffer;
ss := '';
while System.Length(ss) < fs do
begin
if CanRead(Timeout) then
begin
l := WaitingData;
if l > max then
l := max;
if (system.Length(ss) + l) > fs then
l := fs - system.Length(ss);
SetLength(st, l);
x := RecvBuffer(Pointer(st), l);
if FLastError <> 0 then
Break;
lss := system.Length(ss);
SetLength(ss, lss + x);
Move(Pointer(st)^, Pointer(@ss[lss + 1])^, x);
{It is 3x faster then ss:=ss+copy(st,1,x);}
Sleep(0);
end
else
FLastError := WSAETIMEDOUT;
if FLastError <> 0 then
Break;
end;
fs := system.Length(ss);
end;
Result := fb + fs;
s := s + ss;
Move(Pointer(s)^, Buffer^, Result);
ExceptCheck;
end;
function TBlockSocket.RecvPacket(Timeout: Integer): string;
@ -657,16 +717,19 @@ var
begin
Result := '';
FLastError := 0;
x := -1;
if FBuffer <> '' then
begin
Result := FBuffer;
FBuffer := '';
end
else
begin
Sleep(0);
if CanRead(Timeout) then
begin
x := WaitingData;
if x = 0 then
FLastError := WSAECONNRESET;
if x > 0 then
begin
SetLength(Result, x);
@ -677,9 +740,8 @@ begin
end
else
FLastError := WSAETIMEDOUT;
end;
ExceptCheck;
if x = 0 then
FLastError := WSAECONNRESET;
end;
@ -689,9 +751,7 @@ begin
FLastError := 0;
if FBuffer = '' then
FBuffer := RecvPacket(Timeout);
if (FBuffer = '') and (FLastError = 0) then
FLastError := WSAETIMEDOUT;
if FLastError = 0 then
if (FLastError = 0) and (FBuffer <> '') then
begin
Result := Ord(FBuffer[1]);
System.Delete(FBuffer, 1, 1);
@ -714,29 +774,7 @@ begin
if l = 0 then
Exit;
tl := l;
CorCRLF := FConvertLineEnd and (Terminator = #$0d + #$0a);
// if FBuffer contains requested data, return it...
if FBuffer<>'' then
begin
if CorCRLF then
begin
t := '';
x := PosCRLF(FBuffer, t);
tl := system.Length(t);
end
else
begin
x := pos(Terminator, FBuffer);
tl := l;
end;
if x > 0 then
begin
Result := copy(FBuffer, 1, x - 1);
System.Delete(FBuffer, 1, x + tl - 1);
Exit;
end;
end;
// now FBuffer is empty or not contains all data...
CorCRLF := FConvertLineEnd and (Terminator = CRLF);
s := '';
x := 0;
repeat
@ -744,17 +782,29 @@ begin
s := s + RecvPacket(Timeout);
if FLastError <> 0 then
Break;
if CorCRLF then
begin
t := '';
x := PosCRLF(s, t);
tl := system.Length(t);
end
else
begin
x := pos(Terminator, s);
tl := l;
end;
x := 0;
if Length(s) > 0 then
if CorCRLF then
begin
if FLastCR and (s[1] = LF) then
Delete(s, 1, 1);
if FLastLF and (s[1] = CR) then
Delete(s, 1, 1);
FLastCR := False;
FLastLF := False;
t := '';
x := PosCRLF(s, t);
tl := system.Length(t);
if t = CR then
FLastCR := True;
if t = LF then
FLastLF := True;
end
else
begin
x := pos(Terminator, s);
tl := l;
end;
if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then
begin
FLastError := WSAENOBUFS;
@ -775,7 +825,7 @@ var
s: string;
begin
Result := '';
s := RecvTerminated(Timeout, #13 + #10);
s := RecvTerminated(Timeout, CRLF);
if FLastError = 0 then
Result := s;
end;
@ -872,9 +922,14 @@ begin
if BufPtr[0] <> #0 then
begin
// try get Fully Qualified Domain Name
RemoteHost := synsock.GetHostByName(BufPtr);
if RemoteHost <> nil then
Result := PChar(RemoteHost^.h_name);
SynSockCS.Enter;
try
RemoteHost := synsock.GetHostByName(BufPtr);
if RemoteHost <> nil then
Result := PChar(RemoteHost^.h_name);
finally
SynSockCS.Leave;
end;
end;
if Result = '' then
Result := '127.0.0.1';
@ -896,23 +951,28 @@ begin
IP := synsock.inet_addr(PChar(Name));
if IP = u_long(INADDR_NONE) then
begin
RemoteHost := synsock.GetHostByName(PChar(Name));
if RemoteHost <> nil then
begin
PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
i := 0;
while PAdrPtr^[i] <> nil do
SynSockCS.Enter;
try
RemoteHost := synsock.GetHostByName(PChar(Name));
if RemoteHost <> nil then
begin
InAddr := PAdrPtr^[i]^;
with InAddr.S_un_b do
s := Format('%d.%d.%d.%d',
[Ord(s_b1), Ord(s_b2), Ord(s_b3), Ord(s_b4)]);
IPList.Add(s);
Inc(i);
PAdrPtr := PAPInAddr(RemoteHost^.h_addr_list);
i := 0;
while PAdrPtr^[i] <> nil do
begin
InAddr := PAdrPtr^[i]^;
with InAddr.S_un_b do
s := Format('%d.%d.%d.%d',
[Ord(s_b1), Ord(s_b2), Ord(s_b3), Ord(s_b4)]);
IPList.Add(s);
Inc(i);
end;
end;
if IPList.Count = 0 then
IPList.Add('0.0.0.0');
finally
SynSockCS.Leave;
end;
if IPList.Count = 0 then
IPList.Add('0.0.0.0');
end
else
IPList.Add(Name);
@ -936,14 +996,19 @@ var
ProtoEnt: PProtoEnt;
ServEnt: PServEnt;
begin
ProtoEnt := synsock.GetProtoByNumber(FProtocol);
ServEnt := nil;
if ProtoEnt <> nil then
ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
if ServEnt = nil then
Result := synsock.htons(StrToIntDef(Port, 0))
else
Result := ServEnt^.s_port;
SynSockCS.Enter;
try
ProtoEnt := synsock.GetProtoByNumber(FProtocol);
ServEnt := nil;
if ProtoEnt <> nil then
ServEnt := synsock.GetServByName(PChar(Port), ProtoEnt^.p_name);
if ServEnt = nil then
Result := synsock.htons(StrToIntDef(Port, 0))
else
Result := ServEnt^.s_port;
finally
SynSockCS.Leave;
end;
end;
procedure TBlockSocket.SetRemoteSin(IP, Port: string);
@ -1166,12 +1231,64 @@ begin
ExceptCheck;
end;
procedure TBlockSocket.SetTTL(TTL: integer);
var
Res: Integer;
begin
Res := synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @TTL, SizeOf(TTL));
SockCheck(Res);
ExceptCheck;
end;
function TBlockSocket.GetTTL:integer;
var
l: Integer;
begin
l := SizeOf(Result);
SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_TTL, @Result, l));
ExceptCheck;
end;
procedure TBlockSocket.DoStatus(Reason: THookSocketReason; const Value: string);
begin
if assigned(OnStatus) then
OnStatus(Self, Reason, Value);
end;
procedure TBlockSocket.DoReadFilter(Buffer: Pointer; var Length: Integer);
var
s: string;
begin
if assigned(OnReadFilter) then
if Length > 0 then
begin
SetLength(s, Length);
Move(Buffer^, Pointer(s)^, Length);
OnReadFilter(Self, s);
if System.Length(s) > Length then
SetLength(s, Length);
Length := System.Length(s);
Move(Pointer(s)^, Buffer^, Length);
end;
end;
procedure TBlockSocket.DoWriteFilter(Buffer: Pointer; var Length: Integer);
var
s: string;
begin
if assigned(OnWriteFilter) then
if Length > 0 then
begin
SetLength(s, Length);
Move(Buffer^, Pointer(s)^, Length);
OnWriteFilter(Self, s);
if System.Length(s) > Length then
SetLength(s, Length);
Length := System.Length(s);
Move(Pointer(s)^, Buffer^, Length);
end;
end;
class function TBlockSocket.GetErrorDesc(ErrorCode: Integer): string;
begin
case ErrorCode of
@ -1320,8 +1437,7 @@ begin
else
Buf := #5 + #2 + #2 +#0;
SendString(Buf);
Buf := RecvPacket(FSocksTimeout);
FBuffer := Copy(Buf, 3, Length(buf) - 2);
Buf := RecvBufferStr(2, FSocksTimeout);
if Length(Buf) < 2 then
Exit;
if Buf[1] <> #5 then
@ -1335,8 +1451,7 @@ begin
Buf := #1 + char(Length(FSocksUsername)) + FSocksUsername
+ char(Length(FSocksPassword)) + FSocksPassword;
SendString(Buf);
Buf := RecvPacket(FSocksTimeout);
FBuffer := Copy(Buf, 3, Length(buf) - 2);
Buf := RecvBufferStr(2, FSocksTimeout);
if Length(Buf) < 2 then
Exit;
if Buf[2] <> #0 then
@ -1369,7 +1484,7 @@ end;
function TSocksBlockSocket.SocksResponse: Boolean;
var
Buf: string;
Buf, s: string;
x: integer;
begin
Result := False;
@ -1377,18 +1492,33 @@ begin
try
FSocksResponseIP := '';
FSocksResponsePort := '';
Buf := RecvPacket(FSocksTimeout);
Buf := RecvBufferStr(4, FSocksTimeout);
if FLastError <> 0 then
Exit;
if Length(Buf) < 5 then
Exit;
if Buf[1] <> #5 then
Exit;
case Ord(Buf[4]) of
1:
s := RecvBufferStr(4, FSocksTimeout);
3:
begin
x := RecvByte(FSocksTimeout);
if FLastError <> 0 then
Exit;
s := char(x) + RecvBufferStr(x, FSocksTimeout);
end;
else
Exit;
end;
Buf := Buf + s + RecvBufferStr(2, FSocksTimeout);
if FLastError <> 0 then
Exit;
FSocksLastError := Ord(Buf[2]);
if FSocksLastError <> 0 then
Exit;
x := SocksDecode(Buf);
FBuffer := Copy(Buf, x, Length(buf) - x + 1);
SocksDecode(Buf);
Result := True;
finally
FBypassFlag := False;
@ -1414,6 +1544,8 @@ var
w: Word;
begin
FSocksResponsePort := '0';
if Length(Value) < 4 then
Exit;
Atyp := Ord(Value[4]);
Result := 5;
case Atyp of
@ -1505,14 +1637,12 @@ begin
if FSocksControlSock.LastError <> 0 then
Exit;
// if not assigned local port, assign it!
if GetLocalSinPort = 0 then
Bind(GetLocalSinIP, '0');
GetSins;
if not FBinded then
Bind('0.0.0.0', '0');
//open control TCP connection to SOCKS
b := FSocksControlSock.SocksOpen;
if b then
b := FSocksControlSock.SocksRequest(3, GetLocalSinIP,
IntToStr(GetLocalSinPort));
b := FSocksControlSock.SocksRequest(3, GetLocalSinIP, IntToStr(GetLocalSinPort));
if b then
b := FSocksControlSock.SocksResponse;
if not b and (FLastError = 0) then
@ -1520,7 +1650,7 @@ begin
FUsingSocks :=FSocksControlSock.UsingSocks;
FSocksRemoteIP := FSocksControlSock.FSocksResponseIP;
FSocksRemotePort := FSocksControlSock.FSocksResponsePort;
Result := True;
Result := b and (FLastError = 0);
end;
end;
@ -1530,22 +1660,27 @@ var
SPort: integer;
Buf: string;
begin
UdpAssociation;
if FUsingSocks then
begin
Sip := GetRemoteSinIp;
SPort := GetRemoteSinPort;
SetRemoteSin(FSocksRemoteIP, FSocksRemotePort);
SetLength(Buf,Length);
Move(Buffer^, PChar(Buf)^, Length);
Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf;
Result := inherited SendBufferTo(PChar(Buf), System.Length(buf));
SetRemoteSin(Sip, IntToStr(SPort));
end
FUsingSocks := False;
if (FSocksIP <> '') and (not UdpAssociation) then
FLastError := WSANO_RECOVERY
else
begin
Result := inherited SendBufferTo(Buffer, Length);
GetSins;
if FUsingSocks then
begin
Sip := GetRemoteSinIp;
SPort := GetRemoteSinPort;
SetRemoteSin(FSocksRemoteIP, FSocksRemotePort);
SetLength(Buf,Length);
Move(Buffer^, PChar(Buf)^, Length);
Buf := #0 + #0 + #0 + SocksCode(Sip, IntToStr(SPort)) + Buf;
Result := inherited SendBufferTo(PChar(Buf), System.Length(buf));
SetRemoteSin(Sip, IntToStr(SPort));
end
else
begin
Result := inherited SendBufferTo(Buffer, Length);
GetSins;
end;
end;
end;
@ -1589,6 +1724,36 @@ begin
ExceptCheck;
end;
procedure TUDPBlockSocket.SetMulticastTTL(TTL: integer);
var
Res: Integer;
begin
Res := synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @TTL, SizeOf(TTL));
SockCheck(Res);
ExceptCheck;
end;
function TUDPBlockSocket.GetMulticastTTL:integer;
var
l: Integer;
begin
l := SizeOf(Result);
SockCheck(synsock.GetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_TTL, @Result, l));
ExceptCheck;
end;
function TUDPBlockSocket.EnableMulticastLoop(Value: Boolean): Boolean;
var
Opt: Integer;
Res: Integer;
begin
opt := Ord(Value);
Res := synsock.SetSockOpt(FSocket, IPPROTO_IP, IP_MULTICAST_LOOP, @Opt, SizeOf(opt));
SockCheck(Res);
Result := res = 0;
ExceptCheck;
end;
{======================================================================}
function PasswordCallback(buf:PChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
@ -1643,7 +1808,8 @@ end;
procedure TTCPBlockSocket.CloseSocket;
begin
synsock.Shutdown(FSocket, 1);
if FSocket <> INVALID_SOCKET then
synsock.Shutdown(FSocket, 1);
inherited CloseSocket;
end;
@ -1761,11 +1927,11 @@ begin
if FLastError <> 0 then
Exit;
FHTTPTunnel := False;
SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + #$0d + #$0a);
SendString('CONNECT ' + IP + ':' + Port + ' HTTP/1.0' + CRLF);
if FHTTPTunnelUser <> '' then
Sendstring('Proxy-Authorization: Basic ' +
EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + #$0d + #$0a);
SendString(#$0d + #$0a);
EncodeBase64(FHTTPTunnelUser + ':' + FHTTPTunnelPass) + CRLF);
SendString(CRLF);
repeat
s := RecvTerminated(30000, #$0a);
if FLastError <> 0 then
@ -1975,6 +2141,7 @@ begin
FLastError := WSASYSNOTREADY;
ExceptCheck;
DoStatus(HR_ReadCount, IntToStr(Result));
DoReadFilter(Buffer, Result);
end
else
Result := inherited RecvBuffer(Buffer, Length);
@ -1987,6 +2154,7 @@ begin
if FSslEnabled and not(FSslBypass) and not(FBypassFlag) then
begin
FLastError := 0;
DoWriteFilter(Buffer, Length);
repeat
Result := SslWrite(FSsl, Buffer, Length);
err := SslGetError(FSsl, Result);
@ -2111,4 +2279,26 @@ begin
FTimeout := 5000;
end;
{======================================================================}
{$IFDEF ONCEWINSOCK}
initialization
begin
if not InitSocketInterface('') then
begin
e := ESynapseError.Create('Error loading Winsock DLL!');
e.ErrorCode := 0;
e.ErrorMessage := 'Error loading Winsock DLL!';
raise e;
end;
synsock.WSAStartup($101, WsaDataOnce);
end;
finalization
begin
synsock.WSACleanup;
DestroySocketInterface;
end;
{$ENDIF}
end.

305
dnssend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.002.000 |
| Project : Delphree - Synapse | 002.001.001 |
|==============================================================================|
| Content: DNS client |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2000,2001. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -94,31 +94,48 @@ const
QTYPE_NAPTR = 35; // RFC-2168
QTYPE_KX = 36;
QTYPE_AXFR = 252; //
QTYPE_AXFR = 252;
QTYPE_MAILB = 253; //
QTYPE_MAILA = 254; //
QTYPE_ALL = 255; //
QTYPE_ALL = 255;
type
TDNSSend = class(TSynaClient)
private
FID: Word;
FRCode: Integer;
FBuffer: string;
FSock: TUDPBlockSocket;
FTCPSock: TTCPBlockSocket;
FUseTCP: Boolean;
FAnsferInfo: TStringList;
FNameserverInfo: TStringList;
FAdditionalInfo: TStringList;
FAuthoritative: Boolean;
function CompressName(const Value: string): string;
function CodeHeader: string;
function CodeQuery(const Name: string; QType: Integer): string;
function DecodeLabels(var From: Integer): string;
function DecodeResource(var i: Integer; const Name: string;
function DecodeString(var From: Integer): string;
function DecodeResource(var i: Integer; const Info: TStringList;
QType: Integer): string;
function RecvTCPResponse(const WorkSock: TBlockSocket): string;
function DecodeResponse(const Buf: string; const Reply: TStrings;
QType: Integer):boolean;
public
constructor Create;
destructor Destroy; override;
function DNSQuery(Name: string; QType: Integer;
const Reply: TStrings): Boolean;
published
property RCode: Integer read FRCode;
property Sock: TUDPBlockSocket read FSock;
property TCPSock: TTCPBlockSocket read FTCPSock;
property UseTCP: Boolean read FUseTCP Write FUseTCP;
property RCode: Integer read FRCode;
property Authoritative: Boolean read FAuthoritative;
property AnsferInfo: TStringList read FAnsferInfo;
property NameserverInfo: TStringList read FNameserverInfo;
property AdditionalInfo: TStringList read FAdditionalInfo;
end;
function GetMailServers(const DNSHost, Domain: string;
@ -130,13 +147,22 @@ constructor TDNSSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 5000;
FTCPSock := TTCPBlockSocket.Create;
FUseTCP := False;
FTimeout := 10000;
FTargetPort := cDnsProtocol;
FAnsferInfo := TStringList.Create;
FNameserverInfo := TStringList.Create;
FAdditionalInfo := TStringList.Create;
Randomize;
end;
destructor TDNSSend.Destroy;
begin
FAnsferInfo.Free;
FNameserverInfo.Free;
FAdditionalInfo.Free;
FTCPSock.Free;
FSock.Free;
inherited Destroy;
end;
@ -168,8 +194,8 @@ end;
function TDNSSend.CodeHeader: string;
begin
Randomize;
Result := CodeInt(Random(32767)); // ID
FID := Random(32767);
Result := CodeInt(FID); // ID
Result := Result + CodeInt($0100); // flags
Result := Result + CodeInt(1); // QDCount
Result := Result + CodeInt(0); // ANCount
@ -184,6 +210,16 @@ begin
Result := Result + CodeInt(1); // Type INTERNET
end;
function TDNSSend.DecodeString(var From: Integer): string;
var
Len: integer;
begin
Len := Ord(FBuffer[From]);
Inc(From);
Result := Copy(FBuffer, From, Len);
Inc(From, Len);
end;
function TDNSSend.DecodeLabels(var From: Integer): string;
var
l, f: Integer;
@ -191,6 +227,8 @@ begin
Result := '';
while True do
begin
if From >= Length(FBuffer) then
Break;
l := Ord(FBuffer[From]);
Inc(From);
if l = 0 then
@ -213,88 +251,112 @@ begin
end;
end;
function TDNSSend.DecodeResource(var i: Integer; const Name: string;
function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList;
QType: Integer): string;
var
Rname: string;
RType, Len, j, x, n: Integer;
R: string;
t1, t2, ttl: integer;
begin
Result := '';
R := '';
Rname := DecodeLabels(i);
RType := DecodeInt(FBuffer, i);
Inc(i, 8);
Inc(i, 4);
t1 := DecodeInt(FBuffer, i);
Inc(i, 2);
t2 := DecodeInt(FBuffer, i);
Inc(i, 2);
ttl := t1 * 65536 + t2;
Len := DecodeInt(FBuffer, i);
Inc(i, 2); // i point to begin of data
j := i;
i := i + len; // i point to next record
if (Name = Rname) and (QType = RType) then
begin
case RType of
QTYPE_A:
case RType of
QTYPE_A:
begin
R := IntToStr(Ord(FBuffer[j]));
Inc(j);
R := R + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j);
R := R + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j);
R := R + '.' + IntToStr(Ord(FBuffer[j]));
end;
QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP,
QTYPE_NSAPPTR:
R := DecodeLabels(j);
QTYPE_SOA:
begin
R := DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
for n := 1 to 5 do
begin
Result := IntToStr(Ord(FBuffer[j]));
Inc(j);
Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j);
Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j);
Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
Inc(j, 4);
R := R + ',' + IntToStr(x);
end;
QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP,
QTYPE_NSAPPTR:
Result := DecodeLabels(j);
QTYPE_SOA:
begin
Result := DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
for n := 1 to 5 do
begin
x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
Inc(j, 4);
Result := Result + ',' + IntToStr(x);
end;
end;
QTYPE_NULL:
begin
end;
QTYPE_WKS:
begin
end;
QTYPE_HINFO, QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
begin
Result := DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
end;
QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
Result := IntToStr(x);
Result := Result + ',' + DecodeLabels(j);
end;
QTYPE_TXT:
Result := DecodeLabels(j);
QTYPE_GPOS:
begin
Result := DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
end;
QTYPE_PX:
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
Result := IntToStr(x);
Result := Result + ',' + DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
end;
end;
end;
QTYPE_NULL:
begin
end;
QTYPE_WKS:
begin
end;
QTYPE_HINFO:
begin
R := DecodeString(j);
R := R + ',' + DecodeString(j);
end;
QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
begin
R := DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
R := IntToStr(x);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_TXT:
R := DecodeString(j);
QTYPE_GPOS:
begin
R := DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_PX:
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
R := IntToStr(x);
R := R + ',' + DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
end;
end;
if R <> '' then
Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R);
if QType = RType then
Result := R;
end;
function TDNSSend.DNSQuery(Name: string; QType: Integer;
const Reply: TStrings): Boolean;
function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): string;
var
l: integer;
begin
Result := '';
l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout);
if l > 0 then
Result := WorkSock.RecvBufferStr(l, FTimeout);
end;
function TDNSSend.DecodeResponse(const Buf: string; const Reply: TStrings;
QType: Integer):boolean;
var
n, i: Integer;
flag, qdcount, ancount, nscount, arcount: Integer;
@ -302,43 +364,100 @@ var
begin
Result := False;
Reply.Clear;
if IsIP(Name) then
Name := ReverseIP(Name) + '.in-addr.arpa';
FBuffer := CodeHeader + CodeQuery(Name, QType);
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if (FSock.LastError = 0) and (Length(FBuffer) > 13) then
FAnsferInfo.Clear;
FNameserverInfo.Clear;
FAdditionalInfo.Clear;
FAuthoritative := False;
if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then
begin
flag := DecodeInt(FBuffer, 3);
flag := DecodeInt(Buf, 3);
FRCode := Flag and $000F;
FAuthoritative := (Flag and $0400) > 0;
if FRCode = 0 then
begin
qdcount := DecodeInt(FBuffer, 5);
ancount := DecodeInt(FBuffer, 7);
nscount := DecodeInt(FBuffer, 9);
arcount := DecodeInt(FBuffer, 11);
qdcount := DecodeInt(Buf, 5);
ancount := DecodeInt(Buf, 7);
nscount := DecodeInt(Buf, 9);
arcount := DecodeInt(Buf, 11);
i := 13; //begin of body
if qdcount > 0 then //skip questions
if (qdcount > 0) and (Length(Buf) > i) then //skip questions
for n := 1 to qdcount do
begin
while (FBuffer[i] <> #0) and ((Ord(FBuffer[i]) and $C0) <> $C0) do
while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do
Inc(i);
Inc(i, 5);
end;
if ancount > 0 then
if (ancount > 0) and (Length(Buf) > i) then // decode reply
for n := 1 to ancount do
begin
s := DecodeResource(i, Name, QType);
s := DecodeResource(i, FAnsferInfo, QType);
if s <> '' then
Reply.Add(s);
end;
if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info
for n := 1 to nscount do
DecodeResource(i, FNameserverInfo, QType);
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;
function TDNSSend.DNSQuery(Name: string; QType: Integer;
const Reply: TStrings): Boolean;
var
WorkSock: TBlockSocket;
t: TStringList;
b: boolean;
begin
Result := False;
if IsIP(Name) then
Name := ReverseIP(Name) + '.in-addr.arpa';
FBuffer := CodeHeader + CodeQuery(Name, QType);
if FUseTCP then
WorkSock := FTCPSock
else
WorkSock := FSock;
WorkSock.Bind(FIPInterface, cAnyPort);
WorkSock.Connect(FTargetHost, FTargetPort);
if FUseTCP then
FBuffer := Codeint(length(FBuffer)) + FBuffer;
WorkSock.SendString(FBuffer);
if FUseTCP then
FBuffer := RecvTCPResponse(WorkSock)
else
FBuffer := WorkSock.RecvPacket(FTimeout);
if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer
begin
t := TStringList.Create;
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 b then
begin
t.AddStrings(AnsferInfo);
FBuffer := RecvTCPResponse(WorkSock);
if FBuffer = '' then
Break;
if WorkSock.LastError <> 0 then
Break;
end;
until not b;
Reply.Assign(t);
Result := True;
finally
t.free;
end;
end
else //normal query
if WorkSock.LastError = 0 then
Result := DecodeResponse(FBuffer, Reply, QType);
end;
{==============================================================================}
function GetMailServers(const DNSHost, Domain: string;

197
ftpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.003.001 |
| Project : Delphree - Synapse | 002.005.004 |
|==============================================================================|
| Content: FTP client |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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-2002. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -112,6 +112,10 @@ type
FPassiveMode: Boolean;
FForceDefaultPort: Boolean;
FFtpList: TFTPList;
FBinaryMode: Boolean;
FAutoTLS: Boolean;
FIsTLS: Boolean;
FFullSSL: Boolean;
function Auth(Mode: integer): Boolean;
function Connect: Boolean;
function InternalStor(const Command: string; RestoreAt: integer): Boolean;
@ -169,6 +173,10 @@ type
property ForceDefaultPort: Boolean read FForceDefaultPort Write FForceDefaultPort;
property OnStatus: TFTPStatus read FOnStatus write FOnStatus;
property FtpList: TFTPList read FFtpList;
property BinaryMode: Boolean read FBinaryMode Write FBinaryMode;
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
property FullSSL: Boolean read FFullSSL Write FFullSSL;
property IsTLS: Boolean read FIsTLS;
end;
function FtpGetFile(const IP, Port, FileName, LocalFile,
@ -181,15 +189,13 @@ function FtpInterServerTransfer(
implementation
const
CRLF = #13#10;
constructor TFTPSend.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FDataStream := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create;
FSock.ConvertLineEnd := True;
FDSock := TTCPBlockSocket.Create;
FFtpList := TFTPList.Create;
FTimeout := 300000;
@ -205,6 +211,10 @@ begin
FFWUsername := '';
FFWPassword := '';
FFWMode := 0;
FBinaryMode := True;
FAutoTLS := False;
FFullSSL := False;
FIsTLS := False;
end;
destructor TFTPSend.Destroy;
@ -256,38 +266,114 @@ end;
// based on idea by Petr Esner <petr.esner@atlas.cz>
function TFTPSend.Auth(Mode: integer): Boolean;
const
// Direct connection USER[+PASS[+ACCT]]
//if not USER <username> then
// if not PASS <password> then
// if not ACCT <account> then ERROR!
//OK!
Action0: TLogonActions =
(0, FTP_OK, 3, 1, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0);
// SITE <hostname>
(0, FTP_OK, 3,
1, FTP_OK, 6,
2, FTP_OK, FTP_ERR,
0, 0, 0, 0, 0, 0, 0, 0, 0);
//if not USER <FWusername> then
// if not PASS <FWPassword> then ERROR!
//if SITE <FTPServer> then ERROR!
//if not USER <username> then
// if not PASS <password> then
// if not ACCT <account> then ERROR!
//OK!
Action1: TLogonActions =
(3, 6, 3, 4, 6, FTP_ERR, 5, FTP_ERR, 9, 0, FTP_OK, 12, 1, FTP_OK, 15, 2,
FTP_OK, FTP_ERR);
// USER after logon
(3, 6, 3,
4, 6, FTP_ERR,
5, FTP_ERR, 9,
0, FTP_OK, 12,
1, FTP_OK, 15,
2, FTP_OK, FTP_ERR);
//if not USER <FWusername> then
// if not PASS <FWPassword> then ERROR!
//if USER <UserName>'@'<FTPServer> then OK!
//if not PASS <password> then
// if not ACCT <account> then ERROR!
//OK!
Action2: TLogonActions =
(3, 6, 3, 4, 6, FTP_ERR, 6, FTP_OK, 9, 1, FTP_OK, 12, 2, FTP_OK, FTP_ERR,
(3, 6, 3,
4, 6, FTP_ERR,
6, FTP_OK, 9,
1, FTP_OK, 12,
2, FTP_OK, FTP_ERR,
0, 0, 0);
// Transparent
//if not USER <FWusername> then
// if not PASS <FWPassword> then ERROR!
//if not USER <username> then
// if not PASS <password> then
// if not ACCT <account> then ERROR!
//OK!
Action3: TLogonActions =
(3, 6, 3, 4, 6, FTP_ERR, 0, FTP_OK, 9, 1, FTP_OK, 12, 2, FTP_OK, FTP_ERR,
(3, 6, 3,
4, 6, FTP_ERR,
0, FTP_OK, 9,
1, FTP_OK, 12,
2, FTP_OK, FTP_ERR,
0, 0, 0);
// proxy OPEN
//OPEN <FTPserver>
//if not USER <username> then
// if not PASS <password> then
// if not ACCT <account> then ERROR!
//OK!
Action4: TLogonActions =
(7, 3, 3, 0, FTP_OK, 6, 1, FTP_OK, 9, 2, FTP_OK, FTP_ERR,
(7, 3, 3,
0, FTP_OK, 6,
1, FTP_OK, 9,
2, FTP_OK, FTP_ERR,
0, 0, 0, 0, 0, 0);
// USER with no logon
//if USER <UserName>'@'<FTPServer> then OK!
//if not PASS <password> then
// if not ACCT <account> then ERROR!
//OK!
Action5: TLogonActions =
(6, FTP_OK, 3, 1, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0);
// USER fireID@remotehost
(6, FTP_OK, 3,
1, FTP_OK, 6,
2, FTP_OK, FTP_ERR,
0, 0, 0, 0, 0, 0, 0, 0, 0);
//if not USER <FWUserName>@<FTPServer> then
// if not PASS <FWPassword> then ERROR!
//if not USER <username> then
// if not PASS <password> then
// if not ACCT <account> then ERROR!
//OK!
Action6: TLogonActions =
(8, 6, 3, 4, 6, FTP_ERR, 0, FTP_OK, 9, 1, FTP_OK, 12, 2, FTP_OK, FTP_ERR,
(8, 6, 3,
4, 6, FTP_ERR,
0, FTP_OK, 9,
1, FTP_OK, 12,
2, FTP_OK, FTP_ERR,
0, 0, 0);
// USER remoteID@remotehost fireID
//if USER <UserName>@<FTPServer> <FWUserName> then ERROR!
//if not PASS <password> then
// if not ACCT <account> then ERROR!
//OK!
Action7: TLogonActions =
(9, FTP_ERR, 3, 1, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0);
// USER remoteID@fireID@remotehost
(9, FTP_ERR, 3,
1, FTP_OK, 6,
2, FTP_OK, FTP_ERR,
0, 0, 0, 0, 0, 0, 0, 0, 0);
//if not USER <UserName>@<FWUserName>@<FTPServer> then
// if not PASS <Password>@<FWPassword> then
// if not ACCT <account> then ERROR!
//OK!
Action8: TLogonActions =
(10, FTP_OK, 3, 11, FTP_OK, 6, 2, FTP_OK, FTP_ERR, 0, 0, 0, 0, 0, 0, 0, 0, 0);
(10, FTP_OK, 3,
11, FTP_OK, 6,
2, FTP_OK, FTP_ERR,
0, 0, 0, 0, 0, 0, 0, 0, 0);
var
FTPServer: string;
LogonActions: TLogonActions;
@ -362,6 +448,8 @@ function TFTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.CreateSocket;
if FFullSSL then
FSock.SSLEnabled := True;
FSock.Bind(FIPInterface, cAnyPort);
if FFWHost = '' then
FSock.Connect(FTargetHost, FTargetPort)
@ -376,10 +464,22 @@ begin
FCanResume := False;
if not Connect then
Exit;
FIsTLS := FFullSSL;
if (ReadResult div 100) <> 2 then
Exit;
if FAutoTLS and not(FIsTLS) then
if (FTPCommand('AUTH TLS') div 100) = 2 then
begin
FSock.SSLDoConnect;
FIsTLS := True;
end;
if not Auth(FFWMode) then
Exit;
if FIsTLS then
begin
FTPCommand('PROT P');
FTPCommand('PBSZ 0');
end;
FTPCommand('TYPE I');
FTPCommand('STRU F');
FTPCommand('MODE S');
@ -458,12 +558,13 @@ begin
FSock.Bind(FIPInterface, s);
if FDSock.LastError <> 0 then
Exit;
FDSock.SetLinger(True, 10);
FDSock.Listen;
FDSock.GetSins;
FDataIP := FDSock.GetLocalSinIP;
FDataIP := FDSock.ResolveName(FDataIP);
FDataPort := IntToStr(FDSock.GetLocalSinPort);
s := StringReplace(FDataIP, '.', ',');
s := ReplaceString(FDataIP, '.', ',');
s := 'PORT ' + s + ',' + IntToStr(FDSock.GetLocalSinPort div 256)
+ ',' + IntToStr(FDSock.GetLocalSinPort mod 256);
Result := (FTPCommand(s) div 100) = 2;
@ -488,6 +589,8 @@ begin
Result := True;
end;
end;
if FIsTLS then
FDSock.SSLDoConnect;
end;
function TFTPSend.DataRead(const DestStream: TStream): Boolean;
@ -604,7 +707,10 @@ begin
try
if not DataSocket then
Exit;
FTPCommand('TYPE I');
if FBinaryMode then
FTPCommand('TYPE I')
else
FTPCommand('TYPE A');
if Restore then
begin
RetrStream.Seek(0, soFromEnd);
@ -642,7 +748,10 @@ begin
try
if not DataSocket then
Exit;
FTPCommand('TYPE I');
if FBinaryMode then
FTPCommand('TYPE I')
else
FTPCommand('TYPE A');
StorSize := SendStream.Size;
if not FCanResume then
RestoreAt := 0;
@ -759,6 +868,11 @@ begin
end;
end;
procedure TFTPSend.Abort;
begin
FDSock.CloseSocket;
end;
{==============================================================================}
constructor TFTPList.Create;
@ -965,11 +1079,11 @@ begin
else
begin
flr.Readable := true;
flr.Filesize := StrToIntDef(s, 0);
flr.FileSize := StrToIntDef(s, 0);
end;
if Value = '' then
Exit;
flr.FileName := Trim(s);
flr.FileName := Trim(Value);
Result := True;
Exit;
end;
@ -1103,27 +1217,27 @@ begin
Exit;
if not ToFTP.Login then
Exit;
if FromFTP.FTPCommand('PASV') <> 227 then
if (FromFTP.FTPCommand('PASV') div 100) <> 2 then
Exit;
FromFTP.ParseRemote(FromFTP.ResultString);
s := StringReplace(FromFTP.DataIP, '.', ',');
s := ReplaceString(FromFTP.DataIP, '.', ',');
s := 'PORT ' + s + ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) div 256)
+ ',' + IntToStr(StrToIntDef(FromFTP.DataPort, 0) mod 256);
if ToFTP.FTPCommand(s) <> 200 then
if (ToFTP.FTPCommand(s) div 100) <> 2 then
Exit;
x := FromFTP.FTPCommand('STOR ' + FromFile);
if (x <> 125) and (x <> 150) then
x := ToFTP.FTPCommand('RETR ' + FromFile);
if (x div 100) <> 1 then
Exit;
x := ToFTP.FTPCommand('RETR ' + ToFile);
if (x <> 125) and (x <> 150) then
x := FromFTP.FTPCommand('STOR ' + ToFile);
if (x div 100) <> 1 then
Exit;
FromFTP.Timeout := 21600000;
x := FromFTP.ReadResult;
if (x <> 226) and (x <> 250) then
if (x div 100) <> 2 then
Exit;
ToFTP.Timeout := 21600000;
x := ToFTP.ReadResult;
if (x <> 226) and (x <> 250) then
if (x div 100) <> 2 then
Exit;
Result := True;
finally
@ -1132,9 +1246,4 @@ begin
end;
end;
procedure TFTPSend.Abort;
begin
FDSock.CloseSocket;
end;
end.

94
httpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 003.002.000 |
| Project : Delphree - Synapse | 003.004.004 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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-2002. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -75,18 +75,29 @@ type
FProxyPass: string;
FResultCode: Integer;
FResultString: string;
FUserAgent: string;
FCookies: TStringList;
FDownloadSize: integer;
FUploadSize: integer;
FRangeStart: integer;
FRangeEnd: integer;
function ReadUnknown: Boolean;
function ReadIdentity(Size: Integer): Boolean;
function ReadChunked: Boolean;
procedure ParseCookies;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure DecodeStatus(const Value: string);
function HTTPMethod(const Method, URL: string): Boolean;
procedure Abort;
published
property Headers: TStringList read FHeaders Write FHeaders;
property Document: TMemoryStream read FDocument Write FDocument;
property Headers: TStringList read FHeaders;
property Cookies: TStringList read FCookies;
property Document: TMemoryStream read FDocument;
property RangeStart: integer read FRangeStart Write FRangeStart;
property RangeEnd: integer read FRangeEnd Write FRangeEnd;
property MimeType: string read FMimeType Write FMimeType;
property Protocol: string read FProtocol Write FProtocol;
property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
@ -94,8 +105,11 @@ type
property ProxyPort: string read FProxyPort Write FProxyPort;
property ProxyUser: string read FProxyUser Write FProxyUser;
property ProxyPass: string read FProxyPass Write FProxyPass;
property UserAgent: string read FUserAgent Write FUserAgent;
property ResultCode: Integer read FResultCode;
property ResultString: string read FResultString;
property DownloadSize: integer read FDownloadSize;
property UploadSize: integer read FUploadSize;
property Sock: TTCPBlockSocket read FSock;
end;
@ -108,18 +122,16 @@ function HttpPostFile(const URL, FieldName, FileName: string;
implementation
const
CRLF = #13#10;
constructor THTTPSend.Create;
begin
inherited Create;
FHeaders := TStringList.Create;
FCookies := TStringList.Create;
FDocument := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create;
FSock.ConvertLineEnd := True;
FSock.SizeRecvBuffer := 65536;
FSock.SizeSendBuffer := 65536;
FSock.ConvertLineEnd := True;
FTimeout := 300000;
FTargetPort := cHttpProtocol;
FProxyHost := '';
@ -130,6 +142,9 @@ begin
FAlivePort := '';
FProtocol := '1.0';
FKeepAlive := True;
FUserAgent := 'Mozilla/4.0 (compatible; Synapse)';
FDownloadSize := 0;
FUploadSize := 0;
Clear;
end;
@ -137,12 +152,15 @@ destructor THTTPSend.Destroy;
begin
FSock.Free;
FDocument.Free;
FCookies.Free;
FHeaders.Free;
inherited Destroy;
end;
procedure THTTPSend.Clear;
begin
FRangeStart := 0;
FRangeEnd := 0;
FDocument.Clear;
FHeaders.Clear;
FMimeType := 'text/html';
@ -170,11 +188,14 @@ var
Prot, User, Pass, Host, Port, Path, Para, URI: string;
s, su: string;
HttpTunnel: Boolean;
n: integer;
begin
{initial values}
Result := False;
FResultCode := 500;
FResultString := '';
FDownloadSize := 0;
FUploadSize := 0;
URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
@ -208,6 +229,15 @@ begin
if FMimeType <> '' then
FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
end;
{ setting User-agent }
if FUserAgent <> '' then
FHeaders.Insert(0, 'User-Agent: ' + FUserAgent);
{ setting Ranges }
if FRangeEnd > 0 then
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd));
{ setting Cookies }
for n := 0 to FCookies.Count - 1 do
FHeaders.Insert(0, 'Cookie: ' + FCookies[n]);
{ setting KeepAlives }
if not FKeepAlive then
FHeaders.Insert(0, 'Connection: close');
@ -309,6 +339,7 @@ begin
{ send document }
if Sending then
begin
FUploadSize := FDocument.Size;
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
if FSock.LastError <> 0 then
Exit;
@ -382,15 +413,16 @@ begin
TE_CHUNKED:
ReadChunked;
end;
Result := True;
FDocument.Seek(0, soFromBeginning);
Result := True;
if ToClose then
begin
FSock.CloseSocket;
FAliveHost := '';
FAlivePort := '';
end;
ParseCookies;
end;
function THTTPSend.ReadUnknown: Boolean;
@ -407,17 +439,13 @@ end;
function THTTPSend.ReadIdentity(Size: Integer): Boolean;
var
mem: TMemoryStream;
x: integer;
begin
mem := TMemoryStream.Create;
try
mem.SetSize(Size);
FSock.RecvBufferEx(mem.Memory, Size, FTimeout);
Result := FSock.LastError = 0;
FDocument.CopyFrom(mem, 0);
finally
mem.Free;
end;
FDownloadSize := Size;
FDocument.SetSize(FDocument.Position + Size);
x := FSock.RecvBufferEx(IncPoint(FDocument.Memory, FDocument.Position), Size, FTimeout);
FDocument.SetSize(FDocument.Position + x);
Result := FSock.LastError = 0;
end;
function THTTPSend.ReadChunked: Boolean;
@ -440,6 +468,28 @@ begin
Result := FSock.LastError = 0;
end;
procedure THTTPSend.ParseCookies;
var
n: integer;
s: string;
sn, sv: string;
begin
for n := 0 to FHeaders.Count - 1 do
if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then
begin
s := SeparateRight(FHeaders[n], ':');
s := trim(SeparateLeft(s, ';'));
sn := trim(SeparateLeft(s, '='));
sv := trim(SeparateRight(s, '='));
FCookies.Values[sn] := sv;
end;
end;
procedure THTTPSend.Abort;
begin
FSock.CloseSocket;
end;
{==============================================================================}
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
@ -502,8 +552,6 @@ end;
function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStrings): Boolean;
const
CRLF = #$0D + #$0A;
var
HTTP: THTTPSend;
Bound, s: string;
@ -519,7 +567,7 @@ begin
HTTP.Document.CopyFrom(Data, 0);
s := CRLF + '--' + Bound + '--' + CRLF;
HTTP.Document.Write(Pointer(s)^, Length(s));
HTTP.MimeType := 'multipart/form-data, boundary=' + Bound;
HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
Result := HTTP.HTTPMethod('POST', URL);
ResultData.LoadFromStream(HTTP.Document);
finally

59
imapsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.001.000 |
| Project : Delphree - Synapse | 002.002.002 |
|==============================================================================|
| Content: IMAP4rev1 client |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2001-2002. |
| Portions created by Lukas Gebauer are Copyright (c)2001-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -115,6 +115,7 @@ type
function SetFlagsMess(MessID: integer; Flags: string): Boolean;
function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
function StartTLS: Boolean;
function GetUID(MessID: integer; var UID : Integer): Boolean;
function FindCap(const Value: string): string;
published
property ResultString: string read FResultString;
@ -135,19 +136,16 @@ type
implementation
const
CRLF = #13#10;
constructor TIMAPSend.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FIMAPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.ConvertLineEnd := True;
FSock.CreateSocket;
FSock.SizeRecvBuffer := 32768;
FSock.SizeSendBuffer := 32768;
FSock.ConvertLineEnd := True;
FTimeout := 300000;
FTargetPort := cIMAPProtocol;
FUsername := '';
@ -196,9 +194,7 @@ begin
l := StrToIntDef(s, -1);
if l <> -1 then
begin
setlength(s, l);
x := FSock.recvbufferex(PChar(s), l, FTimeout);
SetLength(s, x);
s := FSock.RecvBufferStr(l, FTimeout);
FFullResult.Add(s);
end;
end;
@ -220,7 +216,8 @@ var
begin
Inc(FTagCommand);
l := Length(Data.Text);
FSock.SendString(IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
FSock.RecvString(FTimeout);
FSock.SendString(Data.Text + CRLF);
Result := ReadResult;
end;
@ -247,9 +244,18 @@ begin
for n := 0 to FFullResult.Count - 1 do
begin
s := FFullResult[n];
x := RPos(' ', s);
if (x > 0) and (Pos('NOSELECT', UpperCase(s)) = 0) then
Value.Add(Copy(s, x + 1, Length(s) - x));
if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then
begin
if s[Length(s)] = '"' then
begin
Delete(s, Length(s), 1);
x := RPos('"', s);
end
else
x := RPos(' ', s);
if (x > 0) then
Value.Add(Copy(s, x + 1, Length(s) - x));
end;
end;
end;
@ -472,7 +478,7 @@ begin
for n := 0 to FFullResult.Count - 1 do
begin
s := UpperCase(FFullResult[n]);
if (Pos('* STATUS ', s) = 1) and (Pos(Value, s) > 0 ) then
if (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then
begin
t := SeparateRight(s, Value);
t := SeparateLeft(t, ')');
@ -598,7 +604,7 @@ begin
for n := 0 to FFullResult.Count - 1 do
begin
s := uppercase(FFullResult[n]);
if Pos('* FETCH (FLAGS', s) = 1 then
if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then
begin
s := SeparateRight(s, 'FLAGS');
s := Separateright(s, '(');
@ -620,6 +626,27 @@ begin
end;
end;
//Paul Buskermolen <p.buskermolen@pinkroccade.com>
function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean;
var
s, sUid: string;
n: integer;
begin
sUID := '';
s := 'FETCH ' + IntToStr(MessID) + ' UID';
Result := IMAPcommand(s) = 'OK';
for n := 0 to FFullResult.Count - 1 do
begin
s := uppercase(FFullResult[n]);
if Pos('FETCH (UID', s) >= 1 then
begin
s := Separateright(s, '(UID ');
sUID := SeparateLeft(s, ')');
end;
end;
UID := StrToIntDef(sUID, 0);
end;
{==============================================================================}
end.

31
mimeinln.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.003 |
| Project : Delphree - Synapse | 001.000.005 |
|==============================================================================|
| Content: Inline MIME support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2000,2001. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -64,7 +64,7 @@ implementation
function InlineDecode(const Value: string; CP: TMimeChar): string;
var
s, su: string;
s, su, v: string;
x, y, z, n: Integer;
ichar: TMimeChar;
c: Char;
@ -88,12 +88,17 @@ var
end;
begin
Result := Value;
x := Pos('=?', Result);
y := SearchEndInline(Result, x);
while (y > x) and (x > 0) do //fix by Marcus Moennig (minibbjd@gmx.de)
Result := '';
v := Value;
x := Pos('=?', v);
y := SearchEndInline(v, x);
while (y > x) and (x > 0) do
begin
s := Copy(Result, x, y - x + 2);
s := Copy(v, 1, x - 1);
if Trim(s) <> '' then
Result := Result + s;
s := Copy(v, x, y - x + 2);
Delete(v, 1, y + 1);
su := Copy(s, 3, Length(s) - 4);
ichar := GetCPFromID(su);
z := Pos('?', su);
@ -118,11 +123,11 @@ begin
s := CharsetConversion(s, ichar, CP);
end;
end;
Result := Copy(Result, 1, x - 1) + s +
Copy(Result, y + 2, Length(Result) - y - 1);
x := Pos('=?', Result);
y := SearchEndInline(Result, x);
Result := Result + s;
x := Pos('=?', v);
y := SearchEndInline(v, x);
end;
Result := Result + v;
end;
{==============================================================================}

10
mimemess.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.001.001 |
| Project : Delphree - Synapse | 002.001.002 |
|==============================================================================|
| Content: MIME message object |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2000-2002. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -154,9 +154,9 @@ begin
if FCustomHeaders[n] <> '' then
Value.Insert(0, FCustomHeaders[n]);
if FXMailer = '' then
Value.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer')
Value.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer')
else
Value.Insert(0, 'x-mailer: ' + FXMailer);
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));

65
mimepart.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.001.002 |
| Project : Delphree - Synapse | 002.003.002 |
|==============================================================================|
| Content: MIME support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2000-2002. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -95,6 +95,8 @@ type
public
constructor Create;
destructor Destroy; override;
procedure Assign(Value: TMimePart);
procedure AssignSubParts(Value: TMimePart);
procedure Clear;
procedure DecodePart;
procedure DecodePartHeader;
@ -103,6 +105,7 @@ type
procedure MimeTypeFromExt(Value: string);
function GetSubPartCount: integer;
function GetSubPart(index: integer): TMimePart;
procedure DeleteSubPart(index: integer);
procedure ClearSubParts;
function AddSubPart: TMimePart;
procedure DecomposeParts;
@ -255,6 +258,47 @@ end;
{==============================================================================}
procedure TMIMEPart.Assign(Value: TMimePart);
begin
Primary := Value.Primary;
Encoding := Value.Encoding;
Charset := Value.Charset;
DefaultCharset := Value.DefaultCharset;
PrimaryCode := Value.PrimaryCode;
EncodingCode := Value.EncodingCode;
CharsetCode := Value.CharsetCode;
TargetCharset := Value.TargetCharset;
Secondary := Value.Secondary;
Description := Value.Description;
Disposition := Value.Disposition;
ContentID := Value.ContentID;
Boundary := Value.Boundary;
FileName := Value.FileName;
Lines.Assign(Value.Lines);
PartBody.Assign(Value.PartBody);
Headers.Assign(Value.Headers);
PrePart.Assign(Value.PrePart);
PostPart.Assign(Value.PostPart);
MaxLineLength := Value.MaxLineLength;
end;
{==============================================================================}
procedure TMIMEPart.AssignSubParts(Value: TMimePart);
var
n: integer;
p: TMimePart;
begin
Assign(Value);
for n := 0 to Value.GetSubPartCount - 1 do
begin
p := AddSubPart;
p.AssignSubParts(Value.GetSubPart(n));
end;
end;
{==============================================================================}
function TMIMEPart.GetSubPartCount: integer;
begin
Result := FSubParts.Count;
@ -271,6 +315,17 @@ end;
{==============================================================================}
procedure TMIMEPart.DeleteSubPart(index: integer);
begin
if Index < GetSubPartCount then
begin
GetSubPart(Index).Free;
FSubParts.Delete(Index);
end;
end;
{==============================================================================}
procedure TMIMEPart.ClearSubParts;
var
n: integer;
@ -342,7 +397,7 @@ begin
Mime := AddSubPart;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
s := FLines[x];
Inc(x);
if Pos('--' + FBoundary, s) = 1 then
Break;
@ -702,7 +757,7 @@ begin
begin
s := '';
if FFileName <> '' then
s := '; FileName="' + FFileName + '"';
s := '; FileName="' + InlineCode(FFileName) + '"';
FHeaders.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
end;
if FContentID <> '' then

160
nntpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.001.000 |
| Project : Delphree - Synapse | 001.002.003 |
|==============================================================================|
| Content: NNTP client |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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,2000,2001. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -62,6 +62,9 @@ type
FResultCode: Integer;
FResultString: string;
FData: TStringList;
FDataToSend: TStringList;
FUsername: string;
FPassword: string;
function ReadResult: Integer;
function ReadData: boolean;
function SendData: boolean;
@ -71,6 +74,9 @@ type
destructor Destroy; override;
function Login: Boolean;
procedure Logout;
function DoCommand(const Command: string): boolean;
function DoCommandRead(const Command: string): boolean;
function DoCommandWrite(const Command: string): boolean;
function GetArticle(const Value: string): Boolean;
function GetBody(const Value: string): Boolean;
function GetHead(const Value: string): Boolean;
@ -84,7 +90,10 @@ type
function NewArticles(const Group: string; Since: TDateTime): Boolean;
function PostArticle: Boolean;
function SwitchToSlave: Boolean;
function Xover(xoStart, xoEnd: string): boolean;
published
property Username: string read FUsername write FUsername;
property Password: string read FPassword write FPassword;
property ResultCode: Integer read FResultCode;
property ResultString: string read FResultString;
property Data: TStringList read FData;
@ -93,23 +102,23 @@ type
implementation
const
CRLF = #13#10;
constructor TNNTPSend.Create;
begin
inherited Create;
FData := TStringList.Create;
FDataToSend := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.CreateSocket;
FSock.ConvertLineEnd := True;
FTimeout := 300000;
FTargetPort := cNNTPProtocol;
FUsername := '';
FPassword := '';
end;
destructor TNNTPSend.Destroy;
begin
FSock.Free;
FDataToSend.Free;
FData.Free;
inherited Destroy;
end;
@ -149,22 +158,26 @@ var
s: string;
n: integer;
begin
for n := 0 to FData.Count -1 do
for n := 0 to FDataToSend.Count - 1 do
begin
s := FData[n];
if (s <> '') and (s[1]='.') then
s := FDataToSend[n];
if (s <> '') and (s[1] = '.') then
s := s + '.';
FSock.SendString(s + CRLF);
if FSock.LastError <> 0 then
break;
end;
if FDataToSend.Count = 0 then
FSock.SendString(CRLF);
if FSock.LastError = 0 then
FSock.SendString('.' + CRLF);
FDataToSend.Clear;
Result := FSock.LastError = 0;
end;
function TNNTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.CreateSocket;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0;
@ -176,6 +189,15 @@ begin
if not Connect then
Exit;
Result := (ReadResult div 100) = 2;
if (FUsername <> '') and Result then
begin
FSock.SendString('AUTHINFO USER ' + FUsername + CRLF);
if (ReadResult div 100) = 3 then
begin
FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF);
Result := (ReadResult div 100) = 2;
end;
end;
end;
procedure TNNTPSend.Logout;
@ -185,136 +207,132 @@ begin
FSock.CloseSocket;
end;
function TNNTPSend.DoCommand(const Command: string): Boolean;
begin
FSock.SendString(Command + CRLF);
Result := (ReadResult div 100) = 2;
Result := Result and (FSock.LastError = 0);
end;
function TNNTPSend.DoCommandRead(const Command: string): Boolean;
begin
Result := DoCommand(Command);
if Result then
begin
Result := ReadData;
Result := Result and (FSock.LastError = 0);
end;
end;
function TNNTPSend.DoCommandWrite(const Command: string): Boolean;
var
x: integer;
begin
FDataToSend.Assign(FData);
FSock.SendString(Command + CRLF);
x := (ReadResult div 100);
if x = 3 then
begin
SendData;
x := (ReadResult div 100);
end;
Result := x = 2;
Result := Result and (FSock.LastError = 0);
end;
function TNNTPSend.GetArticle(const Value: string): Boolean;
var
s: string;
begin
Result := False;
s := 'ARTICLE';
if Value <> '' then
s := s + ' ' + Value;
FSock.SendString(s + CRLF);
if (ReadResult div 100) <> 2 then
Exit;
Result := ReadData;
Result := DoCommandRead(s);
end;
function TNNTPSend.GetBody(const Value: string): Boolean;
var
s: string;
begin
Result := False;
s := 'BODY';
if Value <> '' then
s := s + ' ' + Value;
FSock.SendString(s + CRLF);
if (ReadResult div 100) <> 2 then
Exit;
Result := ReadData;
Result := DoCommandRead(s);
end;
function TNNTPSend.GetHead(const Value: string): Boolean;
var
s: string;
begin
Result := False;
s := 'HEAD';
if Value <> '' then
s := s + ' ' + Value;
FSock.SendString(s + CRLF);
if (ReadResult div 100) <> 2 then
Exit;
Result := ReadData;
Result := DoCommandRead(s);
end;
function TNNTPSend.GetStat(const Value: string): Boolean;
var
s: string;
begin
Result := False;
s := 'STAT';
if Value <> '' then
s := s + ' ' + Value;
FSock.SendString(s + CRLF);
if (ReadResult div 100) <> 2 then
Exit;
Result := FSock.LastError = 0;
Result := DoCommandRead(s);
end;
function TNNTPSend.SelectGroup(const Value: string): Boolean;
begin
FSock.SendString('GROUP ' + Value + CRLF);
Result := (ReadResult div 100) = 2;
Result := DoCommand('GROUP ' + Value);
end;
function TNNTPSend.IHave(const MessID: string): Boolean;
var
x: integer;
begin
FSock.SendString('IHAVE ' + MessID + CRLF);
x := (ReadResult div 100);
if x = 3 then
begin
SendData;
x := (ReadResult div 100);
end;
Result := x = 2;
Result := DoCommandWrite('IHAVE ' + MessID);
end;
function TNNTPSend.GotoLast: Boolean;
begin
FSock.SendString('LAST' + CRLF);
Result := (ReadResult div 100) = 2;
Result := DoCommand('LAST');
end;
function TNNTPSend.GotoNext: Boolean;
begin
FSock.SendString('NEXT' + CRLF);
Result := (ReadResult div 100) = 2;
Result := DoCommand('NEXT');
end;
function TNNTPSend.ListGroups: Boolean;
begin
FSock.SendString('LIST' + CRLF);
Result := (ReadResult div 100) = 2;
if Result then
Result := ReadData;
Result := DoCommandRead('LIST');
end;
function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean;
begin
FSock.SendString('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT' + CRLF);
Result := (ReadResult div 100) = 2;
if Result then
Result := ReadData;
Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT');
end;
function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean;
begin
FSock.SendString('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT' + CRLF);
Result := (ReadResult div 100) = 2;
if Result then
Result := ReadData;
Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT');
end;
function TNNTPSend.PostArticle: Boolean;
var
x: integer;
begin
FSock.SendString('POST' + CRLF);
x := (ReadResult div 100);
if x = 3 then
begin
SendData;
x := (ReadResult div 100);
end;
Result := x = 2;
Result := DoCommandWrite('POST');
end;
function TNNTPSend.SwitchToSlave: Boolean;
begin
FSock.SendString('SLAVE' + CRLF);
Result := (ReadResult div 100) = 2;
Result := DoCommand('SLAVE');
end;
function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean;
var
s: string;
begin
s := 'XOVER ' + xoStart;
if xoEnd <> xoStart then
s := s + '-' + xoEnd;
Result := DoCommandRead(s);
end;
{==============================================================================}

4
pingsend.pas
View File

@ -3,7 +3,7 @@
|==============================================================================|
| Content: PING sender |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2000,2001. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |

15
pop3send.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.001.000 |
| Project : Delphree - Synapse | 002.001.004 |
|==============================================================================|
| Content: POP3 client |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2001-2002. |
| Portions created by Lukas Gebauer are Copyright (c)2001-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -116,9 +116,6 @@ type
implementation
const
CRLF = #13#10;
constructor TPOP3Send.Create;
begin
inherited Create;
@ -126,7 +123,7 @@ begin
FPOP3cap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.CreateSocket;
FSock.ConvertLineEnd := True;
FSock.ConvertLineEnd := true;
FTimeout := 300000;
FTargetPort := cPop3Protocol;
FUsername := '';
@ -161,6 +158,9 @@ begin
s := FSock.RecvString(FTimeout);
if s = '.' then
Break;
if s <> '' then
if s[1] = '.' then
Delete(s, 1, 1);
FFullResult.Add(s);
until FSock.LastError <> 0;
FResultCode := Result;
@ -203,7 +203,6 @@ end;
function TPOP3Send.Capability: Boolean;
begin
FPOP3cap.Clear;
Result := False;
FSock.SendString('CAPA' + CRLF);
Result := ReadResult(True) = 1;
if Result then

7
slogsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.001.000 |
| Project : Delphree - Synapse | 001.001.001 |
|==============================================================================|
| Content: SysLog client |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2001. |
| Portions created by Lukas Gebauer are Copyright (c)2001-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -167,7 +167,6 @@ end;
function ToSysLog(const SyslogServer: string; Facil: Byte;
Sever: TSyslogSeverity; const Content: string): Boolean;
begin
Result := False;
with TSyslogSend.Create do
try
TargetHost :=SyslogServer;

21
smtpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 003.002.001 |
| Project : Delphree - Synapse | 003.002.004 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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-2002. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -126,9 +126,6 @@ function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
implementation
const
CRLF = #13#10;
constructor TSMTPSend.Create;
begin
inherited Create;
@ -136,7 +133,7 @@ begin
FESMTPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.CreateSocket;
FSock.ConvertLineEnd := True;
FSock.ConvertLineEnd := true;
FTimeout := 300000;
FTargetPort := cSmtpProtocol;
FUsername := '';
@ -547,11 +544,11 @@ begin
try
t.Assign(MailData);
t.Insert(0, '');
t.Insert(0, 'x-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
t.Insert(0, 'subject: ' + Subject);
t.Insert(0, 'date: ' + Rfc822DateTime(now));
t.Insert(0, 'to: ' + MailTo);
t.Insert(0, 'from: ' + MailFrom);
t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
t.Insert(0, 'Subject: ' + Subject);
t.Insert(0, 'Date: ' + Rfc822DateTime(now));
t.Insert(0, 'To: ' + MailTo);
t.Insert(0, 'From: ' + MailFrom);
Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password);
finally
t.Free;

111
snmpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.005.000 |
| Project : Delphree - Synapse | 002.006.000 |
|==============================================================================|
| Content: SNMP client |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2000,2001. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -102,6 +102,8 @@ type
procedure MIBAdd(const MIB, Value: string; ValueType: Integer);
procedure MIBDelete(Index: Integer);
function MIBGet(const MIB: string): string;
function MIBCount: integer;
function MIBByIndex(Index: Integer): TSNMPMib;
published
property Version: Integer read FVersion write FVersion;
property Community: string read FCommunity write FCommunity;
@ -262,19 +264,31 @@ end;
procedure TSNMPRec.MIBDelete(Index: Integer);
begin
if (Index >= 0) and (Index < FSNMPMibList.Count) then
if (Index >= 0) and (Index < MIBCount) then
begin
TSNMPMib(FSNMPMibList[Index]).Free;
FSNMPMibList.Delete(Index);
end;
end;
function TSNMPRec.MIBCount: integer;
begin
Result := FSNMPMibList.Count;
end;
function TSNMPRec.MIBByIndex(Index: Integer): TSNMPMib;
begin
Result := nil;
if (Index >= 0) and (Index < MIBCount) then
Result := TSNMPMib(FSNMPMibList[Index]);
end;
function TSNMPRec.MIBGet(const MIB: string): string;
var
i: Integer;
begin
Result := '';
for i := 0 to FSNMPMibList.Count - 1 do
for i := 0 to MIBCount - 1 do
begin
if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then
begin
@ -365,25 +379,32 @@ begin
end;
end;
function InternalGetNext(const SNMPSend: TSNMPSend; var OID: string;
const Community: string; var Value: string): Boolean;
begin
SNMPSend.Query.Clear;
SNMPSend.Query.ID := SNMPSend.Query.ID + 1;
SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUGetNextRequest;
SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
Result := SNMPSend.DoIt;
Value := '';
if Result then
if SNMPSend.Reply.SNMPMibList.Count > 0 then
begin
OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID;
Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value;
end;
end;
function SNMPGetNext(var OID: string; const Community, SNMPHost: string; var Value: string): Boolean;
var
SNMPSend: TSNMPSend;
begin
SNMPSend := TSNMPSend.Create;
try
SNMPSend.Query.Clear;
SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUGetNextRequest;
SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
SNMPSend.TargetHost := SNMPHost;
Result := SNMPSend.DoIt;
Value := '';
if Result then
if SNMPSend.Reply.SNMPMibList.Count > 0 then
begin
OID := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).OID;
Value := TSNMPMib(SNMPSend.Reply.SNMPMibList[0]).Value;
end;
Result := InternalGetNext(SNMPSend, OID, Community, Value);
finally
SNMPSend.Free;
end;
@ -394,33 +415,39 @@ var
OID: string;
s: string;
col,row: string;
lastcol: string;
x, n: integer;
x: integer;
SNMPSend: TSNMPSend;
RowList: TStringList;
begin
Value.Clear;
OID := BaseOID;
lastcol := '';
x := 0;
repeat
Result := SNMPGetNext(OID, Community, SNMPHost, s);
if Pos(BaseOID, OID) <> 1 then
break;
row := separateright(oid, baseoid + '.');
col := fetch(row, '.');
if col = lastcol then
inc(x)
else
x:=0;
lastcol := col;
if value.count <= x then
for n := value.Count - 1 to x do
value.add('');
if value[x] <> '' then
value[x] := value[x] + ',';
if IsBinaryString(s) then
s := StrToHex(s);
value[x] := value[x] + AnsiQuotedStr(s, '"');
until not result;
SNMPSend := TSNMPSend.Create;
RowList := TStringList.Create;
try
SNMPSend.TargetHost := SNMPHost;
OID := BaseOID;
repeat
Result := InternalGetNext(SNMPSend, OID, Community, s);
if Pos(BaseOID, OID) <> 1 then
break;
row := separateright(oid, baseoid + '.');
col := fetch(row, '.');
if IsBinaryString(s) then
s := StrToHex(s);
x := RowList.indexOf(Row);
if x < 0 then
begin
x := RowList.add(Row);
Value.Add('');
end;
if (Value[x] <> '') then
Value[x] := Value[x] + ',';
Value[x] := Value[x] + AnsiQuotedStr(s, '"');
until not result;
finally
SNMPSend.Free;
RowList.Free;
end;
end;
function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean;

4
snmptrap.pas
View File

@ -3,7 +3,7 @@
|==============================================================================|
| Content: SNMP traps |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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 Hernan Sanchez are Copyright (c)2000,2001. |
| Portions created by Hernan Sanchez are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |

14
sntpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.002.000 |
| Project : Delphree - Synapse | 002.002.001 |
|==============================================================================|
| Content: SNTP client |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2000,2001. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -154,12 +154,12 @@ var
begin
d := (dt - 2) * 86400;
d1 := frac(d);
d := trunc(d);
if d>maxilongint then
if d > maxilongint then
d := d - maxi - 1;
d := trunc(d);
d1 := Trunc(d1 * 10000) / 10000;
d1 := d1 * maxi;
if d1>maxilongint then
if d1 > maxilongint then
d1 := d1 - maxi - 1;
Nsec:=trunc(d);
Nfrac:=trunc(d1);
@ -232,7 +232,7 @@ begin
FillChar(q, SizeOf(q), 0);
q.mode := $1B;
t1 := GetUTTime;
EncodeTs(t1,q.org1,q.org2);
EncodeTs(t1, q.org1, q.org2);
FSock.SendBuffer(@q, SizeOf(q));
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then

34
synachar.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 004.000.001 |
| Project : Delphree - Synapse | 004.000.003 |
|==============================================================================|
| Content: Charset conversion support |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2000,2001. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -671,7 +671,7 @@ const
$0158, $0052,
$0160, $0053,
$0164, $0053,
$00DA, $0054,
$00DA, $0055,
$016E, $0055,
$00DD, $0059,
$017D, $005A
@ -806,8 +806,15 @@ begin
b[1] := 0;
b[2] := 0;
b[3] := 0;
if (Length(Value) + 1) < Index + mb then
b1 := 0;
b2 := 0;
b3 := 0;
b4 := 0;
if length(Value) < (Index + mb - 1) then
begin
Inc(index, mb);
Exit;
end;
s := '';
for n := 1 to mb do
begin
@ -937,9 +944,9 @@ end;
{==============================================================================}
function UTF7toUCS2(const Value: string): string;
var
n: Integer;
n, i: Integer;
c: Char;
s: string;
s, t: string;
begin
Result := '';
n := 1;
@ -968,7 +975,18 @@ begin
if s = '' then
s := WriteMulti(Ord('+'), 0, 0, 0, 2)
else
s := DecodeBase64(s);
begin
t := DecodeBase64(s);
if not odd(length(t)) then
s := t
else
begin //ill-formed sequence
t := s;
s := WriteMulti(Ord('+'), 0, 0, 0, 2);
for i := 1 to length(t) do
s := s + WriteMulti(Ord(t[i]), 0, 0, 0, 2);
end;
end;
Result := Result + s;
end;
end;

28
synacode.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.005.005 |
| Project : Delphree - Synapse | 001.006.001 |
|==============================================================================|
| Content: Coding and decoding support |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2000-2002. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -113,6 +113,7 @@ function Encode3to4(const Value, Table: string): string;
function DecodeBase64(const Value: string): string;
function EncodeBase64(const Value: string): string;
function DecodeUU(const Value: string): string;
function EncodeUU(const Value: string): string;
function DecodeXX(const Value: string): string;
function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
function Crc32(const Value: string): Integer;
@ -506,7 +507,11 @@ begin
Exit; //ignore Table yet (set custom UUT)
//begin decoding
x := Pos(Value[1], uut) - 1;
x := Round((x / 3) * 4);
case (x mod 3) of
0: x :=(x div 3)* 4;
1: x :=((x div 3) * 4) + 2;
2: x :=((x div 3) * 4) + 3;
end;
//x - lenght UU line
s := Copy(Value, 2, x);
if s = '' then
@ -516,6 +521,15 @@ end;
{==============================================================================}
function EncodeUU(const Value: string): string;
begin
Result := '';
if Length(Value) < Length(TableUU) then
Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU);
end;
{==============================================================================}
function DecodeXX(const Value: string): string;
var
s: string;
@ -531,7 +545,11 @@ begin
Exit;
//begin decoding
x := Pos(Value[1], TableXX) - 1;
x := Round((x / 3) * 4);
case (x mod 3) of
0: x :=(x div 3)* 4;
1: x :=((x div 3) * 4) + 2;
2: x :=((x div 3) * 4) + 3;
end;
//x - lenght XX line
s := Copy(Value, 2, x);
if s = '' then

306
synamisc.pas Normal file
View File

@ -0,0 +1,306 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.004 |
|==============================================================================|
| Content: misc. procedures and functions |
|==============================================================================|
| 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) 2002-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$Q-}
unit SynaMisc;
interface
uses
SynaUtil, blcksock, SysUtils, Classes,
{$IFDEF LINUX}
Libc;
{$ELSE}
Windows, Wininet;
{$ENDIF}
Type
TProxySetting = record
Host: string;
Port: string;
Bypass: string;
end;
procedure WakeOnLan(MAC, IP: string);
function GetDNS: string;
function GetIEProxy(protocol: string): TProxySetting;
implementation
{==============================================================================}
procedure WakeOnLan(MAC, IP: string);
var
sock: TUDPBlockSocket;
HexMac: string;
data: string;
n: integer;
b: Byte;
begin
if MAC <> '' then
begin
MAC := ReplaceString(MAC, '-', '');
MAC := ReplaceString(MAC, ':', '');
if Length(MAC) < 12 then
Exit;
HexMac := '';
for n := 0 to 5 do
begin
b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0);
HexMac := HexMac + char(b);
end;
if IP = '' then
IP := cBroadcast;
sock := TUDPBlockSocket.Create;
try
sock.CreateSocket;
sock.EnableBroadcast(true);
sock.Connect(IP, '9');
data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF;
for n := 1 to 16 do
data := data + HexMac;
sock.SendString(data);
finally
sock.Free;
end;
end;
end;
{==============================================================================}
{$IFNDEF LINUX}
function GetDNSbyIpHlp: string;
type
PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING;
TIP_ADDRESS_STRING = array[0..15] of char;
PTIP_ADDR_STRING = ^TIP_ADDR_STRING;
TIP_ADDR_STRING = packed record
Next: PTIP_ADDR_STRING;
IpAddress: TIP_ADDRESS_STRING;
IpMask: TIP_ADDRESS_STRING;
Context: DWORD;
end;
PTFixedInfo = ^TFixedInfo;
TFixedInfo = packed record
HostName: array[1..128 + 4] of char;
DomainName: array[1..128 + 4] of char;
CurrentDNSServer: PTIP_ADDR_STRING;
DNSServerList: TIP_ADDR_STRING;
NodeType: UINT;
ScopeID: array[1..256 + 4] of char;
EnableRouting: UINT;
EnableProxy: UINT;
EnableDNS: UINT;
end;
const
IpHlpDLL = 'IPHLPAPI.DLL';
var
IpHlpModule: THandle;
FixedInfo: PTFixedInfo;
InfoSize: Longint;
PDnsServer: PTIP_ADDR_STRING;
err: integer;
GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall;
begin
InfoSize := 0;
Result := '...';
IpHlpModule := LoadLibrary(IpHlpDLL);
if IpHlpModule = 0 then
exit;
try
GetNetworkParams := GetProcAddress(IpHlpModule,'GetNetworkParams');
if @GetNetworkParams = nil then
Exit;
err := GetNetworkParams(Nil, @InfoSize);
if err <> ERROR_BUFFER_OVERFLOW then
Exit;
Result := '';
GetMem (FixedInfo, InfoSize);
try
err := GetNetworkParams(FixedInfo, @InfoSize);
if err <> ERROR_SUCCESS then
exit;
with FixedInfo^ do
begin
Result := DnsServerList.IpAddress;
PDnsServer := DnsServerList.Next;
while PDnsServer <> Nil do
begin
if Result <> '' then
Result := Result + ',';
Result := Result + PDnsServer^.IPAddress;
PDnsServer := PDnsServer.Next;
end;
end;
finally
FreeMem(FixedInfo);
end;
finally
FreeLibrary(IpHlpModule);
end;
end;
function ReadReg(SubKey, Vn: PChar): string;
var
OpenKey: HKEY;
DataType, DataSize: integer;
Temp: array [0..2048] of char;
begin
Result := '';
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE,
KEY_READ, OpenKey) = ERROR_SUCCESS then
begin
DataType := REG_SZ;
DataSize := SizeOf(Temp);
if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then
Result := string(Temp);
RegCloseKey(OpenKey);
end;
end ;
{$ENDIF}
function GetDNS: string;
{$IFDEF LINUX}
var
l: TStringList;
n: integer;
begin
Result := '';
l := TStringList.Create;
try
l.LoadFromFile('/etc/resolv.conf');
for n := 0 to l.Count - 1 do
if Pos('NAMESERVER', uppercase(l[n])) = 1 then
begin
if Result <> '' then
Result := Result + ',';
Result := Result + SeparateRight(l[n], ' ');
end;
finally
l.Free;
end;
end;
{$ELSE}
const
NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary';
NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters';
W9xfix = 'System\CurrentControlSet\Services\MSTCP';
begin
Result := GetDNSbyIpHlp;
if Result = '...' then
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
Result := ReadReg(NTdyn, 'NameServer');
if result = '' then
Result := ReadReg(NTfix, 'NameServer');
end
else
Result := ReadReg(W9xfix, 'NameServer');
end;
{$ENDIF}
{==============================================================================}
function GetIEProxy(protocol: string): TProxySetting;
{$IFDEF LINUX}
begin
Result.Host := '';
Result.Port := '';
Result.Bypass := '';
end;
{$ELSE}
var
ProxyInfo: PInternetProxyInfo;
Err: Boolean;
Len: DWORD;
Proxy: string;
DefProxy: string;
ProxyList: TStringList;
n: integer;
begin
Result.Host := '';
Result.Port := '';
Result.Bypass := '';
if protocol = '' then
protocol := 'http';
Len := 4096;
GetMem(ProxyInfo, Len);
ProxyList := TStringList.Create;
try
Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
if Err then
if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
begin
ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
Proxy := '';
DefProxy := '';
for n := 0 to ProxyList.Count -1 do
begin
if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then
begin
Proxy := SeparateRight(ProxyList[n], '=');
break;
end;
if Pos('=', ProxyList[n]) < 1 then
DefProxy := ProxyList[n];
end;
if Proxy = '' then
Proxy := DefProxy;
if Proxy <> '' then
begin
Result.Host := SeparateLeft(Proxy, ':');
Result.Port := SeparateRight(Proxy, ':');
end;
Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
end;
finally
ProxyList.Free;
FreeMem(ProxyInfo);
end;
end;
{$ENDIF}
{==============================================================================}
end.

16
synassl.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.006.000 |
| Project : Delphree - Synapse | 001.007.000 |
|==============================================================================|
| Content: SSL support |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2002. |
| Portions created by Lukas Gebauer are Copyright (c)2002-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -63,8 +63,8 @@ const
DLLSSLName = 'libssl.so';
DLLUtilName = 'libcrypto.so';
{$ELSE}
DLLSSLName = 'libssl32.dll';
DLLSSLName2 = 'ssleay32.dll';
DLLSSLName = 'ssleay32.dll';
DLLSSLName2 = 'libssl32.dll';
DLLUtilName = 'libeay32.dll';
{$ENDIF}
@ -94,6 +94,7 @@ const
var
SSLLibHandle: Integer = 0;
SSLUtilHandle: Integer = 0;
SSLLibName: string = '';
// libssl.dll
SslGetError : function(s: PSSL; ret_code: Integer):Integer cdecl = nil;
@ -155,11 +156,16 @@ begin
begin
{$IFDEF LINUX}
SSLLibHandle := HMODULE(dlopen(DLLSSLName, RTLD_GLOBAL));
SSLLibName := DLLSSLName;
SSLUtilHandle := HMODULE(dlopen(DLLUtilName, RTLD_GLOBAL));
{$ELSE}
SSLLibHandle := LoadLibrary(PChar(DLLSSLName));
SSLLibName := DLLSSLName;
if (SSLLibHandle = 0) then
begin
SSLLibHandle := LoadLibrary(PChar(DLLSSLName2));
SSLLibName := DLLSSLName2;
end;
SSLUtilHandle := LoadLibrary(PChar(DLLUtilName));
{$ENDIF}
if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then

33
synautil.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 003.002.001 |
| Project : Delphree - Synapse | 003.003.000 |
|==============================================================================|
| Content: support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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-2002. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. |
| Portions created by Hernan Sanchez are Copyright (c) 2000. |
| All Rights Reserved. |
|==============================================================================|
@ -90,7 +90,7 @@ function IntToBin(Value: Integer; Digits: Byte): string;
function BinToInt(const Value: string): Integer;
function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
Para: string): string;
function StringReplace(Value, Search, Replace: string): string;
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;
@ -98,6 +98,7 @@ 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;
implementation
@ -308,7 +309,7 @@ begin
x := rpos(':', Value);
if (x > 0) and ((Length(Value) - x) > 2) then
Value := Copy(Value, 1, x + 2);
Value := StringReplace(Value, ':', TimeSeparator);
Value := ReplaceString(Value, ':', TimeSeparator);
Result := 0;
try
Result := StrToTime(Value);
@ -370,9 +371,9 @@ begin
month := 0;
year := 0;
zone := 0;
Value := StringReplace(Value, ' -', ' #');
Value := StringReplace(Value, '-', ' ');
Value := StringReplace(Value, ' #', ' -');
Value := ReplaceString(Value, ' -', ' #');
Value := ReplaceString(Value, '-', ' ');
Value := ReplaceString(Value, ' #', ' -');
while Value <> '' do
begin
s := Fetch(Value, ' ');
@ -419,6 +420,8 @@ begin
if y > 0 then
month := y;
end;
if year = 0 then
year := 1980;
if (month < 1) or (month > 12) then
month := 1;
if (day < 1) or (day > 31) then
@ -826,7 +829,7 @@ end;
function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
Para: string): string;
var
x: Integer;
x, y: Integer;
sURL: string;
s: string;
s1, s2: string;
@ -850,7 +853,8 @@ begin
if UpperCase(Prot) = 'FTP' then
Port := '21';
x := Pos('@', sURL);
if (x > 0) and (x < Pos('/', sURL)) then
y := Pos('/', sURL);
if (x > 0) and ((x < y) or (y < 1))then
begin
s := SeparateLeft(sURL, '@');
sURL := SeparateRight(sURL, '@');
@ -897,7 +901,7 @@ end;
{==============================================================================}
function StringReplace(Value, Search, Replace: string): string;
function ReplaceString(Value, Search, Replace: string): string;
var
x, l, ls, lr: Integer;
begin
@ -1061,4 +1065,11 @@ end;
{==============================================================================}
function IncPoint(const p: pointer; Value: integer): pointer;
begin
Result := pointer(integer(p) + Value);
end;
{==============================================================================}
end.

17
synsock.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.001.000 |
| Project : Delphree - Synapse | 002.002.000 |
|==============================================================================|
| Content: Socket Independent Platform Layer |
|==============================================================================|
| Copyright (c)1999-2002, Lukas Gebauer |
| Copyright (c)1999-2003, 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)2001. |
| Portions created by Lukas Gebauer are Copyright (c)2001-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -53,6 +53,7 @@ unit synsock;
interface
uses
SyncObjs,
{$IFDEF LINUX}
Libc, KernelIoctl;
{$ELSE}
@ -273,14 +274,14 @@ function LSSelect(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint; stdcall;
{$ENDIF}
var
SynSockCS: TCriticalSection;
implementation
{$IFNDEF LINUX}
{$IFNDEF STATICWINSOCK}
uses syncobjs;
var
SynSockCS: TCriticalSection;
SynSockCount: Integer = 0;
{$ENDIF}
{$ENDIF}
@ -622,8 +623,6 @@ begin
Result := True;
end;
{$IFNDEF LINUX}
{$IFNDEF STATICWINSOCK}
initialization
begin
SynSockCS:= TCriticalSection.Create;
@ -633,7 +632,5 @@ finalization
begin
SynSockCS.Free;
end;
{$ENDIF}
{$ENDIF}
end.

306
tlntsend.pas Normal file
View File

@ -0,0 +1,306 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.002 |
|==============================================================================|
| Content: TELNET client |
|==============================================================================|
| 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)2002-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$WEAKPACKAGEUNIT ON}
//RFC-854
unit TlntSend;
interface
uses
SysUtils, Classes,
blcksock, SynaUtil;
const
cTelnetProtocol = 'telnet';
TLNT_EOR = #239;
TLNT_SE = #240;
TLNT_NOP = #241;
TLNT_DATA_MARK = #242;
TLNT_BREAK = #243;
TLNT_IP = #244;
TLNT_AO = #245;
TLNT_AYT = #246;
TLNT_EC = #247;
TLNT_EL = #248;
TLNT_GA = #249;
TLNT_SB = #250;
TLNT_WILL = #251;
TLNT_WONT = #252;
TLNT_DO = #253;
TLNT_DONT = #254;
TLNT_IAC = #255;
type
TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
TTelnetSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FBuffer: string;
FState: TTelnetState;
FSessionLog: string;
FSubNeg: string;
FSubType: char;
function Connect: Boolean;
function Negotiate(const Buf: string): string;
procedure FilterHook(Sender: TObject; var Value: string);
public
constructor Create;
destructor Destroy; override;
function Login: Boolean;
procedure Logout;
procedure Send(const Value: string);
function WaitFor(const Value: string): Boolean;
function RecvTerminated(const Terminator: string): string;
function RecvString: string;
published
property Sock: TTCPBlockSocket read FSock;
property SessionLog: string read FSessionLog write FSessionLog;
end;
implementation
constructor TTelnetSend.Create;
begin
inherited Create;
FSock := TTCPBlockSocket.Create;
FSock.OnReadFilter := FilterHook;
FTimeout := 300000;
FTargetPort := cTelnetProtocol;
FSubNeg := '';
FSubType := #0;
end;
destructor TTelnetSend.Destroy;
begin
FSock.Free;
inherited Destroy;
end;
function TTelnetSend.Connect: Boolean;
begin
// Do not call this function! It is calling by LOGIN method!
FBuffer := '';
FSessionLog := '';
FState := tsDATA;
FSock.CloseSocket;
FSock.LineBuffer := '';
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0;
end;
function TTelnetSend.RecvTerminated(const Terminator: string): string;
begin
Result := FSock.RecvTerminated(FTimeout, Terminator);
end;
function TTelnetSend.RecvString: string;
begin
Result := FSock.RecvTerminated(FTimeout, CRLF);
end;
function TTelnetSend.WaitFor(const Value: string): Boolean;
begin
Result := FSock.RecvTerminated(FTimeout, Value) <> '';
end;
procedure TTelnetSend.FilterHook(Sender: TObject; var Value: string);
begin
Value := Negotiate(Value);
FSessionLog := FSessionLog + Value;
end;
function TTelnetSend.Negotiate(const Buf: string): string;
var
n: integer;
c: char;
Reply: string;
SubReply: string;
begin
Result := '';
for n := 1 to Length(Buf) do
begin
c := Buf[n];
Reply := '';
case FState of
tsData:
if c = TLNT_IAC then
FState := tsIAC
else
Result := Result + c;
tsIAC:
case c of
TLNT_IAC:
begin
FState := tsData;
Result := Result + TLNT_IAC;
end;
TLNT_WILL:
FState := tsIAC_WILL;
TLNT_WONT:
FState := tsIAC_WONT;
TLNT_DONT:
FState := tsIAC_DONT;
TLNT_DO:
FState := tsIAC_DO;
TLNT_EOR:
FState := tsDATA;
TLNT_SB:
begin
FState := tsIAC_SB;
FSubType := #0;
FSubNeg := '';
end;
else
FState := tsData;
end;
tsIAC_WILL:
begin
case c of
#3: //suppress GA
Reply := TLNT_DO;
else
Reply := TLNT_DONT;
end;
FState := tsData;
end;
tsIAC_WONT:
begin
Reply := TLNT_DONT;
FState := tsData;
end;
tsIAC_DO:
begin
case c of
#24: //termtype
Reply := TLNT_WILL;
else
Reply := TLNT_WONT;
end;
FState := tsData;
end;
tsIAC_DONT:
begin
Reply := TLNT_WONT;
FState := tsData;
end;
tsIAC_SB:
begin
FSubType := c;
FState := tsIAC_SBDATA;
end;
tsIAC_SBDATA:
begin
if c = TLNT_IAC then
FState := tsSBDATA_IAC
else
FSubNeg := FSubNeg + c;
end;
tsSBDATA_IAC:
case c of
TLNT_IAC:
begin
FState := tsIAC_SBDATA;
FSubNeg := FSubNeg + c;
end;
TLNT_SE:
begin
SubReply := '';
case FSubType of
#24: //termtype
begin
if (FSubNeg <> '') and (FSubNeg[1] = #1) then
SubReply := #0 + 'SYNAPSE';
end;
end;
Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE);
FState := tsDATA;
end;
else
FState := tsDATA;
end;
else
FState := tsData;
end;
if Reply <> '' then
Sock.SendString(TLNT_IAC + Reply + c);
end;
end;
procedure TTelnetSend.Send(const Value: string);
begin
Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC));
end;
function TTelnetSend.Login: Boolean;
begin
Result := False;
if not Connect then
Exit;
Result := True;
end;
procedure TTelnetSend.Logout;
begin
FSock.CloseSocket;
end;
end.