pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 23

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@49 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 07:05:26 +00:00
parent 3afdb0701b
commit df848de345
20 changed files with 6026 additions and 5916 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

403
asn1util.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.003.002 |
| Project : Delphree - Synapse | 001.003.003 |
|==============================================================================|
| Content: support for ASN.1 coding and decoding |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
@ -26,6 +26,7 @@
|==============================================================================}
{$Q-}
{$WEAKPACKAGEUNIT ON}
unit ASN1Util;
@ -46,204 +47,202 @@ const
ASN1_TIMETICKS = $43;
ASN1_OPAQUE = $44;
function ASNEncOIDitem(Value: integer): string;
function ASNDecOIDitem(var Start: integer; Buffer: string): integer;
function ASNEncLen(Len: integer): string;
function ASNDecLen(var Start: integer; Buffer: string): integer;
function ASNEncInt(Value: integer): string;
function ASNEncUInt(Value: integer): string;
function ASNObject(Data: string; ASNType: integer): string;
function ASNItem(var Start: integer; Buffer: string; var ValueType:integer): string;
Function MibToId(mib:string):string;
Function IdToMib(id:string):string;
Function IntMibToStr(int:string):string;
function ASNEncOIDItem(Value: Integer): string;
function ASNDecOIDItem(var Start: Integer; const Buffer: string): Integer;
function ASNEncLen(Len: Integer): string;
function ASNDecLen(var Start: Integer; const Buffer: string): Integer;
function ASNEncInt(Value: Integer): string;
function ASNEncUInt(Value: Integer): string;
function ASNObject(const Data: string; ASNType: Integer): string;
function ASNItem(var Start: Integer; const Buffer: string;
var ValueType: Integer): string;
function MibToId(Mib: string): string;
function IdToMib(const Id: string): string;
function IntMibToStr(const Value: string): string;
function IPToID(Host: string): string;
implementation
{==============================================================================}
{ASNEncOIDitem}
function ASNEncOIDitem(Value: integer): string;
function ASNEncOIDItem(Value: Integer): string;
var
x,xm:integer;
b:boolean;
x, xm: Integer;
b: Boolean;
begin
x:=value;
b:=false;
result:='';
x := Value;
b := False;
Result := '';
repeat
xm:=x mod 128;
x:=x div 128;
xm := x mod 128;
x := x div 128;
if b then
xm:=xm or $80;
if x>0
then b:=true;
result:=char(xm)+result;
until x=0;
xm := xm or $80;
if x > 0 then
b := True;
Result := Char(xm) + Result;
until x = 0;
end;
{==============================================================================}
{ASNDecOIDitem}
function ASNDecOIDitem(var Start: integer; Buffer: string): integer;
function ASNDecOIDItem(var Start: Integer; const Buffer: string): Integer;
var
x:integer;
b:boolean;
x: Integer;
b: Boolean;
begin
result:=0;
Result := 0;
repeat
result:=result*128;
Result := Result * 128;
x := Ord(Buffer[Start]);
inc(start);
b:=x>$7f;
x:=x and $7f;
result:=result+x;
if not b
then break;
until false
Inc(Start);
b := x > $7F;
x := x and $7F;
Result := Result + x;
until not b;
end;
{==============================================================================}
{ASNEncLen}
function ASNEncLen(Len: integer): string;
function ASNEncLen(Len: Integer): string;
var
x, y: integer;
x, y: Integer;
begin
if (len<$80)
then result:=char(len)
else
begin
x:=len;
result:='';
repeat
y:=x mod 256;
x:=x div 256;
result:=char(y)+result;
until x=0;
y:=length(result);
y:=y or $80;
result:=char(y)+result;
end;
if Len < $80 then
Result := Char(Len)
else
begin
x := Len;
Result := '';
repeat
y := x mod 256;
x := x div 256;
Result := Char(y) + Result;
until x = 0;
y := Length(Result);
y := y or $80;
Result := Char(y) + Result;
end;
end;
{==============================================================================}
{ASNDecLen}
function ASNDecLen(var Start: integer; Buffer: string): integer;
function ASNDecLen(var Start: Integer; const Buffer: string): Integer;
var
x,n: integer;
x, n: Integer;
begin
x:=Ord(Buffer[Start]);
x := Ord(Buffer[Start]);
Inc(Start);
if (x<$80)
then Result:=x
else
begin
result:=0;
x:=x and $7f;
for n:=1 to x do
begin
result:=result*256;
x:=Ord(Buffer[Start]);
Inc(Start);
result:=result+x;
end;
end;
if x < $80 then
Result := x
else
begin
Result := 0;
x := x and $7F;
for n := 1 to x do
begin
Result := Result * 256;
x := Ord(Buffer[Start]);
Inc(Start);
Result := Result + x;
end;
end;
end;
{==============================================================================}
{ASNEncInt}
function ASNEncInt(Value: integer): string;
function ASNEncInt(Value: Integer): string;
var
x,y:cardinal;
neg:boolean;
x, y: Cardinal;
neg: Boolean;
begin
neg:=value<0;
x:=abs(Value);
neg := Value < 0;
x := Abs(Value);
if neg then
x:=not (x-1);
result:='';
x := not (x - 1);
Result := '';
repeat
y:=x mod 256;
x:=x div 256;
result:=char(y)+result;
until x=0;
if (not neg) and (result[1]>#$7F)
then result:=#0+result;
y := x mod 256;
x := x div 256;
Result := Char(y) + Result;
until x = 0;
if (not neg) and (Result[1] > #$7F) then
Result := #0 + Result;
end;
{==============================================================================}
{ASNEncUInt}
function ASNEncUInt(Value: integer): string;
function ASNEncUInt(Value: Integer): string;
var
x,y:integer;
neg:boolean;
x, y: Integer;
neg: Boolean;
begin
neg:=value<0;
x:=Value;
if neg
then x:=x and $7FFFFFFF;
result:='';
neg := Value < 0;
x := Value;
if neg then
x := x and $7FFFFFFF;
Result := '';
repeat
y:=x mod 256;
x:=x div 256;
result:=char(y)+result;
until x=0;
if neg
then result[1]:=char(ord(result[1]) or $80);
y := x mod 256;
x := x div 256;
Result := Char(y) + Result;
until x = 0;
if neg then
Result[1] := Char(Ord(Result[1]) or $80);
end;
{==============================================================================}
{ASNObject}
function ASNObject(Data: string; ASNType: integer): string;
function ASNObject(const Data: string; ASNType: Integer): string;
begin
Result := Char(ASNType) + ASNEncLen(Length(Data)) + Data;
end;
{==============================================================================}
{ASNItem}
function ASNItem(var Start: integer; Buffer: string; var ValueType:integer): string;
function ASNItem(var Start: Integer; const Buffer: string;
var ValueType: Integer): string;
var
ASNType: integer;
ASNSize: integer;
y,n: integer;
ASNType: Integer;
ASNSize: Integer;
y, n: Integer;
x: byte;
s: string;
c: char;
neg: boolean;
l:integer;
neg: Boolean;
l: Integer;
begin
Result:='';
ValueType:=ASN1_NULL;
l:=length(buffer);
if l<(start+1)
then exit;
Result := '';
ValueType := ASN1_NULL;
l := Length(Buffer);
if l < (Start + 1) then
Exit;
ASNType := Ord(Buffer[Start]);
Valuetype:=ASNType;
Inc(start);
ValueType := ASNType;
Inc(Start);
ASNSize := ASNDecLen(Start, Buffer);
if (Start+ASNSize-1)>l
then exit;
if ((ASNType and $20) > 0) then
begin
Result := '$' + IntToHex(ASNType, 2);
end
if (Start + ASNSize - 1) > l then
Exit;
if (ASNType and $20) > 0 then
Result := '$' + IntToHex(ASNType, 2)
else
case ASNType of
ASN1_INT:
begin
y := 0;
neg:=false;
neg := False;
for n := 1 to ASNSize do
begin
x:=Ord(Buffer[Start]);
if (n=1) and (x>$7F)
then neg:=true;
if neg
then x:=not x;
x := Ord(Buffer[Start]);
if (n = 1) and (x > $7F) then
neg := True;
if neg then
x := not x;
y := y * 256 + x;
Inc(Start);
end;
if neg
then y:=-(y+1);
if neg then
y := -(y + 1);
Result := IntToStr(y);
end;
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
@ -299,101 +298,95 @@ begin
end;
{==============================================================================}
{MibToId}
function MibToId(mib:string):string;
var
x:integer;
Function walkInt(var s:string):integer;
function MibToId(Mib: string): string;
var
x: Integer;
function WalkInt(var s: string): Integer;
var
x:integer;
t:string;
x: Integer;
t: string;
begin
x:=pos('.',s);
if x<1 then
begin
t:=s;
s:='';
end
else
begin
t:=copy(s,1,x-1);
s:=copy(s,x+1,length(s)-x);
end;
result:=StrToIntDef(t,0);
x := Pos('.', s);
if x < 1 then
begin
t := s;
s := '';
end
else
begin
t := Copy(s, 1, x - 1);
s := Copy(s, x + 1, Length(s) - x);
end;
Result := StrToIntDef(t, 0);
end;
begin
result:='';
x:=walkint(mib);
x:=x*40+walkint(mib);
result:=ASNEncOIDItem(x);
while mib<>'' do
begin
x:=walkint(mib);
result:=result+ASNEncOIDItem(x);
end;
Result := '';
x := WalkInt(Mib);
x := x * 40 + WalkInt(Mib);
Result := ASNEncOIDItem(x);
while Mib <> '' do
begin
x := WalkInt(Mib);
Result := Result + ASNEncOIDItem(x);
end;
end;
{==============================================================================}
{IdToMib}
Function IdToMib(id:string):string;
function IdToMib(const Id: string): string;
var
x,y,n:integer;
x, y, n: Integer;
begin
result:='';
n:=1;
while length(id)+1>n do
Result := '';
n := 1;
while Length(Id) + 1 > n do
begin
x := ASNDecOIDItem(n, Id);
if (n - 1) = 1 then
begin
x:=ASNDecOIDItem(n,id);
if (n-1)=1 then
begin
y:=x div 40;
x:=x mod 40;
result:=IntTostr(y);
end;
result:=result+'.'+IntToStr(x);
y := x div 40;
x := x mod 40;
Result := IntToStr(y);
end;
Result := Result + '.' + IntToStr(x);
end;
end;
{==============================================================================}
{IntMibToStr}
Function IntMibToStr(int:string):string;
Var
n,y:integer;
function IntMibToStr(const Value: string): string;
var
n, y: Integer;
begin
y:=0;
for n:=1 to length(int)-1 do
y:=y*256+ord(int[n]);
result:=IntToStr(y);
y := 0;
for n := 1 to Length(Value) - 1 do
y := y * 256 + Ord(Value[n]);
Result := IntToStr(y);
end;
{==============================================================================}
{IPToID} //Hernan Sanchez
//Hernan Sanchez
function IPToID(Host: string): string;
var
s, t: string;
i, x: integer;
i, x: Integer;
begin
Result := '';
for x:= 1 to 3 do
begin
t := '';
s := StrScan(PChar(Host), '.');
t := Copy(Host, 1, (Length(Host) - Length(s)));
Delete(Host, 1, (Length(Host) - Length(s) + 1));
i := StrTointDef(t, 0);
Result := Result + Chr(i);
end;
i := StrTointDef(Host, 0);
for x := 1 to 3 do
begin
t := '';
s := StrScan(PChar(Host), '.');
t := Copy(Host, 1, (Length(Host) - Length(s)));
Delete(Host, 1, (Length(Host) - Length(s) + 1));
i := StrToIntDef(t, 0);
Result := Result + Chr(i);
end;
i := StrToIntDef(Host, 0);
Result := Result + Chr(i);
end;
{==============================================================================}
begin
exit;
asm
db 'Synapse ASN.1 library by Lukas Gebauer',0
end;
end.

134
blcksck2.pas
View File

@ -1,134 +0,0 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.000.000 |
|==============================================================================|
| Content: Library base for RAW sockets |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
| the specific language governing rights and limitations under the License. |
|==============================================================================|
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Remember, this unit work only on Linux or Windows with Winsock2!
(on Win98 and WinNT 4.0 or higher)
If you must use this unit on Win95, download Wínsock2 from Microsoft
and distribute it with your application!
In spite of I use Winsock level version 1.1, RAW sockets work in this level only
if Winsock2 is installed on your computer!!!
On WinNT standardly RAW sockets work if program is running under user with
administrators provilegies. To use RAW sockets under another users, you must
create the following registry variable and set its value to DWORD 1:
HKLM\System\CurrentControlSet\Services\Afd\Parameters\DisableRawSecurity
After you change the registry, you need to restart your computer!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
}
unit blcksck2;
interface
uses
synsock, SysUtils, blcksock,
{$IFDEF LINUX}
libc, kernelioctl;
{$ELSE}
winsock, windows;
{$ENDIF}
type
{TICMPBlockSocket}
TICMPBlockSocket = class (TBlockSocket)
public
procedure CreateSocket; override;
end;
{TRAWBlockSocket}
TRAWBlockSocket = class (TBlockSocket)
public
procedure CreateSocket; override;
end;
TIPHeader = Record
VerLen : Byte;
TOS : Byte;
TotalLen : Word;
Identifer : Word;
FragOffsets : Word;
TTL : Byte;
Protocol : Byte;
CheckSum : Word;
SourceIp : Dword;
DestIp : Dword;
Options : Dword;
End;
function SetTimeout(Sock:TSocket;Timeout:integer):Boolean;
implementation
{======================================================================}
{TICMPBlockSocket.CreateSocket}
Procedure TICMPBlockSocket.CreateSocket;
begin
FSocket:=synsock.socket(PF_INET,integer(SOCK_RAW),IPPROTO_ICMP);
FProtocol:=IPPROTO_ICMP;
inherited createSocket;
end;
{======================================================================}
{TRAWBlockSocket.CreateSocket}
Procedure TRAWBlockSocket.CreateSocket;
begin
FSocket:=synsock.socket(PF_INET,integer(SOCK_RAW),IPPROTO_RAW);
FProtocol:=IPPROTO_RAW;
inherited createSocket;
end;
{======================================================================}
function SetTimeout(Sock:TSocket;Timeout:integer):Boolean;
var
len,Value,res:integer;
r1,r2:Boolean;
begin
Result:=False;
r1:=False;
r2:=False;
Value:=Timeout;
len:=SizeOf(Value);
Res:=synsock.setsockopt(sock,SOL_SOCKET,SO_RCVTIMEO,@Value,len);
r1:=res<>SOCKET_ERROR;
Res:=synsock.setsockopt(sock,SOL_SOCKET,SO_SNDTIMEO,@Value,len);
r2:=res<>SOCKET_ERROR;
Result:=r1 and r2;
end;
end.

1278
blcksock.pas
View File

File diff suppressed because it is too large Load Diff

563
dnssend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.001.001 |
| Project : Delphree - Synapse | 001.001.002 |
|==============================================================================|
| Content: DNS client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000. |
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -23,351 +23,342 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
// RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
{$Q-}
{$WEAKPACKAGEUNIT ON}
unit DNSsend;
interface
uses
Blcksock, sysutils, classes, SynaUtil;
SysUtils, Classes,
blcksock, SynaUtil;
const
Qtype_A =1;
Qtype_NS =2;
Qtype_MD =3;
Qtype_MF =4;
Qtype_CNAME =5;
Qtype_SOA =6;
Qtype_MB =7;
Qtype_MG =8;
Qtype_MR =9;
Qtype_NULL =10;
Qtype_WKS =11; //
Qtype_PTR =12;
Qtype_HINFO =13;
Qtype_MINFO =14;
Qtype_MX =15;
Qtype_TXT =16;
cDnsProtocol = 'Domain';
Qtype_RP =17;
Qtype_AFSDB =18;
Qtype_X25 =19;
Qtype_ISDN =20;
Qtype_RT =21;
Qtype_NSAP =22;
Qtype_NSAPPTR=23;
Qtype_SIG =24; //RFC-2065
Qtype_KEY =25; //RFC-2065
Qtype_PX =26;
Qtype_GPOS =27;
Qtype_AAAA =28; //IP6 Address [Susan Thomson]
Qtype_LOC =29; //RFC-1876
Qtype_NXT =30; //RFC-2065
QTYPE_A = 1;
QTYPE_NS = 2;
QTYPE_MD = 3;
QTYPE_MF = 4;
QTYPE_CNAME = 5;
QTYPE_SOA = 6;
QTYPE_MB = 7;
QTYPE_MG = 8;
QTYPE_MR = 9;
QTYPE_NULL = 10;
QTYPE_WKS = 11; //
QTYPE_PTR = 12;
QTYPE_HINFO = 13;
QTYPE_MINFO = 14;
QTYPE_MX = 15;
QTYPE_TXT = 16;
Qtype_SRV =33; //RFC-2052
Qtype_NAPTR =35; //RFC-2168
Qtype_KX =36;
QTYPE_RP = 17;
QTYPE_AFSDB = 18;
QTYPE_X25 = 19;
QTYPE_ISDN = 20;
QTYPE_RT = 21;
QTYPE_NSAP = 22;
QTYPE_NSAPPTR = 23;
QTYPE_SIG = 24; // RFC-2065
QTYPE_KEY = 25; // RFC-2065
QTYPE_PX = 26;
QTYPE_GPOS = 27;
QTYPE_AAAA = 28; // IP6 Address [Susan Thomson]
QTYPE_LOC = 29; // RFC-1876
QTYPE_NXT = 30; // RFC-2065
Qtype_AXFR =252; //
Qtype_MAILB =253; //
Qtype_MAILA =254; //
Qtype_ALL =255; //
QTYPE_SRV = 33; // RFC-2052
QTYPE_NAPTR = 35; // RFC-2168
QTYPE_KX = 36;
QTYPE_AXFR = 252; //
QTYPE_MAILB = 253; //
QTYPE_MAILA = 254; //
QTYPE_ALL = 255; //
type
TDNSSend = class
TDNSSend = class(TObject)
private
Buffer:string;
Sock:TUDPBlockSocket;
function CompressName(Value:string):string;
function CodeHeader:string;
function CodeQuery(Name:string; Qtype:integer):string;
function DecodeLabels(var From:integer):string;
function DecodeResource(var i:integer; Name:string; Qtype:integer):string;
FTimeout: Integer;
FDNSHost: string;
FRCode: Integer;
FBuffer: string;
FSock: TUDPBlockSocket;
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;
QType: Integer): string;
public
timeout:integer;
DNSHost:string;
RCode:integer;
Constructor Create;
Destructor Destroy; override;
Function DNSQuery(Name:string;Qtype:integer;Reply:TStrings):Boolean;
constructor Create;
destructor Destroy; override;
function DNSQuery(Name: string; QType: Integer;
const Reply: TStrings): Boolean;
published
property Timeout: Integer read FTimeout Write FTimeout;
property DNSHost: string read FDNSHost Write FDNSHost;
property RCode: Integer read FRCode;
end;
function GetMailServers (DNSHost, domain:string; servers:TStringList):Boolean;
function GetMailServers(const DNSHost, Domain: string;
const Servers: TStrings): Boolean;
implementation
{TDNSSend.Create}
Constructor TDNSSend.Create;
constructor TDNSSend.Create;
begin
inherited Create;
sock:=TUDPBlockSocket.create;
sock.CreateSocket;
timeout:=5000;
DNShost:='localhost';
FSock := TUDPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 5000;
FDNSHost := cLocalhost;
end;
{TDNSSend.Destroy}
Destructor TDNSSend.Destroy;
destructor TDNSSend.Destroy;
begin
Sock.free;
inherited destroy;
FSock.Free;
inherited Destroy;
end;
{TDNSSend.ComressName}
function TDNSSend.CompressName(Value:string):string;
function TDNSSend.CompressName(const Value: string): string;
var
n:integer;
s:String;
n: Integer;
s: string;
begin
Result:='';
if Value='' then Result:=char(0)
else
Result := '';
if Value = '' then
Result := #0
else
begin
s := '';
for n := 1 to Length(Value) do
if Value[n] = '.' then
begin
s:='';
for n:=1 to Length(Value) do
if Value[n]='.' then
begin
Result:=Result+char(Length(s))+s;
s:='';
end
else s:=s+Value[n];
if s<>'' then Result:=Result+char(Length(s))+s;
Result:=Result+char(0);
end;
Result := Result + Char(Length(s)) + s;
s := '';
end
else
s := s + Value[n];
if s <> '' then
Result := Result + Char(Length(s)) + s;
Result := Result + #0;
end;
end;
{TDNSSend.CodeHeader}
function TDNSSend.CodeHeader:string;
function TDNSSend.CodeHeader: string;
begin
Randomize;
Result:=Codeint(Random(32767)); //ID
Result:=Result+Codeint($0100); //flags
Result:=Result+Codeint(1); //QDCount
Result:=Result+Codeint(0); //ANCount
Result:=Result+Codeint(0); //NSCount
Result:=Result+Codeint(0); //ARCount
Result := CodeInt(Random(32767)); // ID
Result := Result + CodeInt($0100); // flags
Result := Result + CodeInt(1); // QDCount
Result := Result + CodeInt(0); // ANCount
Result := Result + CodeInt(0); // NSCount
Result := Result + CodeInt(0); // ARCount
end;
{TDNSSend.CodeQuery}
function TDNSSend.CodeQuery(Name:string; Qtype:integer):string;
function TDNSSend.CodeQuery(const Name: string; QType: Integer): string;
begin
Result:=Compressname(Name);
Result:=Result+Codeint(Qtype);
Result:=Result+Codeint(1); //Type INTERNET
Result := CompressName(Name);
Result := Result + CodeInt(QType);
Result := Result + CodeInt(1); // Type INTERNET
end;
{TDNSSend.DecodeLabels}
function TDNSSend.DecodeLabels(var From:integer):string;
function TDNSSend.DecodeLabels(var From: Integer): string;
var
l,f:integer;
l, f: Integer;
begin
Result:='';
Result := '';
while True do
begin
l := Ord(FBuffer[From]);
Inc(From);
if l = 0 then
Break;
if Result <> '' then
Result := Result + '.';
if (l and $C0) = $C0 then
begin
l:=Ord(Buffer[From]);
f := l and $3F;
f := f * 256 + Ord(FBuffer[From]) + 1;
Inc(From);
if l=0 then break;
if Result<>'' then Result:=Result+'.';
if (l and $C0)=$C0
then
begin
f:=l and $3F;
f:=f*256+Ord(Buffer[From])+1;
Inc(From);
Result:=Result+Self.decodelabels(f);
break;
end
else
begin
Result:=Result+Copy(Buffer,From,l);
Inc(From,l);
end;
end;
end;
{TDNSSend.DecodeResource}
function TDNSSend.DecodeResource(var i:integer; Name:string;
Qtype:integer):string;
var
Rname:string;
RType,Len,j,x,n:integer;
begin
Result:='';
Rname:=decodelabels(i);
Rtype:=DeCodeint(Buffer,i);
Inc(i,8);
Len:=DeCodeint(Buffer,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
Result := Result + DecodeLabels(f);
Break;
end
else
begin
case Rtype of
Qtype_A :
begin
Result:=IntToStr(Ord(Buffer[j]));
Inc(j);
Result:=Result+'.'+IntToStr(Ord(Buffer[j]));
Inc(j);
Result:=Result+'.'+IntToStr(Ord(Buffer[j]));
Inc(j);
Result:=Result+'.'+IntToStr(Ord(Buffer[j]));
end;
Qtype_NS,
Qtype_MD,
Qtype_MF,
Qtype_CNAME,
Qtype_MB,
Qtype_MG,
Qtype_MR,
Qtype_PTR,
Qtype_X25,
Qtype_NSAP,
Qtype_NSAPPTR:
begin
Result:=Decodelabels(j);
end;
Qtype_SOA :
begin
Result:=Decodelabels(j);
Result:=Result+','+Decodelabels(j);
for n:=1 to 5 do
begin
x:=DecodeInt(Buffer,j)*65536+DecodeInt(Buffer,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(Buffer,j);
Inc(j,2);
Result:=IntToStr(x);
Result:=Result+','+Decodelabels(j);
end;
Qtype_TXT :
begin
Result:=Decodelabels(j);
end;
Qtype_GPOS :
begin
Result:=Decodelabels(j);
Result:=Result+','+Decodelabels(j);
Result:=Result+','+Decodelabels(j);
end;
Qtype_PX :
begin
x:=DecodeInt(Buffer,j);
Inc(j,2);
Result:=IntToStr(x);
Result:=Result+','+Decodelabels(j);
Result:=Result+','+Decodelabels(j);
end;
end;
Result := Result + Copy(FBuffer, From, l);
Inc(From, l);
end;
end;
end;
{TDNSSend.DNSQuery}
Function TDNSSend.DNSQuery(Name:string;Qtype:integer;Reply:TStrings):Boolean;
function TDNSSend.DecodeResource(var i: Integer; const Name: string;
QType: Integer): string;
var
x,n,i:integer;
flag,qdcount, ancount, nscount, arcount:integer;
s:string;
Rname: string;
RType, Len, j, x, n: Integer;
begin
Result:=False;
Reply.Clear;
if IsIP(Name) then Name:=ReverseIP(Name)+'.in-addr.arpa';
Buffer:=Codeheader+CodeQuery(Name,QType);
sock.connect(DNSHost,'domain');
// dump(Buffer,'c:\dnslog.Txt');
sock.sendstring(Buffer);
if sock.canread(timeout)
then begin
x:=sock.waitingdata;
setlength(Buffer,x);
sock.recvbuffer(Pointer(Buffer),x);
// dump(Buffer,'c:\dnslogr.Txt');
flag:=DeCodeint(Buffer,3);
RCode:=Flag and $000F;
if RCode=0 then
Result := '';
Rname := DecodeLabels(i);
RType := DecodeInt(FBuffer, i);
Inc(i, 8);
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:
begin
qdcount:=DeCodeint(Buffer,5);
ancount:=DeCodeint(Buffer,7);
nscount:=DeCodeint(Buffer,9);
arcount:=DeCodeint(Buffer,11);
i:=13; //begin of body
if qdcount>0 then //skip questions
for n:=1 to qdcount do
begin
while (Buffer[i]<>#0) and ((Ord(Buffer[i]) and $C0)<>$C0) do
Inc(i);
Inc(i,5);
end;
if ancount>0 then
for n:=1 to ancount do
begin
s:=DecodeResource(i, Name, Qtype);
if s<>'' then
Reply.Add(s);
end;
Result:=True;
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]));
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;
end;
function TDNSSend.DNSQuery(Name: string; QType: Integer;
const Reply: TStrings): Boolean;
var
x, n, i: Integer;
flag, qdcount, ancount, nscount, arcount: Integer;
s: string;
begin
Result := False;
Reply.Clear;
if IsIP(Name) then
Name := ReverseIP(Name) + '.in-addr.arpa';
FBuffer := CodeHeader + CodeQuery(Name, QType);
FSock.Connect(FDNSHost, cDnsProtocol);
FSock.SendString(FBuffer);
if FSock.CanRead(FTimeout) then
begin
x := FSock.WaitingData;
SetLength(FBuffer, x);
FSock.RecvBuffer(Pointer(FBuffer), x);
flag := DecodeInt(FBuffer, 3);
FRCode := Flag and $000F;
if FRCode = 0 then
begin
qdcount := DecodeInt(FBuffer, 5);
ancount := DecodeInt(FBuffer, 7);
nscount := DecodeInt(FBuffer, 9);
arcount := DecodeInt(FBuffer, 11);
i := 13; //begin of body
if qdcount > 0 then //skip questions
for n := 1 to qdcount do
begin
while (FBuffer[i] <> #0) and ((Ord(FBuffer[i]) and $C0) <> $C0) do
Inc(i);
Inc(i, 5);
end;
if ancount > 0 then
for n := 1 to ancount do
begin
s := DecodeResource(i, Name, QType);
if s <> '' then
Reply.Add(s);
end;
Result := True;
end;
end;
end;
{==============================================================================}
function GetMailServers (DNSHost, domain:string; servers:TStringList):Boolean;
function GetMailServers(const DNSHost, Domain: string;
const Servers: TStrings): Boolean;
var
DNS:TDNSSend;
t:TStringList;
n,m,x:integer;
DNS: TDNSSend;
t: TStringList;
n, m, x: Integer;
begin
Result:=False;
servers.Clear;
t:=TStringList.Create;
DNS:=TDNSSend.Create;
Result := False;
Servers.Clear;
t := TStringList.Create;
DNS := TDNSSend.Create;
try
DNS.DNSHost:=DNSHost;
if DNS.DNSQuery(domain,QType_MX,t) then
DNS.DNSHost := DNSHost;
if DNS.DNSQuery(Domain, QType_MX, t) then
begin
{ normalize preference number to 5 digits }
for n := 0 to t.Count - 1 do
begin
{normalize preference number to 5 digits}
for n:=0 to t.Count-1 do
begin
x:=Pos(',',t[n]);
if x>0 then
for m:=1 to 6-x do
t[n]:='0'+t[n];
end;
{sort server list}
t.Sorted:=True;
{result is sorted list without preference numbers}
for n:=0 to t.Count-1 do
begin
x:=Pos(',',t[n]);
servers.Add(Copy(t[n],x+1,Length(t[n])-x));
end;
Result:=True;
x := Pos(',', t[n]);
if x > 0 then
for m := 1 to 6 - x do
t[n] := '0' + t[n];
end;
{ sort server list }
t.Sorted := True;
{ result is sorted list without preference numbers }
for n := 0 to t.Count - 1 do
begin
x := Pos(',', t[n]);
Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x));
end;
Result := True;
end;
finally
DNS.Free;
t.Free;
@ -375,5 +366,3 @@ begin
end;
end.

669
httpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.001.000 |
| Project : Delphree - Synapse | 002.001.001 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
@ -23,423 +23,432 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit HTTPSend;
interface
uses
Blcksock, sysutils, classes, SynaUtil, SynaCode;
SysUtils, Classes,
blcksock, SynaUtil, SynaCode;
const
CRLF=#13+#10;
cHttpProtocol = '80';
type
TTransferEncoding=(TE_UNKNOWN,
TE_IDENTITY,
TE_CHUNKED);
TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
THTTPSend = class
THTTPSend = class(TObject)
private
Sock:TTCPBlockSocket;
TransferEncoding:TTransferEncoding;
AliveHost:string;
AlivePort:string;
function ReadUnknown:boolean;
function ReadIdentity(size:integer):boolean;
function ReadChunked:boolean;
FSock: TTCPBlockSocket;
FTransferEncoding: TTransferEncoding;
FAliveHost: string;
FAlivePort: string;
FHeaders: TStringList;
FDocument: TMemoryStream;
FMimeType: string;
FProtocol: string;
FKeepAlive: Boolean;
FTimeout: Integer;
FHTTPHost: string;
FHTTPPort: string;
FProxyHost: string;
FProxyPort: string;
FProxyUser: string;
FProxyPass: string;
FResultCode: Integer;
FResultString: string;
function ReadUnknown: Boolean;
function ReadIdentity(Size: Integer): Boolean;
function ReadChunked: Boolean;
public
headers:TStringlist;
Document:TMemoryStream;
MimeType:string;
Protocol:string;
KeepAlive:boolean;
Timeout:integer;
HTTPHost:string;
HTTPPort:string;
ProxyHost:string;
ProxyPort:string;
ProxyUser:string;
ProxyPass:string;
ResultCode:integer;
ResultString:string;
Constructor Create;
Destructor Destroy; override;
procedure clear;
procedure DecodeStatus(value:string);
function HTTPmethod(method,URL:string):boolean;
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure DecodeStatus(const Value: string);
function HTTPMethod(const Method, URL: string): Boolean;
published
property Headers: TStringList read FHeaders Write FHeaders;
property Document: TMemoryStream read FDocument Write FDocument;
property MimeType: string read FMimeType Write FMimeType;
property Protocol: string read FProtocol Write FProtocol;
property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
property Timeout: Integer read FTimeout Write FTimeout;
property HTTPHost: string read FHTTPHost;
property HTTPPort: string read FHTTPPort;
property ProxyHost: string read FProxyHost Write FProxyHost;
property ProxyPort: string read FProxyPort Write FProxyPort;
property ProxyUser: string read FProxyUser Write FProxyUser;
property ProxyPass: string read FProxyPass Write FProxyPass;
property ResultCode: Integer read FResultCode;
property ResultString: string read FResultString;
end;
function HttpGetText(URL:string;Response:TStrings):Boolean;
function HttpGetBinary(URL:string;Response:TStream):Boolean;
function HttpPostBinary(URL:string;Data:TStream):Boolean;
function HttpPostURL(URL:string;URLData:string;Data:TStream):Boolean;
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
implementation
{THTTPSend.Create}
Constructor THTTPSend.Create;
const
CRLF = #13#10;
constructor THTTPSend.Create;
begin
inherited Create;
Headers:=TStringList.create;
Document:=TMemoryStream.Create;
sock:=TTCPBlockSocket.create;
sock.SizeRecvBuffer:=65536;
sock.SizeSendBuffer:=65536;
timeout:=300000;
HTTPhost:='localhost';
HTTPPort:='80';
ProxyHost:='';
ProxyPort:='8080';
ProxyUser:='';
ProxyPass:='';
AliveHost:='';
AlivePort:='';
Protocol:='1.1';
KeepAlive:=true;
FHeaders := TStringList.Create;
FDocument := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create;
FSock.SizeRecvBuffer := 65536;
FSock.SizeSendBuffer := 65536;
FTimeout := 300000;
FHTTPHost := cLocalhost;
FHTTPPort := cHttpProtocol;
FProxyHost := '';
FProxyPort := '8080';
FProxyUser := '';
FProxyPass := '';
FAliveHost := '';
FAlivePort := '';
FProtocol := '1.1';
FKeepAlive := True;
Clear;
end;
{THTTPSend.Destroy}
Destructor THTTPSend.Destroy;
destructor THTTPSend.Destroy;
begin
Sock.free;
Document.free;
headers.free;
inherited destroy;
FSock.Free;
FDocument.Free;
FHeaders.Free;
inherited Destroy;
end;
{THTTPSend.Clear}
procedure THTTPSend.Clear;
begin
Document.Clear;
Headers.Clear;
MimeType:='text/html';
FDocument.Clear;
FHeaders.Clear;
FMimeType := 'text/html';
end;
{THTTPSend.DecodeStatus}
procedure THTTPSend.DecodeStatus(value:string);
procedure THTTPSend.DecodeStatus(const Value: string);
var
s,su:string;
s, su: string;
begin
s:=separateright(value,' ');
su:=separateleft(s,' ');
ResultCode:=StrToIntDef(su,0);
ResultString:=separateright(s,' ');
if ResultString=s
then ResultString:='';
s := SeparateRight(Value, ' ');
su := SeparateLeft(s, ' ');
FResultCode := StrToIntDef(su, 0);
FResultString := SeparateRight(s, ' ');
if FResultString = s then
FResultString := '';
end;
{THTTPSend.HTTPmethod}
function THTTPSend.HTTPmethod(method,URL:string):boolean;
function THTTPSend.HTTPMethod(const Method, URL: string): Boolean;
var
sending,receiving:boolean;
status100:boolean;
status100error:string;
ToClose:boolean;
size:integer;
Prot,User,Pass,Host,Port,Path,Para,URI:string;
n:integer;
s,su:string;
Sending, Receiving: Boolean;
status100: Boolean;
status100error: string;
ToClose: Boolean;
Size: Integer;
Prot, User, Pass, Host, Port, Path, Para, URI: string;
n: Integer;
s, su: string;
begin
{initial values}
result:=false;
ResultCode:=500;
ResultString:='';
Result := False;
FResultCode := 500;
FResultString := '';
URI:=ParseURL(URL,Prot,User,Pass,Host,Port,Path,Para);
sending:=Document.Size>0;
{headers for sending data}
status100:=sending and (protocol='1.1');
if status100
then Headers.insert(0,'Expect: 100-continue');
if sending then
begin
Headers.insert(0,'Content-Length: '+inttostr(Document.size));
if MimeType<>''
then Headers.insert(0,'Content-Type: '+MimeType);
end;
{seting KeepAlives}
if not KeepAlive
then Headers.insert(0,'Connection: close');
{set target servers/proxy, authorisations, etc...}
if User<>''
then Headers.insert(0,'Authorization: Basic '+EncodeBase64(user+':'+pass));
if (proxyhost<>'') and (proxyUser<>'')
then Headers.insert(0,'Proxy-Authorization: Basic '+EncodeBase64(Proxyuser+':'+Proxypass));
Headers.insert(0,'Host: '+host+':'+port);
if proxyHost<>''
then URI:=prot+'://'+host+':'+port+URI;
if URI='/*'
then URI:='*';
if protocol='0.9'
then Headers.insert(0,uppercase(method)+' '+URI)
else Headers.insert(0,uppercase(method)+' '+URI+' HTTP/'+protocol);
if proxyhost=''
then
begin
HttpHost:=host;
HttpPort:=port;
end
else
begin
HttpHost:=Proxyhost;
HttpPort:=Proxyport;
end;
if headers[headers.count-1]<>''
then headers.add('');
{connect}
if (Alivehost<>HTTPhost) or (AlivePort<>HTTPport)
then
begin
sock.CloseSocket;
sock.CreateSocket;
sock.Connect(HTTPHost,HTTPPort);
if sock.lasterror<>0 then Exit;
Alivehost:=HTTPhost;
AlivePort:=HTTPport;
end
else
begin
if sock.canread(0) then
begin
sock.CloseSocket;
sock.createsocket;
sock.Connect(HTTPHost,HTTPPort);
if sock.lasterror<>0 then Exit;
end;
end;
{send headers}
Sock.SendString(Headers[0]+CRLF);
if protocol<>'0.9' then
for n:=1 to Headers.Count-1 do
Sock.SendString(Headers[n]+CRLF);
if sock.lasterror<>0 then Exit;
{reading Status}
Status100Error:='';
URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
Sending := Document.Size > 0;
{Headers for Sending data}
status100 := Sending and (FProtocol = '1.1');
if status100 then
FHeaders.Insert(0, 'Expect: 100-continue');
if Sending then
begin
FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
if FMimeType <> '' then
FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
end;
{ setting KeepAlives }
if not FKeepAlive then
FHeaders.Insert(0, 'Connection: close');
{ set target servers/proxy, authorisations, etc... }
if User <> '' then
FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(user + ':' + pass));
if (FProxyHost <> '') and (FProxyUser <> '') then
FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
EncodeBase64(FProxyUser + ':' + FProxyPass));
FHeaders.Insert(0, 'Host: ' + Host + ':' + Port);
if FProxyHost <> '' then
URI := Prot + '://' + Host + ':' + Port + URI;
if URI = '/*' then
URI := '*';
if FProtocol = '0.9' then
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI)
else
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
if FProxyHost = '' then
begin
FHTTPHost := Host;
FHTTPPort := Port;
end
else
begin
FHTTPHost := FProxyHost;
FHTTPPort := FProxyPort;
end;
if FHeaders[FHeaders.Count - 1] <> '' then
FHeaders.Add('');
{ connect }
if (FAliveHost <> FHTTPHost) or (FAlivePort <> FHTTPPort) then
begin
FSock.CloseSocket;
FSock.CreateSocket;
FSock.Connect(FHTTPHost, FHTTPPort);
if FSock.LastError <> 0 then
Exit;
FAliveHost := FHTTPHost;
FAlivePort := FHTTPPort;
end
else
begin
if FSock.CanRead(0) then
begin
repeat
s:=sock.recvstring(timeout);
if s<>'' then break;
until sock.lasterror<>0;
DecodeStatus(s);
if (ResultCode>=100) and (ResultCode<200)
then
begin
repeat
s:=sock.recvstring(timeout);
if s='' then break;
until sock.lasterror<>0;
end
else
begin
sending:=false;
Status100Error:=s;
end;
FSock.CloseSocket;
FSock.CreateSocket;
FSock.Connect(FHTTPHost, FHTTPPort);
if FSock.LastError <> 0 then
Exit;
end;
end;
{send document}
if sending then
begin
Sock.SendBuffer(Document.memory,Document.size);
if sock.lasterror<>0 then Exit;
end;
{ send Headers }
FSock.SendString(Headers[0] + CRLF);
if FProtocol <> '0.9' then
for n := 1 to FHeaders.Count - 1 do
FSock.SendString(FHeaders[n] + CRLF);
if FSock.LastError <> 0 then
Exit;
clear;
size:=-1;
TransferEncoding:=TE_UNKNOWN;
{read status}
If Status100Error=''
then
begin
repeat
s:=sock.recvstring(timeout);
if s<>'' then break;
until sock.lasterror<>0;
if pos('HTTP/',uppercase(s))=1
then
begin
Headers.add(s);
decodeStatus(s);
end
else
begin
{old HTTP 0.9 and some buggy servers not send result}
s:=s+CRLF;
document.Write(pointer(s)^,length(s));
ResultCode:=0;
end;
end
else Headers.add(Status100Error);
{if need receive hedaers, receive and parse it}
ToClose:=protocol<>'1.1';
if Headers.count>0 then
{ reading Status }
Status100Error := '';
if status100 then
begin
repeat
s:=sock.recvstring(timeout);
Headers.Add(s);
if s=''
then break;
su:=uppercase(s);
if pos('CONTENT-LENGTH:',su)=1 then
begin
size:=strtointdef(separateright(s,' '),-1);
TransferEncoding:=TE_IDENTITY;
end;
if pos('CONTENT-TYPE:',su)=1 then
MimeType:=separateright(s,' ');
if pos('TRANSFER-ENCODING:',su)=1 then
begin
s:=separateright(su,' ');
if pos('CHUNKED',s)>0 then
TransferEncoding:=TE_CHUNKED;
end;
if pos('CONNECTION: CLOSE',su)=1 then
ToClose:=true;
until sock.lasterror<>0;
s := FSock.RecvString(FTimeout);
if s <> '' then
Break;
until FSock.LastError <> 0;
DecodeStatus(s);
if (FResultCode >= 100) and (FResultCode < 200) then
repeat
s := FSock.recvstring(FTimeout);
if s = '' then
Break;
until FSock.LastError <> 0
else
begin
Sending := False;
Status100Error := s;
end;
end;
{ send document }
if Sending then
begin
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
if FSock.LastError <> 0 then
Exit;
end;
Clear;
Size := -1;
FTransferEncoding := TE_UNKNOWN;
{ read status }
if Status100Error = '' then
begin
repeat
s := FSock.RecvString(FTimeout);
if s <> '' then
Break;
until FSock.LastError <> 0;
if Pos('HTTP/', UpperCase(s)) = 1 then
begin
FHeaders.Add(s);
DecodeStatus(s);
end
else
begin
{ old HTTP 0.9 and some buggy servers not send result }
s := s + CRLF;
FDocument.Write(Pointer(s)^, Length(s));
FResultCode := 0;
end;
end
else
FHeaders.Add(Status100Error);
{ if need receive hedaers, receive and parse it }
ToClose := FProtocol <> '1.1';
if FHeaders.Count > 0 then
repeat
s := FSock.RecvString(FTimeout);
FHeaders.Add(s);
if s = '' then
Break;
su := UpperCase(s);
if Pos('CONTENT-LENGTH:', su) = 1 then
begin
Size := StrToIntDef(SeparateRight(s, ' '), -1);
FTransferEncoding := TE_IDENTITY;
end;
if Pos('CONTENT-TYPE:', su) = 1 then
FMimeType := SeparateRight(s, ' ');
if Pos('TRANSFER-ENCODING:', su) = 1 then
begin
s := SeparateRight(su, ' ');
if Pos('CHUNKED', s) > 0 then
FTransferEncoding := TE_CHUNKED;
end;
if Pos('CONNECTION: CLOSE', su) = 1 then
ToClose := True;
until FSock.LastError <> 0;
{if need receive response body, read it}
Receiving:=Method<>'HEAD';
Receiving:=Receiving and (ResultCode<>204);
Receiving:=Receiving and (ResultCode<>304);
Receiving := Method <> 'HEAD';
Receiving := Receiving and (FResultCode <> 204);
Receiving := Receiving and (FResultCode <> 304);
if Receiving then
case TransferEncoding of
TE_UNKNOWN : readunknown;
TE_IDENTITY: readidentity(size);
TE_CHUNKED : readChunked;
case FTransferEncoding of
TE_UNKNOWN:
ReadUnknown;
TE_IDENTITY:
ReadIdentity(Size);
TE_CHUNKED:
ReadChunked;
end;
Document.Seek(0,soFromBeginning);
result:=true;
FDocument.Seek(0, soFromBeginning);
Result := True;
if ToClose then
begin
sock.closesocket;
Alivehost:='';
AlivePort:='';
end;
end;
{THTTPSend.ReadUnknown}
function THTTPSend.ReadUnknown:boolean;
var
s:string;
begin
result:=false;
repeat
s:=sock.recvstring(timeout);
s:=s+CRLF;
document.Write(pointer(s)^,length(s));
until sock.lasterror<>0;
result:=true;
end;
{THTTPSend.ReadIdentity}
function THTTPSend.ReadIdentity(size:integer):boolean;
var
mem:TMemoryStream;
begin
mem:=TMemoryStream.create;
try
mem.SetSize(size);
sock.RecvBufferEx(mem.memory,size,timeout);
result:=sock.lasterror=0;
document.CopyFrom(mem,0);
finally
mem.free;
begin
FSock.CloseSocket;
FAliveHost := '';
FAlivePort := '';
end;
end;
{THTTPSend.ReadChunked}
function THTTPSend.ReadChunked:boolean;
function THTTPSend.ReadUnknown: Boolean;
var
s:string;
size:integer;
s: string;
begin
repeat
s := FSock.RecvString(FTimeout);
s := s + CRLF;
FDocument.Write(Pointer(s)^, Length(s));
until FSock.LastError <> 0;
Result := True;
end;
function THTTPSend.ReadIdentity(Size: Integer): Boolean;
var
mem: TMemoryStream;
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;
end;
function THTTPSend.ReadChunked: Boolean;
var
s: string;
Size: Integer;
begin
repeat
repeat
s:=sock.recvstring(timeout);
until s<>'';
if sock.lasterror<>0
then break;
s:=separateleft(s,' ');
size:=strtointdef('$'+s,0);
if size=0 then break;
ReadIdentity(size);
until false;
result:=sock.lasterror=0;
s := FSock.RecvString(FTimeout);
until s <> '';
if FSock.LastError <> 0 then
Break;
s := SeparateLeft(s, ' ');
Size := StrToIntDef('$' + s, 0);
if Size = 0 then
Break;
ReadIdentity(Size);
until False;
Result := FSock.LastError = 0;
end;
{==============================================================================}
{HttpGetText}
function HttpGetText(URL:string;Response:TStrings):Boolean;
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
var
HTTP:THTTPSend;
HTTP: THTTPSend;
begin
Result:=False;
HTTP:=THTTPSend.Create;
HTTP := THTTPSend.Create;
try
Result:=HTTP.HTTPmethod('GET',URL);
response.LoadFromStream(HTTP.document);
Result := HTTP.HTTPMethod('GET', URL);
Response.LoadFromStream(HTTP.Document);
finally
HTTP.Free;
end;
end;
{HttpGetBinary}
function HttpGetBinary(URL:string;Response:TStream):Boolean;
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
var
HTTP:THTTPSend;
HTTP: THTTPSend;
begin
Result:=False;
HTTP:=THTTPSend.Create;
HTTP := THTTPSend.Create;
try
Result:=HTTP.HTTPmethod('GET',URL);
Response.Seek(0,soFromBeginning);
Response.CopyFrom(HTTP.document,0);
Result := HTTP.HTTPMethod('GET', URL);
Response.Seek(0, soFromBeginning);
Response.CopyFrom(HTTP.Document, 0);
finally
HTTP.Free;
end;
end;
{HttpPostBinary}
function HttpPostBinary(URL:string;Data:TStream):Boolean;
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
var
HTTP:THTTPSend;
HTTP: THTTPSend;
begin
Result:=False;
HTTP:=THTTPSend.Create;
HTTP := THTTPSend.Create;
try
HTTP.Document.CopyFrom(data,0);
HTTP.MimeType:='Application/octet-stream';
Result:=HTTP.HTTPmethod('POST',URL);
data.Seek(0,soFromBeginning);
data.CopyFrom(HTTP.document,0);
HTTP.Document.CopyFrom(Data, 0);
HTTP.MimeType := 'Application/octet-stream';
Result := HTTP.HTTPMethod('POST', URL);
Data.Seek(0, soFromBeginning);
Data.CopyFrom(HTTP.Document, 0);
finally
HTTP.Free;
end;
end;
{HttpPostURL}
function HttpPostURL(URL:string;URLData:string;Data:TStream):Boolean;
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
var
HTTP:THTTPSend;
HTTP: THTTPSend;
begin
Result:=False;
HTTP:=THTTPSend.Create;
HTTP := THTTPSend.Create;
try
HTTP.Document.Write(pointer(URLData)^,Length(URLData));
HTTP.MimeType:='application/x-url-encoded';
Result:=HTTP.HTTPmethod('POST',URL);
data.Seek(0,soFromBeginning);
data.CopyFrom(HTTP.document,0);
HTTP.Document.Write(Pointer(URLData)^, Length(URLData));
HTTP.MimeType := 'application/x-url-encoded';
Result := HTTP.HTTPMethod('POST', URL);
Data.Seek(0, soFromBeginning);
Data.CopyFrom(HTTP.Document, 0);
finally
HTTP.Free;
end;
end;
end.

1135
mimechar.pas
View File

File diff suppressed because it is too large Load Diff

240
mimeinln.pas
View File

@ -1,11 +1,11 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.001 |
| Project : Delphree - Synapse | 001.000.002 |
|==============================================================================|
| Content: Inline MIME support procedures and functions |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000. |
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -23,151 +23,151 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit MIMEinLn;
interface
uses
sysutils, classes, MIMEchar, SynaCode, SynaUtil;
SysUtils, Classes,
SynaChar, SynaCode, SynaUtil;
function InlineDecode(value:string;CP:TMimeChar):string;
function InlineEncode(value:string;CP,MimeP:TMimeChar):string;
Function NeedInline(value:string):boolean;
function InlineCode(value:string):string;
function InlineEmail(value:string):string;
function InlineDecode(const Value: string; CP: TMimeChar): string;
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
function NeedInline(const Value: string): boolean;
function InlineCode(const Value: string): string;
function InlineEmail(const Value: string): string;
implementation
{==============================================================================}
{InlineDecode}
function InlineDecode(value:string;CP:TMimeChar):string;
var
s,su:string;
x,y,z,n:integer;
ichar:TMimeChar;
c:char;
function SearchEndInline(value:string;be:integer):integer;
function InlineDecode(const Value: string; CP: TMimeChar): string;
var
s, su: string;
x, y, z, n: Integer;
ichar: TMimeChar;
c: Char;
function SearchEndInline(const Value: string; be: Integer): Integer;
var
n,q:integer;
n, q: Integer;
begin
q:=0;
result:=0;
for n:=be+2 to length(value)-1 do
if value[n]='?' then
q := 0;
Result := 0;
for n := be + 2 to Length(Value) - 1 do
if Value[n] = '?' then
begin
Inc(q);
if (q > 2) and (Value[n + 1] = '=') then
begin
inc(q);
if (q>2) and (value[n+1]='=') then
begin
result:=n;
break;
end;
Result := n;
Break;
end;
end;
end;
begin
result:=value;
x:=pos('=?',result);
y:=SearchEndInline(result,x);
while y>x do
Result := Value;
x := Pos('=?', Result);
y := SearchEndInline(Result, x);
while y > x do
begin
s := Copy(Result, x, y - x + 2);
su := Copy(s, 3, Length(s) - 4);
ichar := GetCPFromID(su);
z := Pos('?', su);
if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
begin
s:=copy(result,x,y-x+2);
su:=copy(s,3,length(s)-4);
ichar:=GetCPfromID(su);
z:=pos('?',su);
if (length(su)>=(z+2)) and (su[z+2]='?') then
begin
c:=uppercase(su)[z+1];
su:=copy(su,z+3,length(su)-z-2);
if c='B' then
begin
s:=DecodeBase64(su);
s:=DecodeChar(s,ichar,CP);
end;
if c='Q' then
begin
s:='';
for n:=1 to length(su) do
if su[n]='_'
then s:=s+' '
else s:=s+su[n];
s:=DecodeQuotedprintable(s);
s:=DecodeChar(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);
c := UpperCase(su)[z + 1];
su := Copy(su, z + 3, Length(su) - z - 2);
if c = 'B' then
begin
s := DecodeBase64(su);
s := CharsetConversion(s, ichar, CP);
end;
if c = 'Q' then
begin
s := '';
for n := 1 to Length(su) do
if su[n] = '_' then
s := s + ' '
else
s := s + su[n];
s := DecodeQuotedPrintable(s);
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);
end;
end;
{==============================================================================}
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
var
s, s1: string;
n: Integer;
begin
s := CharsetConversion(Value, CP, MimeP);
s := EncodeQuotedPrintable(s);
s1 := '';
for n := 1 to Length(s) do
if s[n] = ' ' then
s1 := s1 + '=20'
else
s1 := s1 + s[n];
Result := '=?' + GetIdFromCP(MimeP) + '?Q?' + s1 + '?=';
end;
{==============================================================================}
function NeedInline(const Value: string): boolean;
var
n: Integer;
begin
Result := False;
for n := 1 to Length(Value) do
if Value[n] in (SpecialChar + [Char(1)..Char(31), Char(128)..Char(255)]) then
begin
Result := True;
Break;
end;
end;
{==============================================================================}
{InlineEncode}
function InlineEncode(value:string;CP,MimeP:TMimeChar):string;
var
s,s1:string;
n:integer;
begin
s:=DecodeChar(value,CP,MimeP);
s:=EncodeQuotedPrintable(s);
s1:='';
for n:=1 to length(s) do
if s[n]=' '
then s1:=s1+'=20'
else s1:=s1+s[n];
result:='=?'+GetIdFromCP(MimeP)+'?Q?'+s1+'?=';
end;
{==============================================================================}
{NeedInline}
Function NeedInline(value:string):boolean;
function InlineCode(const Value: string): string;
var
n:integer;
c: TMimeChar;
begin
result:=false;
for n:=1 to length(value) do
if value[n] in (SpecialChar+[char(1)..char(31),char(128)..char(255)]) then
begin
result:=true;
break;
end;
end;
{==============================================================================}
{InlineCode}
function InlineCode(value:string):string;
var
c:TMimeChar;
begin
if NeedInline(value)
then
begin
c:=IdealCoding(value,GetCurCP,
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
result:=InlineEncode(value,GetCurCP,c);
end
else result:=value;
end;
{==============================================================================}
{InlineEmail}
function InlineEmail(value:string):string;
var
sd,se:string;
begin
sd:=getEmaildesc(value);
se:=getEmailAddr(value);
if sd=''
then result:=se
else result:='"'+InlineCode(sd)+'"<'+se+'>';
if NeedInline(Value) then
begin
c := IdealCharsetCoding(Value, GetCurCP,
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
Result := InlineEncode(Value, GetCurCP, c);
end
else
Result := Value;
end;
{==============================================================================}
function InlineEmail(const Value: string): string;
var
sd, se: string;
begin
exit;
asm
db 'Synapse Inline MIME encoding and decoding library by Lukas Gebauer',0
end;
sd := GetEmailDesc(Value);
se := GetEmailAddr(Value);
if sd = '' then
Result := se
else
Result := '"' + InlineCode(sd) + '"<' + se + '>';
end;
end.

538
mimemess.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.003.000 |
| Project : Delphree - Synapse | 001.004.000 |
|==============================================================================|
| Content: MIME message object |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
@ -19,314 +19,334 @@
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| History: see HISTORY.HTM From distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit MIMEmess;
interface
uses
classes, Sysutils, MIMEpart, MimeChar, SynaUtil, MIMEInLn;
Classes, SysUtils,
MIMEpart, SynaChar, SynaUtil, MIMEinLn;
type
TMessHeader=record
from:string;
ToList:tstringlist;
subject:string;
organization:string;
end;
TMimeMess=class(TObject)
TMessHeader = class(TObject)
private
FFrom: string;
FToList: TStringList;
FSubject: string;
FOrganization: string;
public
PartList:TList;
Lines:TStringList;
header:TMessHeader;
constructor Create;
destructor Destroy; override;
procedure Clear;
function AddPart:integer;
procedure AddPartText(value:tstringList);
procedure AddPartHTML(value:tstringList);
procedure AddPartHTMLBinary(Value,Cid:string);
procedure AddPartBinary(value:string);
published
property From: string read FFrom Write FFrom;
property ToList: TStringList read FToList Write FToList;
property Subject: string read FSubject Write FSubject;
property Organization: string read FOrganization Write FOrganization;
end;
TMimeMess = class(TObject)
private
FPartList: TList;
FLines: TStringList;
FHeader: TMessHeader;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function AddPart: Integer;
procedure AddPartText(Value: TStringList);
procedure AddPartHTML(Value: TStringList);
procedure AddPartHTMLBinary(Value, Cid: string);
procedure AddPartBinary(Value: string);
procedure EncodeMessage;
procedure FinalizeHeaders;
procedure ParseHeaders;
procedure DecodeMessage;
end;
published
property PartList: TList read FPartList Write FPartList;
property Lines: TStringList read FLines Write FLines;
property Header: TMessHeader read FHeader Write FHeader;
end;
implementation
{==============================================================================}
{TMimeMess.Create}
Constructor TMimeMess.Create;
constructor TMessHeader.Create;
begin
inherited Create;
PartList:=TList.create;
Lines:=TStringList.create;
Header.ToList:=TStringList.create;
FToList := TStringList.Create;
end;
{TMimeMess.Destroy}
Destructor TMimeMess.Destroy;
destructor TMessHeader.Destroy;
begin
Header.ToList.free;
Lines.free;
PartList.free;
inherited destroy;
FToList.Free;
inherited Destroy;
end;
{==============================================================================}
{TMimeMess.Clear}
procedure TMessHeader.Clear;
begin
FFrom := '';
FToList.Clear;
FSubject := '';
FOrganization := '';
end;
{==============================================================================}
constructor TMimeMess.Create;
begin
inherited Create;
FPartList := TList.Create;
FLines := TStringList.Create;
FHeader := TMessHeader.Create;
end;
destructor TMimeMess.Destroy;
begin
FHeader.Free;
Lines.Free;
PartList.Free;
inherited Destroy;
end;
{==============================================================================}
procedure TMimeMess.Clear;
var
n:integer;
n: Integer;
begin
Lines.clear;
for n:=0 to PartList.count-1 do
Lines.Clear;
for n := 0 to PartList.Count - 1 do
TMimePart(PartList[n]).Free;
PartList.Clear;
with header do
begin
from:='';
ToList.clear;
subject:='';
organization:='';
end;
FHeader.Clear;
end;
{==============================================================================}
{TMimeMess.AddPart}
function TMimeMess.AddPart:integer;
function TMimeMess.AddPart: Integer;
var
mp:TMimePart;
mp: TMimePart;
begin
mp:=TMimePart.create;
result:=PartList.Add(mp);
mp := TMimePart.Create;
Result := PartList.Add(mp);
end;
{==============================================================================}
{TMimeMess.AddPartText}
procedure TMimeMess.AddPartText(value:tstringList);
procedure TMimeMess.AddPartText(Value: TStringList);
var
x:integer;
x: Integer;
begin
x:=Addpart;
x := AddPart;
with TMimePart(PartList[x]) do
begin
value.SaveToStream(decodedlines);
primary:='text';
secondary:='plain';
description:='Message text';
disposition:='inline';
CharsetCode:=IdealCoding(value.text,targetCharset,
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
EncodingCode:=ME_QUOTED_PRINTABLE;
EncodePart;
end;
end;
{==============================================================================}
{TMimeMess.AddPartHTML}
procedure TMimeMess.AddPartHTML(value:tstringList);
var
x:integer;
begin
x:=Addpart;
with TMimePart(PartList[x]) do
begin
value.SaveToStream(decodedlines);
primary:='text';
secondary:='html';
description:='HTML text';
disposition:='inline';
CharsetCode:=UTF_8;
EncodingCode:=ME_QUOTED_PRINTABLE;
EncodePart;
end;
end;
{==============================================================================}
{TMimeMess.AddPartBinary}
procedure TMimeMess.AddPartBinary(value:string);
var
x:integer;
s:string;
begin
x:=Addpart;
with TMimePart(PartList[x]) do
begin
DecodedLines.LoadFromFile(Value);
s:=ExtractFileName(value);
MimeTypeFromExt(s);
description:='Attached file: '+s;
disposition:='attachment';
filename:=s;
EncodingCode:=ME_BASE64;
EncodePart;
end;
end;
{TMimeMess.AddPartHTMLBinary}
procedure TMimeMess.AddPartHTMLBinary(Value,Cid:string);
var
x:integer;
s:string;
begin
x:=Addpart;
with TMimePart(PartList[x]) do
begin
DecodedLines.LoadFromFile(Value);
s:=ExtractFileName(value);
MimeTypeFromExt(s);
description:='Included file: '+s;
disposition:='inline';
contentID:=cid;
filename:=s;
EncodingCode:=ME_BASE64;
EncodePart;
end;
end;
{==============================================================================}
{TMimeMess.Encodemessage}
procedure TMimeMess.Encodemessage;
var
bound:string;
n:integer;
m:TMimepart;
begin
lines.clear;
If PartList.Count=1
then
Lines.assign(TMimePart(PartList[0]).lines)
else
begin
bound:=generateboundary;
for n:=0 to PartList.count-1 do
begin
Lines.add('--'+bound);
lines.AddStrings(TMimePart(PartList[n]).lines);
end;
Lines.add('--'+bound);
m:=TMimePart.Create;
try
Lines.SaveToStream(m.DecodedLines);
m.Primary:='Multipart';
m.secondary:='mixed';
m.description:='Multipart message';
m.boundary:=bound;
m.EncodePart;
Lines.assign(m.lines);
finally
m.free;
end;
end;
end;
{==============================================================================}
{TMimeMess.FinalizeHeaders}
procedure TMimeMess.FinalizeHeaders;
var
n:integer;
begin
Lines.Insert(0,'x-mailer: Synapse - Delphi TCP/IP library by Lukas Gebauer');
Lines.Insert(0,'MIME-Version: 1.0 (produced by Synapse)');
Lines.Insert(0,'date: '+Rfc822DateTime(now));
if header.organization<>''
then Lines.Insert(0,'Organization: '+InlineCode(header.organization));
if header.subject<>''
then Lines.Insert(0,'Subject: '+InlineCode(header.subject));
for n:=0 to Header.ToList.count-1 do
Lines.Insert(0,'To: '+InlineEmail(header.ToList[n]));
Lines.Insert(0,'From: '+InlineEmail(header.from));
end;
{==============================================================================}
{TMimeMess.ParseHeaders}
procedure TMimeMess.ParseHeaders;
var
s:string;
x:integer;
cp:TMimeChar;
begin
cp:=getCurCP;
header.ToList.clear;
x:=0;
while lines.count>x do
begin
s:=normalizeheader(lines,x);
if s=''
then break;
If pos('FROM:',uppercase(s))=1
then header.from:=InlineDecode(separateright(s,':'),cp);
If pos('SUBJECT:',uppercase(s))=1
then header.subject:=InlineDecode(separateright(s,':'),cp);
If pos('ORGANIZATION:',uppercase(s))=1
then header.organization:=InlineDecode(separateright(s,':'),cp);
If pos('TO:',uppercase(s))=1
then header.ToList.add(InlineDecode(separateright(s,':'),cp));
end;
end;
{==============================================================================}
{TMimeMess.DecodeMessage}
procedure TMimeMess.DecodeMessage;
var
l:tstringlist;
m:tmimepart;
x,i:integer;
bound:string;
begin
l:=tstringlist.create;
m:=tmimepart.create;
try
l.assign(lines);
with header do
begin
from:='';
ToList.clear;
subject:='';
organization:='';
end;
ParseHeaders;
m.ExtractPart(l,0);
if m.primarycode=MP_MULTIPART
then
begin
bound:=m.boundary;
i:=0;
repeat
x:=AddPart;
with TMimePart(PartList[x]) do
begin
boundary:=bound;
i:=ExtractPart(l,i);
DecodePart;
end;
until i>=l.count-2;
end
else
begin
x:=AddPart;
with TMimePart(PartList[x]) do
begin
ExtractPart(l,0);
DecodePart;
end;
end;
finally
m.free;
l.free;
begin
Value.SaveToStream(DecodedLines);
Primary := 'text';
Secondary := 'plain';
Description := 'Message text';
Disposition := 'inline';
CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset,
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
end;
end;
{==============================================================================}
procedure TMimeMess.AddPartHTML(Value: TStringList);
var
x: Integer;
begin
x := AddPart;
with TMimePart(PartList[x]) do
begin
Value.SaveToStream(DecodedLines);
Primary := 'text';
Secondary := 'html';
Description := 'HTML text';
Disposition := 'inline';
CharsetCode := UTF_8;
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
end;
end;
{==============================================================================}
procedure TMimeMess.AddPartBinary(Value: string);
var
x: Integer;
s: string;
begin
x := AddPart;
with TMimePart(PartList[x]) do
begin
DecodedLines.LoadFromFile(Value);
s := ExtractFileName(Value);
MimeTypeFromExt(s);
Description := 'Attached file: ' + s;
Disposition := 'attachment';
FileName := s;
EncodingCode := ME_BASE64;
EncodePart;
end;
end;
procedure TMimeMess.AddPartHTMLBinary(Value, Cid: string);
var
x: Integer;
s: string;
begin
x := AddPart;
with TMimePart(PartList[x]) do
begin
DecodedLines.LoadFromFile(Value);
s := ExtractFileName(Value);
MimeTypeFromExt(s);
Description := 'Included file: ' + s;
Disposition := 'inline';
ContentID := cid;
FileName := s;
EncodingCode := ME_BASE64;
EncodePart;
end;
end;
{==============================================================================}
procedure TMimeMess.EncodeMessage;
var
bound: string;
n: Integer;
begin
Lines.Clear;
if PartList.Count = 1 then
Lines.Assign(TMimePart(PartList[0]).Lines)
else
begin
bound := GenerateBoundary;
for n := 0 to PartList.Count - 1 do
begin
Lines.Add('--' + bound);
Lines.AddStrings(TMimePart(PartList[n]).Lines);
end;
Lines.Add('--' + bound);
with TMimePart.Create do
try
Self.Lines.SaveToStream(DecodedLines);
Primary := 'Multipart';
Secondary := 'mixed';
Description := 'Multipart message';
Boundary := bound;
EncodePart;
Self.Lines.Assign(Lines);
finally
Free;
end;
end;
end;
{==============================================================================}
procedure TMimeMess.FinalizeHeaders;
var
n: Integer;
begin
Lines.Insert(0, 'x-mailer: Synapse - Delphi TCP/IP library by Lukas Gebauer');
Lines.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
Lines.Insert(0, 'date: ' + Rfc822DateTime(Now));
if FHeader.Organization <> '' then
Lines.Insert(0, 'Organization: ' + InlineCode(Header.Organization));
if Header.Subject <> '' then
FLines.Insert(0, 'Subject: ' + InlineCode(Header.Subject));
for n := 0 to FHeader.ToList.Count - 1 do
Lines.Insert(0, 'To: ' + InlineEmail(FHeader.ToList[n]));
Lines.Insert(0, 'From: ' + InlineEmail(FHeader.From));
end;
{==============================================================================}
procedure TMimeMess.ParseHeaders;
var
s: string;
x: Integer;
cp: TMimeChar;
begin
cp := GetCurCP;
FHeader.Clear;
x := 0;
while Lines.Count > x do
begin
s := NormalizeHeader(Lines, x);
if s = '' then
Break;
if Pos('FROM:', UpperCase(s)) = 1 then
FHeader.From := InlineDecode(SeparateRight(s, ':'), cp);
if Pos('SUBJECT:', UpperCase(s)) = 1 then
FHeader.Subject := InlineDecode(SeparateRight(s, ':'), cp);
if Pos('ORGANIZATION:', UpperCase(s)) = 1 then
FHeader.Organization := InlineDecode(SeparateRight(s, ':'), cp);
if Pos('TO:', UpperCase(s)) = 1 then
FHeader.ToList.Add(InlineDecode(SeparateRight(s, ':'), cp));
end;
end;
{==============================================================================}
procedure TMimeMess.DecodeMessage;
var
l: TStringList;
m: TMimePart;
x, i: Integer;
bound: string;
begin
l := TStringList.Create;
m := TMimePart.Create;
try
l.Assign(Lines);
FHeader.Clear;
ParseHeaders;
m.ExtractPart(l, 0);
if m.PrimaryCode = MP_MULTIPART then
begin
bound := m.Boundary;
i := 0;
repeat
x := AddPart;
with TMimePart(PartList[x]) do
begin
Boundary := bound;
i := ExtractPart(l, i);
DecodePart;
end;
until i >= l.Count - 2;
end
else
begin
x := AddPart;
with TMimePart(PartList[x]) do
begin
ExtractPart(l, 0);
DecodePart;
end;
end;
finally
m.Free;
l.Free;
end;
end;
end.

917
mimepart.pas
View File

File diff suppressed because it is too large Load Diff

273
pingsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.000.000 |
| Project : Delphree - Synapse | 002.001.000 |
|==============================================================================|
| Content: PING sender |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000. |
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -25,27 +25,12 @@
{
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Remember, this unit work only on Linux or Windows with Winsock2!
(on Win98 and WinNT 4.0 or higher)
If you must use this unit on Win95, download Wínsock2 from Microsoft
and distribute it with your application!
In spite of I use Winsock level version 1.1, RAW sockets work in this level only
if Winsock2 is installed on your computer!!!
On WinNT standardly RAW sockets work if program is running under user with
administrators provilegies. To use RAW sockets under another users, you must
create the following registry variable and set its value to DWORD 1:
HKLM\System\CurrentControlSet\Services\Afd\Parameters\DisableRawSecurity
After you change the registry, you need to restart your computer!
See 'winsock2.txt' file in distribute package!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
}
{$Q-}
{$WEAKPACKAGEUNIT ON}
unit PINGsend;
@ -53,159 +38,183 @@ interface
uses
{$IFDEF LINUX}
libc,
Libc,
{$ELSE}
windows,
Windows,
{$ENDIF}
synsock, SysUtils, blcksck2, Synautil;
SysUtils,
synsock, blcksock, SynaUtil;
const
ICMP_ECHO=8;
ICMP_ECHOREPLY=0;
ICMP_ECHO = 8;
ICMP_ECHOREPLY = 0;
type
TIcmpEchoHeader = record
i_type: Byte;
i_code: Byte;
i_checkSum: Word;
i_Id: Word;
i_seq: Word;
TimeStamp: ULONG;
end;
TIcmpEchoHeader = Record
i_type : Byte;
i_code : Byte;
i_checkSum : Word;
i_Id : Word;
i_seq : Word;
TimeStamp : ULong;
End;
TPINGSend=class(TObject)
TPINGSend = class(TObject)
private
Sock:TICMPBlockSocket;
Buffer:string;
seq:integer;
id:integer;
function checksum:integer;
function GetTick:cardinal;
FSock: TICMPBlockSocket;
FBuffer: string;
FSeq: Integer;
FId: Integer;
FTimeout: Integer;
FPacketSize: Integer;
FPingTime: Integer;
function Checksum: Integer;
function GetTick: Cardinal;
function ReadPacket: Boolean;
public
timeout:integer;
PacketSize:integer;
PingTime:integer;
function ping(host:string):Boolean;
function Ping(const Host: string): Boolean;
constructor Create;
destructor Destroy; override;
end;
published
property Timeout: Integer read FTimeout Write FTimeout;
property PacketSize: Integer read FPacketSize Write FPacketSize;
property PingTime: Integer read FPingTime;
end;
function PingHost(host:string):integer;
function PingHost(const Host: string): Integer;
implementation
{==============================================================================}
{TPINGSend.Create}
Constructor TPINGSend.Create;
constructor TPINGSend.Create;
begin
inherited Create;
sock:=TICMPBlockSocket.create;
sock.CreateSocket;
timeout:=5000;
packetsize:=32;
seq:=0;
FSock := TICMPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 5000;
FPacketSize := 32;
FSeq := 0;
Randomize;
end;
{TPINGSend.Destroy}
Destructor TPINGSend.Destroy;
destructor TPINGSend.Destroy;
begin
Sock.free;
inherited destroy;
FSock.Free;
inherited Destroy;
end;
{TPINGSend.ping}
function TPINGSend.ping(host:string):Boolean;
function TPINGSend.ReadPacket: Boolean;
var
PIPHeader:^TIPHeader;
IpHdrLen:Integer;
PIcmpEchoHeader:^TICMPEchoHeader;
n,x:integer;
x: Integer;
begin
Result:=False;
sock.connect(host,'0');
Buffer:=StringOfChar(#0,SizeOf(TICMPEchoHeader)+packetSize);
PIcmpEchoHeader := Pointer(Buffer);
With PIcmpEchoHeader^ Do Begin
i_type:=ICMP_ECHO;
i_code:=0;
i_CheckSum:=0;
id:=Random(32767);
i_Id:=id;
TimeStamp:=GetTick;
Inc(Seq);
i_Seq:=Seq;
for n:=Succ(SizeOf(TicmpEchoHeader)) to Length(Buffer) do
Buffer[n]:=#$55;
i_CheckSum:=CheckSum;
Result := FSock.CanRead(FTimeout);
if Result then
begin
x := FSock.WaitingData;
SetLength(FBuffer, x);
FSock.RecvBuffer(Pointer(FBuffer), x);
end;
sock.sendString(Buffer);
if sock.canread(timeout)
then begin
x:=sock.waitingdata;
setlength(Buffer,x);
sock.recvbuffer(Pointer(Buffer),x);
PIpHeader:=Pointer(Buffer);
IpHdrLen:=(PIpHeader^.VerLen and $0F)*4;
PIcmpEchoHeader:=@Buffer[IpHdrLen+1];
if (PIcmpEchoHeader^.i_type=ICMP_ECHOREPLY)
// Linux return from localhost ECHO instead ECHOREPLY???
or (PIcmpEchoHeader^.i_type=ICMP_ECHO) then
if (PIcmpEchoHeader^.i_id=id) then
begin
PingTime:=GetTick-PIcmpEchoHeader^.TimeStamp;
Result:=True;
end;
end;
end;
{TPINGSend.checksum}
function TPINGSend.checksum:integer;
type
tWordArray=Array[0..0] Of Word;
function TPINGSend.Ping(const Host: string): Boolean;
var
PWordArray:^TWordArray;
CkSum:Dword;
Num,Remain:Integer;
n:Integer;
IPHeadPtr: ^TIPHeader;
IpHdrLen: Integer;
IcmpEchoHeaderPtr: ^TICMPEchoHeader;
n: Integer;
t: Boolean;
begin
Num:=length(Buffer) div 2;
Remain:=length(Buffer) mod 2;
PWordArray:=Pointer(Buffer);
CkSum := 0;
for n:=0 to Num-1 do
CkSum:=CkSum+PWordArray^[n];
if Remain<>0 then
CkSum:=CkSum+ord(Buffer[Length(Buffer)]);
CkSum:=(CkSum shr 16)+(CkSum and $FFFF);
CkSum:=CkSum+(CkSum shr 16);
Result:=Word(not CkSum);
Result := False;
FSock.Connect(Host, '0');
FBuffer := StringOfChar(#0, SizeOf(TICMPEchoHeader) + FPacketSize);
IcmpEchoHeaderPtr := Pointer(FBuffer);
with IcmpEchoHeaderPtr^ do
begin
i_type := ICMP_ECHO;
i_code := 0;
i_CheckSum := 0;
FId := Random(32767);
i_Id := FId;
TimeStamp := GetTick;
Inc(FSeq);
i_Seq := FSeq;
for n := Succ(SizeOf(TIcmpEchoHeader)) to Length(FBuffer) do
FBuffer[n] := #$55;
i_CheckSum := CheckSum;
end;
FSock.SendString(FBuffer);
repeat
t := ReadPacket;
if not t then
break;
IPHeadPtr := Pointer(FBuffer);
IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
until IcmpEchoHeaderPtr^.i_type <> ICMP_ECHO;
//it discard sometimes possible 'echoes' of previosly sended packet...
if t then
if (IcmpEchoHeaderPtr^.i_type = ICMP_ECHOREPLY) then
if (IcmpEchoHeaderPtr^.i_id = FId) then
begin
FPingTime := GetTick - IcmpEchoHeaderPtr^.TimeStamp;
Result := True;
end;
end;
{TPINGSend.GetTick}
function TPINGSend.GetTick:cardinal;
function TPINGSend.Checksum: Integer;
type
TWordArray = array[0..0] of Word;
var
WordArr: ^TWordArray;
CkSum: DWORD;
Num, Remain: Integer;
n: Integer;
begin
{$IFDEF LINUX}
result:=clock div (CLOCKS_PER_SEC div 1000);
{$ELSE}
result:=windows.GetTickCount;
{$ENDIF}
Num := Length(FBuffer) div 2;
Remain := Length(FBuffer) mod 2;
WordArr := Pointer(FBuffer);
CkSum := 0;
for n := 0 to Num - 1 do
CkSum := CkSum + WordArr^[n];
if Remain <> 0 then
CkSum := CkSum + Ord(FBuffer[Length(FBuffer)]);
CkSum := (CkSum shr 16) + (CkSum and $FFFF);
CkSum := CkSum + (CkSum shr 16);
Result := Word(not CkSum);
end;
{$IFDEF LINUX}
function TPINGSend.GetTick: Cardinal;
var
Stamp: TTimeStamp;
begin
Stamp := DateTimeToTimeStamp(Now);
Result := Stamp.Time;
end;
{$ELSE}
function TPINGSend.GetTick: Cardinal;
begin
Result := Windows.GetTickCount;
end;
{$ENDIF}
{==============================================================================}
function PingHost(host:string):integer;
var
ping:TPINGSend;
function PingHost(const Host: string): Integer;
begin
ping:=TPINGSend.Create;
with TPINGSend.Create do
try
if ping.ping(host)
then Result:=ping.pingtime
else Result:=-1;
if Ping(Host) then
Result := PingTime
else
Result := -1;
finally
ping.Free;
Free;
end;
end;

349
pop3send.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.001.000 |
| Project : Delphree - Synapse | 001.001.001 |
|==============================================================================|
| Content: POP3 client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
@ -23,252 +23,239 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit POP3send;
interface
uses
Blcksock, sysutils, classes, SynaUtil, SynaCode;
SysUtils, Classes,
blcksock, SynaUtil, SynaCode;
const
CRLF=#13+#10;
cPop3Protocol = 'pop3';
type
TPOP3AuthType = (POP3AuthAll,POP3AuthLogin,POP3AuthAPOP);
TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
TPOP3Send = class
TPOP3Send = class(TObject)
private
Sock:TTCPBlockSocket;
function ReadResult(full:boolean):integer;
function Connect:Boolean;
FSock: TTCPBlockSocket;
FTimeout: Integer;
FPOP3Host: string;
FPOP3Port: string;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
FUsername: string;
FPassword: string;
FStatCount: Integer;
FStatSize: Integer;
FTimeStamp: string;
FAuthType: TPOP3AuthType;
function ReadResult(Full: Boolean): Integer;
function Connect: Boolean;
function AuthLogin: Boolean;
function AuthApop: Boolean;
public
timeout:integer;
POP3Host:string;
POP3Port:string;
ResultCode:integer;
ResultString:string;
FullResult:TStringList;
Username:string;
Password:string;
StatCount:integer;
StatSize:integer;
TimeStamp:string;
AuthType:TPOP3AuthType;
Constructor Create;
Destructor Destroy; override;
function AuthLogin:Boolean;
function AuthApop:Boolean;
function login:Boolean;
procedure logout;
function reset:Boolean;
function noop:Boolean;
function stat:Boolean;
function list(value:integer):Boolean;
function retr(value:integer):Boolean;
function dele(value:integer):Boolean;
function top(value,maxlines:integer):Boolean;
function uidl(value:integer):Boolean;
constructor Create;
destructor Destroy; override;
function Login: Boolean;
procedure Logout;
function Reset: Boolean;
function NoOp: Boolean;
function Stat: Boolean;
function List(Value: Integer): Boolean;
function Retr(Value: Integer): Boolean;
function Dele(Value: Integer): Boolean;
function Top(Value, Maxlines: Integer): Boolean;
function Uidl(Value: Integer): Boolean;
published
property Timeout: Integer read FTimeout Write FTimeout;
property POP3Host: string read FPOP3Host Write FPOP3Host;
property POP3Port: string read FPOP3Port Write FPOP3Port;
property ResultCode: Integer read FResultCode;
property ResultString: string read FResultString;
property FullResult: TStringList read FFullResult;
property Username: string read FUsername Write FUsername;
property Password: string read FPassword Write FPassword;
property StatCount: Integer read FStatCount;
property StatSize: Integer read FStatSize;
property TimeStamp: string read FTimeStamp;
property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
end;
implementation
{TPOP3Send.Create}
Constructor TPOP3Send.Create;
const
CRLF = #13#10;
constructor TPOP3Send.Create;
begin
inherited Create;
FullResult:=TStringList.create;
sock:=TTCPBlockSocket.create;
sock.CreateSocket;
timeout:=300000;
POP3host:='localhost';
POP3Port:='pop3';
Username:='';
Password:='';
StatCount:=0;
StatSize:=0;
AuthType:=POP3AuthAll;
FFullResult := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 300000;
FPOP3host := cLocalhost;
FPOP3Port := cPop3Protocol;
FUsername := '';
FPassword := '';
FStatCount := 0;
FStatSize := 0;
FAuthType := POP3AuthAll;
end;
{TPOP3Send.Destroy}
Destructor TPOP3Send.Destroy;
destructor TPOP3Send.Destroy;
begin
Sock.free;
FullResult.free;
inherited destroy;
FSock.Free;
FullResult.Free;
inherited Destroy;
end;
{TPOP3Send.ReadResult}
function TPOP3Send.ReadResult(full:boolean):integer;
function TPOP3Send.ReadResult(Full: Boolean): Integer;
var
s:string;
s: string;
begin
Result:=0;
FullResult.Clear;
s:=sock.recvstring(timeout);
if pos('+OK',s)=1
then result:=1;
ResultString:=s;
if full and (result=1)then
Result := 0;
FFullResult.Clear;
s := FSock.RecvString(FTimeout);
if Pos('+OK', s) = 1 then
Result := 1;
FResultString := s;
if Full and (Result = 1) then
repeat
s:=sock.recvstring(timeout);
if s='.'
then break;
FullResult.add(s);
until sock.LastError<>0;
ResultCode:=Result;
s := FSock.RecvString(FTimeout);
if s = '.' then
Break;
FFullResult.Add(s);
until FSock.LastError <> 0;
FResultCode := Result;
end;
{TPOP3Send.AuthLogin}
function TPOP3Send.AuthLogin:Boolean;
function TPOP3Send.AuthLogin: Boolean;
begin
Result:=false;
Sock.SendString('USER '+username+CRLF);
if readresult(false)<>1 then Exit;
Sock.SendString('PASS '+password+CRLF);
if readresult(false)<>1 then Exit;
Result:=True;
Result := False;
FSock.SendString('USER ' + FUserName + CRLF);
if ReadResult(False) <> 1 then
Exit;
FSock.SendString('PASS ' + FPassword + CRLF);
Result := ReadResult(False) = 1;
end;
{TPOP3Send.AuthAPop}
function TPOP3Send.AuthAPOP:Boolean;
function TPOP3Send.AuthAPOP: Boolean;
var
s:string;
s: string;
begin
Result:=false;
s:=StrToHex(MD5(TimeStamp+PassWord));
Sock.SendString('APOP '+username+' '+s+CRLF);
if readresult(false)<>1 then Exit;
Result:=True;
s := StrToHex(MD5(FTimeStamp + FPassWord));
FSock.SendString('APOP ' + FUserName + ' ' + s + CRLF);
Result := ReadResult(False) = 1;
end;
{TPOP3Send.Connect}
function TPOP3Send.Connect:Boolean;
function TPOP3Send.Connect: Boolean;
begin
//Do not call this function! It is calling by LOGIN method!
Result:=false;
StatCount:=0;
StatSize:=0;
sock.CloseSocket;
sock.LineBuffer:='';
sock.CreateSocket;
sock.Connect(POP3Host,POP3Port);
if sock.lasterror<>0 then Exit;
Result:=True;
// Do not call this function! It is calling by LOGIN method!
FStatCount := 0;
FStatSize := 0;
FSock.CloseSocket;
FSock.LineBuffer := '';
FSock.CreateSocket;
FSock.Connect(POP3Host, POP3Port);
Result := FSock.LastError = 0;
end;
{TPOP3Send.login}
function TPOP3Send.login:Boolean;
function TPOP3Send.Login: Boolean;
var
s,s1:string;
s, s1: string;
begin
Result:=False;
TimeStamp:='';
if not Connect then Exit;
if readresult(false)<>1 then Exit;
s:=separateright(Resultstring,'<');
if s<>Resultstring then
begin
s1:=separateleft(s,'>');
if s1<>s
then TimeStamp:='<'+s1+'>';
end;
result:=false;
if (TimeStamp<>'') and not(AuthType=POP3AuthLogin)
then result:=AuthApop;
if not(Result) and not(AuthType=POP3AuthAPOP)
then result:=AuthLogin;
Result := False;
FTimeStamp := '';
if not Connect then
Exit;
if ReadResult(False) <> 1 then
Exit;
s := SeparateRight(FResultString, '<');
if s <> FResultString then
begin
s1 := SeparateLeft(s, '>');
if s1 <> s then
FTimeStamp := '<' + s1 + '>';
end;
Result := False;
if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
Result := AuthApop;
if not Result and not (FAuthType = POP3AuthAPOP) then
Result := AuthLogin;
end;
{TPOP3Send.logout}
procedure TPOP3Send.logout;
procedure TPOP3Send.Logout;
begin
Sock.SendString('QUIT'+CRLF);
readresult(false);
Sock.CloseSocket;
FSock.SendString('QUIT' + CRLF);
ReadResult(False);
FSock.CloseSocket;
end;
{TPOP3Send.reset}
function TPOP3Send.reset:Boolean;
function TPOP3Send.Reset: Boolean;
begin
Result:=false;
Sock.SendString('RSET'+CRLF);
if readresult(false)<>1 then Exit;
Result:=True;
FSock.SendString('RSET' + CRLF);
Result := ReadResult(False) = 1;
end;
{TPOP3Send.noop}
function TPOP3Send.noop:Boolean;
function TPOP3Send.NoOp: Boolean;
begin
Result:=false;
Sock.SendString('NOOP'+CRLF);
if readresult(false)<>1 then Exit;
Result:=True;
FSock.SendString('NOOP' + CRLF);
Result := ReadResult(False) = 1;
end;
{TPOP3Send.stat}
function TPOP3Send.stat:Boolean;
function TPOP3Send.Stat: Boolean;
var
s:string;
s: string;
begin
Result:=false;
Sock.SendString('STAT'+CRLF);
if readresult(false)<>1 then Exit;
s:=separateright(ResultString,'+OK ');
StatCount:=StrToIntDef(separateleft(s,' '),0);
StatSize:=StrToIntDef(separateright(s,' '),0);
Result:=True;
Result := False;
FSock.SendString('STAT' + CRLF);
if ReadResult(False) <> 1 then
Exit;
s := SeparateRight(ResultString, '+OK ');
FStatCount := StrToIntDef(SeparateLeft(s, ' '), 0);
FStatSize := StrToIntDef(SeparateRight(s, ' '), 0);
Result := True;
end;
{TPOP3Send.list}
function TPOP3Send.list(value:integer):Boolean;
function TPOP3Send.List(Value: Integer): Boolean;
begin
Result:=false;
if value=0
then Sock.SendString('LIST'+CRLF)
else Sock.SendString('LIST '+IntToStr(value)+CRLF);
if readresult(value=0)<>1 then Exit;
Result:=True;
if Value = 0 then
FSock.SendString('LIST' + CRLF)
else
FSock.SendString('LIST ' + IntToStr(Value) + CRLF);
Result := ReadResult(Value = 0) = 1;
end;
{TPOP3Send.retr}
function TPOP3Send.retr(value:integer):Boolean;
function TPOP3Send.Retr(Value: Integer): Boolean;
begin
Result:=false;
Sock.SendString('RETR '+IntToStr(value)+CRLF);
if readresult(true)<>1 then Exit;
Result:=True;
FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
Result := ReadResult(True) = 1;
end;
{TPOP3Send.dele}
function TPOP3Send.dele(value:integer):Boolean;
function TPOP3Send.Dele(Value: Integer): Boolean;
begin
Result:=false;
Sock.SendString('DELE '+IntToStr(value)+CRLF);
if readresult(false)<>1 then Exit;
Result:=True;
FSock.SendString('DELE ' + IntToStr(Value) + CRLF);
Result := ReadResult(False) = 1;
end;
{TPOP3Send.top}
function TPOP3Send.top(value,maxlines:integer):Boolean;
function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
begin
Result:=false;
Sock.SendString('TOP '+IntToStr(value)+' '+IntToStr(maxlines)+CRLF);
if readresult(true)<>1 then Exit;
Result:=True;
FSock.SendString('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines) + CRLF);
Result := ReadResult(True) = 1;
end;
{TPOP3Send.uidl}
function TPOP3Send.uidl(value:integer):Boolean;
function TPOP3Send.Uidl(Value: Integer): Boolean;
begin
Result:=false;
if value=0
then Sock.SendString('UIDL'+CRLF)
else Sock.SendString('UIDL '+IntToStr(value)+CRLF);
if readresult(value=0)<>1 then Exit;
Result:=True;
if Value = 0 then
FSock.SendString('UIDL' + CRLF)
else
FSock.SendString('UIDL ' + IntToStr(Value) + CRLF);
Result := ReadResult(Value = 0) = 1;
end;
{==============================================================================}
end.

806
smtpsend.pas
View File

@ -1,11 +1,11 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.001.002 |
| Project : Delphree - Synapse | 002.001.003 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are Subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
@ -23,485 +23,481 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit SMTPsend;
interface
uses
Blcksock, sysutils, classes, SynaUtil, SynaCode;
SysUtils, Classes,
blcksock, SynaUtil, SynaCode;
const
CRLF=#13+#10;
cSmtpProtocol = 'smtp';
type
TSMTPSend = class
TSMTPSend = class(TObject)
private
Sock:TTCPBlockSocket;
procedure EnhancedCode(value:string);
function ReadResult:integer;
FSock: TTCPBlockSocket;
FTimeout: Integer;
FSMTPHost: string;
FSMTPPort: string;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
FESMTPcap: TStringList;
FESMTP: Boolean;
FUsername: string;
FPassword: string;
FAuthDone: Boolean;
FESMTPSize: Boolean;
FMaxSize: Integer;
FEnhCode1: Integer;
FEnhCode2: Integer;
FEnhCode3: Integer;
FSystemName: string;
procedure EnhancedCode(const Value: string);
function ReadResult: Integer;
function AuthLogin: Boolean;
function AuthCram: Boolean;
function Helo: Boolean;
function Ehlo: Boolean;
function Connect: Boolean;
public
timeout:integer;
SMTPHost:string;
SMTPPort:string;
ResultCode:integer;
ResultString:string;
FullResult:TStringList;
ESMTPcap:TStringList;
ESMTP:boolean;
Username:string;
Password:string;
AuthDone:boolean;
ESMTPSize:boolean;
MaxSize:integer;
EnhCode1:integer;
EnhCode2:integer;
EnhCode3:integer;
SystemName:string;
Constructor Create;
Destructor Destroy; override;
function AuthLogin:Boolean;
function AuthCram:Boolean;
function Connect:Boolean;
function Helo:Boolean;
function Ehlo:Boolean;
function login:Boolean;
procedure logout;
function reset:Boolean;
function noop:Boolean;
function mailfrom(Value:string; size:integer):Boolean;
function mailto(Value:string):Boolean;
function maildata(Value:Tstrings):Boolean;
function etrn(Value:string):Boolean;
function verify(Value:string):Boolean;
function EnhCodeString:string;
function FindCap(value:string):string;
constructor Create;
destructor Destroy; override;
function Login: Boolean;
procedure Logout;
function Reset: Boolean;
function NoOp: Boolean;
function MailFrom(const Value: string; Size: Integer): Boolean;
function MailTo(const Value: string): Boolean;
function MailData(const Value: Tstrings): Boolean;
function Etrn(const Value: string): Boolean;
function Verify(const Value: string): Boolean;
function EnhCodeString: string;
function FindCap(const Value: string): string;
published
property Timeout: Integer read FTimeout Write FTimeout;
property SMTPHost: string read FSMTPHost Write FSMTPHost;
property SMTPPort: string read FSMTPPort Write FSMTPPort;
property ResultCode: Integer read FResultCode;
property ResultString: string read FResultString;
property FullResult: TStringList read FFullResult;
property ESMTPcap: TStringList read FESMTPcap;
property ESMTP: Boolean read FESMTP;
property Username: string read FUsername Write FUsername;
property Password: string read FPassword Write FPassword;
property AuthDone: Boolean read FAuthDone;
property ESMTPSize: Boolean read FESMTPSize;
property MaxSize: Integer read FMaxSize;
property EnhCode1: Integer read FEnhCode1;
property EnhCode2: Integer read FEnhCode2;
property EnhCode3: Integer read FEnhCode3;
property SystemName: string read FSystemName Write FSystemName;
end;
function SendtoRaw
(mailfrom,mailto,SMTPHost:string;maildata:TStrings;Username,Password:string):Boolean;
function Sendto
(mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings):Boolean;
function SendtoEx
(mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings;Username,Password:string):Boolean;
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings): Boolean;
function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
implementation
{TSMTPSend.Create}
Constructor TSMTPSend.Create;
const
CRLF = #13#10;
constructor TSMTPSend.Create;
begin
inherited Create;
FullResult:=TStringList.create;
ESMTPcap:=TStringList.create;
sock:=TTCPBlockSocket.create;
sock.CreateSocket;
timeout:=300000;
SMTPhost:='localhost';
SMTPPort:='smtp';
Username:='';
Password:='';
SystemName:=sock.localname;
FFullResult := TStringList.Create;
FESMTPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 300000;
FSMTPhost := cLocalhost;
FSMTPPort := cSmtpProtocol;
FUsername := '';
FPassword := '';
FSystemName := FSock.LocalName;
end;
{TSMTPSend.Destroy}
Destructor TSMTPSend.Destroy;
destructor TSMTPSend.Destroy;
begin
Sock.free;
ESMTPcap.free;
FullResult.free;
inherited destroy;
FSock.Free;
FESMTPcap.Free;
FFullResult.Free;
inherited Destroy;
end;
{TSMTPSend.EnhancedCode}
procedure TSMTPSend.EnhancedCode (value:string);
procedure TSMTPSend.EnhancedCode(const Value: string);
var
s,t:string;
e1,e2,e3:integer;
s, t: string;
e1, e2, e3: Integer;
begin
EnhCode1:=0;
EnhCode2:=0;
EnhCode3:=0;
s:=copy(value,5,length(value)-4);
t:=separateleft(s,'.');
s:=separateright(s,'.');
if t='' then exit;
if length(t)>1 then exit;
e1:=strtointdef(t,0);
if e1=0 then exit;
t:=separateleft(s,'.');
s:=separateright(s,'.');
if t='' then exit;
if length(t)>3 then exit;
e2:=strtointdef(t,0);
t:=separateleft(s,' ');
if t='' then exit;
if length(t)>3 then exit;
e3:=strtointdef(t,0);
EnhCode1:=e1;
EnhCode2:=e2;
EnhCode3:=e3;
FEnhCode1 := 0;
FEnhCode2 := 0;
FEnhCode3 := 0;
s := Copy(Value, 5, Length(Value) - 4);
t := SeparateLeft(s, '.');
s := SeparateRight(s, '.');
if t = '' then
Exit;
if Length(t) > 1 then
Exit;
e1 := StrToIntDef(t, 0);
if e1 = 0 then
Exit;
t := SeparateLeft(s, '.');
s := SeparateRight(s, '.');
if t = '' then
Exit;
if Length(t) > 3 then
Exit;
e2 := StrToIntDef(t, 0);
t := SeparateLeft(s, ' ');
if t = '' then
Exit;
if Length(t) > 3 then
Exit;
e3 := StrToIntDef(t, 0);
FEnhCode1 := e1;
FEnhCode2 := e2;
FEnhCode3 := e3;
end;
{TSMTPSend.ReadResult}
function TSMTPSend.ReadResult:integer;
function TSMTPSend.ReadResult: Integer;
var
s:string;
s: string;
begin
Result:=0;
FullResult.Clear;
Result := 0;
FFullResult.Clear;
repeat
s:=sock.recvstring(timeout);
ResultString:=s;
FullResult.add(s);
if sock.LastError<>0 then
break;
until pos('-',s)<>4;
s:=FullResult[0];
if Length(s)>=3 then Result:=Strtointdef(Copy(s,1,3),0);
ResultCode:=Result;
s := FSock.RecvString(FTimeout);
FResultString := s;
FFullResult.Add(s);
if FSock.LastError <> 0 then
Break;
until Pos('-', s) <> 4;
s := FFullResult[0];
if Length(s) >= 3 then
Result := StrToIntDef(Copy(s, 1, 3), 0);
FResultCode := Result;
EnhancedCode(s);
end;
{TSMTPSend.AuthLogin}
function TSMTPSend.AuthLogin:Boolean;
function TSMTPSend.AuthLogin: Boolean;
begin
Result:=false;
Sock.SendString('AUTH LOGIN'+CRLF);
if readresult<>334 then Exit;
Sock.SendString(Encodebase64(username)+CRLF);
if readresult<>334 then Exit;
Sock.SendString(Encodebase64(password)+CRLF);
if readresult<>235 then Exit;
Result:=True;
Result := False;
FSock.SendString('AUTH LOGIN' + CRLF);
if ReadResult <> 334 then
Exit;
FSock.SendString(EncodeBase64(FUsername) + CRLF);
if ReadResult <> 334 then
Exit;
FSock.SendString(EncodeBase64(FPassword) + CRLF);
Result := ReadResult = 235;
end;
{TSMTPSend.AuthCram}
function TSMTPSend.AuthCram:Boolean;
function TSMTPSend.AuthCram: Boolean;
var
s:string;
s: string;
begin
Result:=false;
Sock.SendString('AUTH CRAM-MD5'+CRLF);
if readresult<>334 then Exit;
s:=copy(ResultString,5,length(ResultString)-4);
s:=DecodeBase64(s);
s:=HMAC_MD5(s,password);
s:=Username+' '+strtohex(s);
Sock.SendString(Encodebase64(s)+CRLF);
if readresult<>235 then Exit;
Result:=True;
Result := False;
FSock.SendString('AUTH CRAM-MD5' + CRLF);
if ReadResult <> 334 then
Exit;
s := Copy(FResultString, 5, Length(FResultString) - 4);
s := DecodeBase64(s);
s := HMAC_MD5(s, FPassword);
s := FUsername + ' ' + StrToHex(s);
FSock.SendString(EncodeBase64(s) + CRLF);
Result := ReadResult = 235;
end;
{TSMTPSend.Connect}
function TSMTPSend.Connect:Boolean;
function TSMTPSend.Connect: Boolean;
begin
Result:=false;
sock.CloseSocket;
sock.CreateSocket;
sock.Connect(SMTPHost,SMTPPort);
if sock.lasterror<>0 then Exit;
Result:=True;
FSock.CloseSocket;
FSock.CreateSocket;
FSock.Connect(FSMTPHost, FSMTPPort);
Result := FSock.LastError = 0;
end;
{TSMTPSend.Helo}
function TSMTPSend.Helo:Boolean;
function TSMTPSend.Helo: Boolean;
var
x:integer;
x: Integer;
begin
Result:=false;
Sock.SendString('HELO '+SystemName+CRLF);
x:=ReadResult;
if (x<250) or (x>259) then Exit;
Result:=True;
FSock.SendString('HELO ' + FSystemName + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
{TSMTPSend.Ehlo}
function TSMTPSend.Ehlo:Boolean;
function TSMTPSend.Ehlo: Boolean;
var
x:integer;
x: Integer;
begin
Result:=false;
Sock.SendString('EHLO '+SystemName+CRLF);
x:=ReadResult;
if (x<250) or (x>259) then Exit;
Result:=True;
FSock.SendString('EHLO ' + FSystemName + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
{TSMTPSend.login}
function TSMTPSend.login:Boolean;
function TSMTPSend.Login: Boolean;
var
n:integer;
auths:string;
s:string;
n: Integer;
auths: string;
s: string;
begin
Result:=False;
ESMTP:=true;
AuthDone:=false;
ESMTPcap.clear;
ESMTPSize:=false;
MaxSize:=0;
if not Connect then Exit;
if readresult<>220 then Exit;
Result := False;
FESMTP := True;
FAuthDone := False;
FESMTPcap.clear;
FESMTPSize := False;
FMaxSize := 0;
if not Connect then
Exit;
if ReadResult <> 220 then
Exit;
if not Ehlo then
begin
FESMTP := False;
if not Helo then
Exit;
end;
Result := True;
if FESMTP then
begin
for n := 1 to FFullResult.Count - 1 do
FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
if not ((FUsername = '') and (FPassword = '')) then
begin
ESMTP:=false;
if not Helo then exit;
end;
Result:=True;
if ESMTP then
begin
for n:=1 to FullResult.count-1 do
ESMTPcap.add(Copy(FullResult[n],5,length(Fullresult[n])-4));
if not ((Username='') and (Password='')) then
begin
s:=FindCap('AUTH ');
if s=''
then s:=FindCap('AUTH=');
auths:=uppercase(s);
if s<>'' then
begin
if pos('CRAM-MD5',auths)>0
then AuthDone:=AuthCram;
if (pos('LOGIN',auths)>0) and (not authDone)
then AuthDone:=AuthLogin;
end;
if AuthDone
then Ehlo;
end;
s:=FindCap('SIZE');
if s<>'' then
begin
ESMTPsize:=true;
MaxSize:=StrToIntDef(copy(s,6,length(s)-5),0);
end;
end;
end;
{TSMTPSend.logout}
procedure TSMTPSend.logout;
begin
Sock.SendString('QUIT'+CRLF);
readresult;
Sock.CloseSocket;
end;
{TSMTPSend.reset}
function TSMTPSend.reset:Boolean;
begin
Result:=false;
Sock.SendString('RSET'+CRLF);
if readresult<>250 then Exit;
Result:=True;
end;
{TSMTPSend.noop}
function TSMTPSend.noop:Boolean;
begin
Result:=false;
Sock.SendString('NOOP'+CRLF);
if readresult<>250 then Exit;
Result:=True;
end;
{TSMTPSend.mailfrom}
function TSMTPSend.mailfrom(Value:string; size:integer):Boolean;
var
s:string;
begin
Result:=false;
s:='MAIL FROM:<'+Value+'>';
if ESMTPsize and (size>0)
then s:=s+' SIZE='+IntToStr(size);
Sock.SendString(s+CRLF);
if readresult<>250 then Exit;
Result:=True;
end;
{TSMTPSend.mailto}
function TSMTPSend.mailto(Value:string):Boolean;
begin
Result:=false;
Sock.SendString('RCPT TO:<'+Value+'>'+CRLF);
if readresult<>250 then Exit;
Result:=True;
end;
{TSMTPSend.maildata}
function TSMTPSend.maildata(Value:Tstrings):Boolean;
var
n:integer;
s:string;
begin
Result:=false;
Sock.SendString('DATA'+CRLF);
if readresult<>354 then Exit;
for n:=0 to Value.Count-1 do
begin
s:=value[n];
if Length(s)>=1 then
if s[1]='.' then s:='.'+s;
Sock.SendString(s+CRLF);
end;
Sock.SendString('.'+CRLF);
if readresult<>250 then Exit;
Result:=True;
end;
{TSMTPSend.etrn}
function TSMTPSend.etrn(Value:string):Boolean;
var
x:integer;
begin
Result:=false;
Sock.SendString('ETRN '+Value+CRLF);
x:=ReadResult;
if (x<250) or (x>259) then Exit;
Result:=True;
end;
{TSMTPSend.verify}
function TSMTPSend.verify(Value:string):Boolean;
var
x:integer;
begin
Result:=false;
Sock.SendString('VRFY '+Value+CRLF);
x:=ReadResult;
if (x<250) or (x>259) then Exit;
Result:=True;
end;
{TSMTPSend.EnhCodeString}
function TSMTPSend.EnhCodeString:string;
var
s,t:string;
begin
s:=inttostr(EnhCode2)+'.'+inttostr(EnhCode3);
t:='';
if s='0.0' then t:='Other undefined Status';
if s='1.0' then t:='Other address status';
if s='1.1' then t:='Bad destination mailbox address';
if s='1.2' then t:='Bad destination system address';
if s='1.3' then t:='Bad destination mailbox address syntax';
if s='1.4' then t:='Destination mailbox address ambiguous';
if s='1.5' then t:='Destination mailbox address valid';
if s='1.6' then t:='Mailbox has moved';
if s='1.7' then t:='Bad sender''s mailbox address syntax';
if s='1.8' then t:='Bad sender''s system address';
if s='2.0' then t:='Other or undefined mailbox status';
if s='2.1' then t:='Mailbox disabled, not accepting messages';
if s='2.2' then t:='Mailbox full';
if s='2.3' then t:='Message length exceeds administrative limit';
if s='2.4' then t:='Mailing list expansion problem';
if s='3.0' then t:='Other or undefined mail system status';
if s='3.1' then t:='Mail system full';
if s='3.2' then t:='System not accepting network messages';
if s='3.3' then t:='System not capable of selected features';
if s='3.4' then t:='Message too big for system';
if s='3.5' then t:='System incorrectly configured';
if s='4.0' then t:='Other or undefined network or routing status';
if s='4.1' then t:='No answer from host';
if s='4.2' then t:='Bad connection';
if s='4.3' then t:='Routing server failure';
if s='4.4' then t:='Unable to route';
if s='4.5' then t:='Network congestion';
if s='4.6' then t:='Routing loop detected';
if s='4.7' then t:='Delivery time expired';
if s='5.0' then t:='Other or undefined protocol status';
if s='5.1' then t:='Invalid command';
if s='5.2' then t:='Syntax error';
if s='5.3' then t:='Too many recipients';
if s='5.4' then t:='Invalid command arguments';
if s='5.5' then t:='Wrong protocol version';
if s='6.0' then t:='Other or undefined media error';
if s='6.1' then t:='Media not supported';
if s='6.2' then t:='Conversion required and prohibited';
if s='6.3' then t:='Conversion required but not supported';
if s='6.4' then t:='Conversion with loss performed';
if s='6.5' then t:='Conversion failed';
if s='7.0' then t:='Other or undefined security status';
if s='7.1' then t:='Delivery not authorized, message refused';
if s='7.2' then t:='Mailing list expansion prohibited';
if s='7.3' then t:='Security conversion required but not possible';
if s='7.4' then t:='Security features not supported';
if s='7.5' then t:='Cryptographic failure';
if s='7.6' then t:='Cryptographic algorithm not supported';
if s='7.7' then t:='Message integrity failure';
s:='???-';
if EnhCode1=2 then s:='Success-';
if EnhCode1=4 then s:='Persistent Transient Failure-';
if EnhCode1=5 then s:='Permanent Failure-';
result:=s+t;
end;
{TSMTPSend.FindCap}
function TSMTPSend.FindCap(value:string):string;
var
n:integer;
s:string;
begin
s:=uppercase(value);
result:='';
for n:=0 to ESMTPcap.count-1 do
if pos(s,uppercase(ESMTPcap[n]))=1 then
s := FindCap('AUTH ');
if s = '' then
s := FindCap('AUTH=');
auths := UpperCase(s);
if s <> '' then
begin
result:=ESMTPcap[n];
break;
if Pos('CRAM-MD5', auths) > 0 then
FAuthDone := AuthCram;
if (Pos('LOGIN', auths) > 0) and (not FauthDone) then
FAuthDone := AuthLogin;
end;
if FAuthDone then
Ehlo;
end;
s := FindCap('SIZE');
if s <> '' then
begin
FESMTPsize := True;
FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0);
end;
end;
end;
procedure TSMTPSend.Logout;
begin
FSock.SendString('QUIT' + CRLF);
ReadResult;
FSock.CloseSocket;
end;
function TSMTPSend.Reset: Boolean;
begin
FSock.SendString('RSET' + CRLF);
Result := ReadResult = 250;
end;
function TSMTPSend.NoOp: Boolean;
begin
FSock.SendString('NOOP' + CRLF);
Result := ReadResult = 250;
end;
function TSMTPSend.MailFrom(const Value: string; Size: Integer): Boolean;
var
s: string;
begin
s := 'MAIL FROM:<' + Value + '>';
if FESMTPsize and (Size > 0) then
s := s + ' SIZE=' + IntToStr(Size);
FSock.SendString(s + CRLF);
Result := ReadResult = 250;
end;
function TSMTPSend.MailTo(const Value: string): Boolean;
begin
FSock.SendString('RCPT TO:<' + Value + '>' + CRLF);
Result := ReadResult = 250;
end;
function TSMTPSend.MailData(const Value: TStrings): Boolean;
var
n: Integer;
s: string;
begin
Result := False;
FSock.SendString('DATA' + CRLF);
if ReadResult <> 354 then
Exit;
for n := 0 to Value.Count - 1 do
begin
s := Value[n];
if Length(s) >= 1 then
if s[1] = '.' then
s := '.' + s;
FSock.SendString(s + CRLF);
end;
FSock.SendString('.' + CRLF);
Result := ReadResult = 250;
end;
function TSMTPSend.Etrn(const Value: string): Boolean;
var
x: Integer;
begin
FSock.SendString('ETRN ' + Value + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.Verify(const Value: string): Boolean;
var
x: Integer;
begin
FSock.SendString('VRFY ' + Value + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.EnhCodeString: string;
var
s, t: string;
begin
s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3);
t := '';
if s = '0.0' then t := 'Other undefined Status';
if s = '1.0' then t := 'Other address status';
if s = '1.1' then t := 'Bad destination mailbox address';
if s = '1.2' then t := 'Bad destination system address';
if s = '1.3' then t := 'Bad destination mailbox address syntax';
if s = '1.4' then t := 'Destination mailbox address ambiguous';
if s = '1.5' then t := 'Destination mailbox address valid';
if s = '1.6' then t := 'Mailbox has moved';
if s = '1.7' then t := 'Bad sender''s mailbox address syntax';
if s = '1.8' then t := 'Bad sender''s system address';
if s = '2.0' then t := 'Other or undefined mailbox status';
if s = '2.1' then t := 'Mailbox disabled, not accepting messages';
if s = '2.2' then t := 'Mailbox full';
if s = '2.3' then t := 'Message Length exceeds administrative limit';
if s = '2.4' then t := 'Mailing list expansion problem';
if s = '3.0' then t := 'Other or undefined mail system status';
if s = '3.1' then t := 'Mail system full';
if s = '3.2' then t := 'System not accepting network messages';
if s = '3.3' then t := 'System not capable of selected features';
if s = '3.4' then t := 'Message too big for system';
if s = '3.5' then t := 'System incorrectly configured';
if s = '4.0' then t := 'Other or undefined network or routing status';
if s = '4.1' then t := 'No answer from host';
if s = '4.2' then t := 'Bad connection';
if s = '4.3' then t := 'Routing server failure';
if s = '4.4' then t := 'Unable to route';
if s = '4.5' then t := 'Network congestion';
if s = '4.6' then t := 'Routing loop detected';
if s = '4.7' then t := 'Delivery time expired';
if s = '5.0' then t := 'Other or undefined protocol status';
if s = '5.1' then t := 'Invalid command';
if s = '5.2' then t := 'Syntax error';
if s = '5.3' then t := 'Too many recipients';
if s = '5.4' then t := 'Invalid command arguments';
if s = '5.5' then t := 'Wrong protocol version';
if s = '6.0' then t := 'Other or undefined media error';
if s = '6.1' then t := 'Media not supported';
if s = '6.2' then t := 'Conversion required and prohibited';
if s = '6.3' then t := 'Conversion required but not supported';
if s = '6.4' then t := 'Conversion with loss performed';
if s = '6.5' then t := 'Conversion failed';
if s = '7.0' then t := 'Other or undefined security status';
if s = '7.1' then t := 'Delivery not authorized, message refused';
if s = '7.2' then t := 'Mailing list expansion prohibited';
if s = '7.3' then t := 'Security conversion required but not possible';
if s = '7.4' then t := 'Security features not supported';
if s = '7.5' then t := 'Cryptographic failure';
if s = '7.6' then t := 'Cryptographic algorithm not supported';
if s = '7.7' then t := 'Message integrity failure';
s := '???-';
if FEnhCode1 = 2 then s := 'Success-';
if FEnhCode1 = 4 then s := 'Persistent Transient Failure-';
if FEnhCode1 = 5 then s := 'Permanent Failure-';
Result := s + t;
end;
function TSMTPSend.FindCap(const Value: string): string;
var
n: Integer;
s: string;
begin
s := UpperCase(Value);
Result := '';
for n := 0 to FESMTPcap.Count - 1 do
if Pos(s, UpperCase(FESMTPcap[n])) = 1 then
begin
Result := FESMTPcap[n];
Break;
end;
end;
{==============================================================================}
function SendtoRaw (mailfrom,mailto,SMTPHost:string;maildata:TStrings;
Username,Password:string):Boolean;
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
var
SMTP:TSMTPSend;
size:integer;
SMTP: TSMTPSend;
begin
Result:=False;
SMTP:=TSMTPSend.Create;
Result := False;
SMTP := TSMTPSend.Create;
try
SMTP.SMTPHost:=SMTPHost;
SMTP.Username:=Username;
SMTP.Password:=Password;
if not SMTP.login then Exit;
size:=length(maildata.text);
if not SMTP.mailfrom(mailfrom,size) then Exit;
if not SMTP.mailto(mailto) then Exit;
if not SMTP.maildata(Maildata) then Exit;
SMTP.logout;
Result:=True;
SMTP.SMTPHost := SMTPHost;
SMTP.Username := Username;
SMTP.Password := Password;
if SMTP.Login then
begin
if SMTP.MailFrom(MailFrom, Length(MailData.Text)) then
if SMTP.MailTo(MailTo) then
if SMTP.MailData(MailData) then
Result := True;
SMTP.Logout;
end;
finally
SMTP.Free;
end;
end;
function SendtoEx (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings;
Username,Password:string):Boolean;
function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
var
t:TStrings;
t: TStrings;
begin
// Result:=False;
t:=TStringList.Create;
t := TStringList.Create;
try
t.assign(Maildata);
t.Insert(0,'');
t.Insert(0,'x-mailer: Synapse - Delphi 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);
t.Assign(MailData);
t.Insert(0, '');
t.Insert(0, 'x-mailer: Synapse - Delphi 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;
end;
end;
function Sendto
(mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings):Boolean;
function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings): Boolean;
begin
result:=SendToEx(mailfrom,mailto,subject,SMTPHost,maildata,'','');
Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', '');
end;
end.

439
snmpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.003.001 |
| Project : Delphree - Synapse | 002.003.002 |
|==============================================================================|
| Content: SNMP client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
@ -25,201 +25,213 @@
|==============================================================================}
{$Q-}
{$WEAKPACKAGEUNIT ON}
unit SNMPSend;
interface
uses
BlckSock, synautil, classes, sysutils, ASN1Util;
Classes, SysUtils,
blckSock, SynaUtil, ASN1Util;
const
cSnmpProtocol = '161';
//PDU type
PDUGetRequest=$a0;
PDUGetNextRequest=$a1;
PDUGetResponse=$a2;
PDUSetRequest=$a3;
PDUTrap=$a4;
PDUGetRequest = $A0;
PDUGetNextRequest = $A1;
PDUGetResponse = $A2;
PDUSetRequest = $A3;
PDUTrap = $A4;
//errors
ENoError=0;
ETooBig=1;
ENoSuchName=2;
EBadValue=3;
EReadOnly=4;
EGenErr=5;
ENoError = 0;
ETooBig = 1;
ENoSuchName = 2;
EBadValue = 3;
EReadOnly = 4;
EGenErr = 5;
type
TSNMPMib = class
OID: string;
Value: string;
ValueType: integer;
end;
TSNMPRec=class(TObject)
public
version:integer;
community:string;
PDUType:integer;
ID:integer;
ErrorStatus:integer;
ErrorIndex:integer;
SNMPMibList: TList;
constructor Create;
destructor Destroy; override;
function DecodeBuf(Buffer:string):boolean;
function EncodeBuf:string;
procedure Clear;
procedure MIBAdd(MIB,Value:string; ValueType:integer);
procedure MIBdelete(Index:integer);
function MIBGet(MIB:string):string;
end;
TSNMPSend=class(TObject)
TSNMPMib = class(TObject)
private
Sock:TUDPBlockSocket;
Buffer:string;
FOID: string;
FValue: string;
FValueType: Integer;
published
property OID: string read FOID Write FOID;
property Value: string read FValue Write FValue;
property ValueType: Integer read FValueType Write FValueType;
end;
TSNMPRec = class(TObject)
private
FVersion: Integer;
FCommunity: string;
FPDUType: Integer;
FID: Integer;
FErrorStatus: Integer;
FErrorIndex: Integer;
FSNMPMibList: TList;
public
Timeout:integer;
Host:string;
HostIP:string;
Query:TSNMPrec;
Reply:TSNMPrec;
constructor Create;
destructor Destroy; override;
function DoIt:boolean;
end;
function DecodeBuf(const Buffer: string): Boolean;
function EncodeBuf: string;
procedure Clear;
procedure MIBAdd(const MIB, Value: string; ValueType: Integer);
procedure MIBDelete(Index: Integer);
function MIBGet(const MIB: string): string;
published
property Version: Integer read FVersion Write FVersion;
property Community: string read FCommunity Write FCommunity;
property PDUType: Integer read FPDUType Write FPDUType;
property ID: Integer read FID Write FID;
property ErrorStatus: Integer read FErrorStatus Write FErrorStatus;
property ErrorIndex: Integer read FErrorIndex Write FErrorIndex;
property SNMPMibList: TList read FSNMPMibList;
end;
function SNMPget (Oid, Community, SNMPHost:string; var Value:string):Boolean;
function SNMPSet (Oid, Community, SNMPHost, Value: string; ValueType: integer): boolean;
TSNMPSend = class(TObject)
private
FSock: TUDPBlockSocket;
FBuffer: string;
FTimeout: Integer;
FHost: string;
FHostIP: string;
FQuery: TSNMPRec;
FReply: TSNMPRec;
public
constructor Create;
destructor Destroy; override;
function DoIt: Boolean;
published
property Timeout: Integer read FTimeout Write FTimeout;
property Host: string read FHost Write FHost;
property HostIP: string read FHostIP;
property Query: TSNMPRec read FQuery;
property Reply: TSNMPRec read FReply;
end;
function SNMPGet(const Oid, Community, SNMPHost: string;
var Value: string): Boolean;
function SNMPSet(const Oid, Community, SNMPHost, Value: string;
ValueType: Integer): Boolean;
implementation
{==============================================================================}
{TSNMPRec.Create}
constructor TSNMPRec.Create;
begin
inherited create;
SNMPMibList := TList.create;
id:=1;
inherited Create;
FSNMPMibList := TList.Create;
id := 1;
end;
{TSNMPRec.Destroy}
destructor TSNMPRec.Destroy;
var
i:integer;
i: Integer;
begin
for i := 0 to SNMPMibList.count - 1 do
TSNMPMib(SNMPMibList[i]).Free;
SNMPMibList.free;
inherited destroy;
for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Free;
inherited Destroy;
end;
{TSNMPRec.DecodeBuf}
function TSNMPRec.DecodeBuf(Buffer:string):boolean;
function TSNMPRec.DecodeBuf(const Buffer: string): Boolean;
var
Pos:integer;
endpos:integer;
sm,sv:string;
svt: integer;
Pos: Integer;
EndPos: Integer;
sm, sv: string;
Svt: Integer;
begin
result:=false;
if length(buffer)<2
then exit;
if (ord(buffer[1]) and $20)=0
then exit;
Pos:=2;
Endpos:=ASNDecLen(Pos,buffer);
if length(buffer)<(Endpos+2)
then exit;
Self.version:=StrToIntDef(ASNItem(Pos,buffer,svt),0);
Self.community:=ASNItem(Pos,buffer,svt);
Self.PDUType:=StrToIntDef(ASNItem(Pos,buffer,svt),0);
Self.ID:=StrToIntDef(ASNItem(Pos,buffer,svt),0);
Self.ErrorStatus:=StrToIntDef(ASNItem(Pos,buffer,svt),0);
Self.ErrorIndex:=StrToIntDef(ASNItem(Pos,buffer,svt),0);
ASNItem(Pos,buffer,svt);
while Pos<Endpos do
begin
ASNItem(Pos,buffer,svt);
Sm:=ASNItem(Pos,buffer,svt);
Sv:=ASNItem(Pos,buffer,svt);
Self.MIBadd(sm,sv, svt);
end;
result:=true;
Result := False;
if Length(Buffer) < 2 then
Exit;
if (Ord(Buffer[1]) and $20) = 0 then
Exit;
Pos := 2;
EndPos := ASNDecLen(Pos, Buffer);
if Length(Buffer) < (EndPos + 2) then
Exit;
Self.FVersion := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FCommunity := ASNItem(Pos, Buffer, Svt);
Self.FPDUType := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
ASNItem(Pos, Buffer, Svt);
while Pos < EndPos do
begin
ASNItem(Pos, Buffer, Svt);
Sm := ASNItem(Pos, Buffer, Svt);
Sv := ASNItem(Pos, Buffer, Svt);
Self.MIBAdd(sm, sv, Svt);
end;
Result := True;
end;
{TSNMPRec.EncodeBuf}
function TSNMPRec.EncodeBuf:string;
function TSNMPRec.EncodeBuf: string;
var
data,s:string;
data, s: string;
SNMPMib: TSNMPMib;
n:integer;
n: Integer;
begin
data:='';
for n:=0 to SNMPMibList.Count-1 do
begin
SNMPMib := SNMPMibList[n];
case (SNMPMib.ValueType) of
ASN1_INT:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID)
+ASNObject(ASNEncInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID)
+ASNObject(ASNEncUInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
ASN1_OBJID:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(MibToID(SNMPMib.Value),SNMPMib.ValueType);
end;
ASN1_IPADDR:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(IPToID(SNMPMib.Value),SNMPMib.ValueType);
end;
ASN1_NULL:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject('',ASN1_NULL);
end;
else
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(SNMPMib.Value,SNMPMib.ValueType);
end;
data := data + ASNObject(s, ASN1_SEQ);
data := '';
for n := 0 to FSNMPMibList.Count - 1 do
begin
SNMPMib := FSNMPMibList[n];
case SNMPMib.ValueType of
ASN1_INT:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_OBJID:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_IPADDR:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_NULL:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject('', ASN1_NULL);
else
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(SNMPMib.Value, SNMPMib.ValueType);
end;
data:=ASNObject(data,ASN1_SEQ);
data:=ASNObject(ASNEncInt(Self.ID),ASN1_INT)
+ASNObject(ASNEncInt(Self.ErrorStatus),ASN1_INT)
+ASNObject(ASNEncInt(Self.ErrorIndex),ASN1_INT)
+data;
data:=ASNObject(ASNEncInt(Self.Version),ASN1_INT)
+ASNObject(Self.community,ASN1_OCTSTR)
+ASNObject(data,Self.PDUType);
data:=ASNObject(data,ASN1_SEQ);
Result:=data;
data := data + ASNObject(s, ASN1_SEQ);
end;
data := ASNObject(data, ASN1_SEQ);
data := ASNObject(ASNEncInt(Self.FID), ASN1_INT) +
ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) +
ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) +
data;
data := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) +
ASNObject(Self.FCommunity, ASN1_OCTSTR) +
ASNObject(data, Self.FPDUType);
data := ASNObject(data, ASN1_SEQ);
Result := data;
end;
{TSNMPRec.Clear}
procedure TSNMPRec.Clear;
var
i:integer;
i: Integer;
begin
version:=0;
community:='';
PDUType:=0;
ErrorStatus:=0;
ErrorIndex:=0;
for i := 0 to SNMPMibList.count - 1 do
TSNMPMib(SNMPMibList[i]).Free;
SNMPMibList.Clear;
FVersion := 0;
FCommunity := '';
FPDUType := 0;
FErrorStatus := 0;
FErrorIndex := 0;
for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Clear;
end;
{TSNMPRec.MIBAdd}
procedure TSNMPRec.MIBAdd(MIB,Value:string; ValueType:integer);
procedure TSNMPRec.MIBAdd(const MIB, Value: string; ValueType: Integer);
var
SNMPMib: TSNMPMib;
begin
@ -227,122 +239,117 @@ begin
SNMPMib.OID := MIB;
SNMPMib.Value := Value;
SNMPMib.ValueType := ValueType;
SNMPMibList.Add(SNMPMib);
FSNMPMibList.Add(SNMPMib);
end;
{TSNMPRec.MIBdelete}
procedure TSNMPRec.MIBdelete(Index:integer);
procedure TSNMPRec.MIBDelete(Index: Integer);
begin
if (Index >= 0) and (Index < SNMPMibList.count) then
begin
TSNMPMib(SNMPMibList[Index]).Free;
SNMPMibList.Delete(Index);
end;
if (Index >= 0) and (Index < FSNMPMibList.Count) then
begin
TSNMPMib(FSNMPMibList[Index]).Free;
FSNMPMibList.Delete(Index);
end;
end;
{TSNMPRec.MIBGet}
function TSNMPRec.MIBGet(MIB:string):string;
function TSNMPRec.MIBGet(const MIB: string): string;
var
i: integer;
i: Integer;
begin
Result := '';
for i := 0 to SNMPMibList.count - 1 do
for i := 0 to FSNMPMibList.Count - 1 do
begin
if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then
begin
if ((TSNMPMib(SNMPMibList[i])).OID = MIB) then
begin
Result := (TSNMPMib(SNMPMibList[i])).Value;
break;
end;
Result := (TSNMPMib(FSNMPMibList[i])).Value;
Break;
end;
end;
end;
{==============================================================================}
{TSNMPSend.Create}
constructor TSNMPSend.Create;
begin
inherited create;
Query:=TSNMPRec.Create;
Reply:=TSNMPRec.Create;
Query.Clear;
Reply.Clear;
sock:=TUDPBlockSocket.create;
sock.createsocket;
timeout:=5000;
host:='localhost';
HostIP:='';
inherited Create;
FQuery := TSNMPRec.Create;
FReply := TSNMPRec.Create;
FQuery.Clear;
FReply.Clear;
FSock := TUDPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 5000;
FHost := cLocalhost;
FHostIP := '';
end;
{TSNMPSend.Destroy}
destructor TSNMPSend.Destroy;
begin
Sock.Free;
Reply.Free;
Query.Free;
inherited destroy;
FSock.Free;
FReply.Free;
FQuery.Free;
inherited Destroy;
end;
{TSNMPSend.DoIt}
function TSNMPSend.DoIt:boolean;
function TSNMPSend.DoIt: Boolean;
var
x:integer;
x: Integer;
begin
Result:=false;
reply.clear;
Buffer:=Query.Encodebuf;
sock.connect(host,'161');
HostIP:=sock.GetRemoteSinIP;
sock.SendBuffer(PChar(Buffer),Length(Buffer));
if sock.canread(timeout)
then begin
x:=sock.WaitingData;
if x>0 then
begin
setlength(Buffer,x);
sock.RecvBuffer(PChar(Buffer),x);
result:=true;
end;
Result := False;
FReply.Clear;
FBuffer := Query.EncodeBuf;
FSock.Connect(FHost, cSnmpProtocol);
FHostIP := FSock.GetRemoteSinIP;
FSock.SendBuffer(PChar(FBuffer), Length(FBuffer));
if FSock.CanRead(FTimeout) then
begin
x := FSock.WaitingData;
if x > 0 then
begin
SetLength(FBuffer, x);
FSock.RecvBuffer(PChar(FBuffer), x);
Result := True;
end;
if Result
then result:=reply.DecodeBuf(Buffer);
end;
if Result then
Result := FReply.DecodeBuf(FBuffer);
end;
{==============================================================================}
function SNMPget (Oid, Community, SNMPHost:string; var Value:string):Boolean;
function SNMPGet(const Oid, Community, SNMPHost: string;
var Value: string): Boolean;
var
SNMP:TSNMPSend;
SNMP: TSNMPSend;
begin
SNMP:=TSNMPSend.Create;
SNMP := TSNMPSend.Create;
try
Snmp.Query.community:=Community;
Snmp.Query.PDUType:=PDUGetRequest;
Snmp.Query.MIBAdd(Oid,'',ASN1_NULL);
Snmp.host:=SNMPHost;
Result:=Snmp.DoIt;
SNMP.Query.Community := Community;
SNMP.Query.PDUType := PDUGetRequest;
SNMP.Query.MIBAdd(Oid, '', ASN1_NULL);
SNMP.Host := SNMPHost;
Result := SNMP.DoIt;
if Result then
Value:=Snmp.Reply.MIBGet(Oid);
Value := SNMP.Reply.MIBGet(Oid);
finally
SNMP.Free;
end;
end;
function SNMPSet(Oid, Community, SNMPHost, Value: string; ValueType: integer): boolean;
function SNMPSet(const Oid, Community, SNMPHost, Value: string;
ValueType: Integer): Boolean;
var
SNMPSend: TSNMPSend;
begin
SNMPSend := TSNMPSend.Create;
try
SNMPSend.Query.community := Community;
SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUSetRequest;
SNMPSend.Query.MIBAdd(Oid, Value, ValueType);
SNMPSend.Host := SNMPHost;
result:= SNMPSend.DoIt=true;
Result := SNMPSend.DoIt = True;
finally
SNMPSend.Free;
end;
end;
end.

421
snmptrap.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.002.001 |
| Project : Delphree - Synapse | 002.002.002 |
|==============================================================================|
| Content: SNMP traps |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
@ -25,105 +25,123 @@
|==============================================================================}
{$Q-}
{$WEAKPACKAGEUNIT ON}
unit SNMPTrap;
interface
uses
Classes, SysUtils, BlckSock, SynaUtil, ASN1Util, SNMPsend;
Classes, SysUtils,
blckSock, SynaUtil, ASN1Util, SNMPSend;
const
TRAP_PORT = 162;
cSnmpTrapProtocol = '162';
SNMP_VERSION = 0;
SNMP_VERSION = 0;
PDU_GET = $A0;
PDU_GETN = $A1;
PDU_RESP = $A2;
PDU_SET = $A3;
PDU_TRAP = $A4;
PDU_GET = $A0;
PDU_GETN = $A1;
PDU_RESP = $A2;
PDU_SET = $A3;
PDU_TRAP = $A4;
type
TTrapPDU = class(TObject)
private
protected
Buffer: string;
public
TrapPort: integer;
Version: integer;
PDUType: integer;
Community: string;
Enterprise: string;
TrapHost: string;
GenTrap: integer;
SpecTrap: integer;
TimeTicks: integer;
SNMPMibList: TList;
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure MIBAdd(MIB, Value: string; ValueType:integer);
procedure MIBDelete(Index: integer);
function MIBGet(MIB: string): string;
function EncodeTrap: integer;
function DecodeTrap: boolean;
private
FBuffer: string;
FTrapPort: string;
FVersion: Integer;
FPDUType: Integer;
FCommunity: string;
FEnterprise: string;
FTrapHost: string;
FGenTrap: Integer;
FSpecTrap: Integer;
FTimeTicks: Integer;
FSNMPMibList: TList;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure MIBAdd(const MIB, Value: string; ValueType: Integer);
procedure MIBDelete(Index: Integer);
function MIBGet(const MIB: string): string;
function EncodeTrap: Integer;
function DecodeTrap: Boolean;
published
property Version: Integer read FVersion Write FVersion;
property Community: string read FCommunity Write FCommunity;
property PDUType: Integer read FPDUType Write FPDUType;
property TrapPort: string read FTrapPort Write FTrapPort;
property Enterprise: string read FEnterprise Write FEnterprise;
property TrapHost: string read FTrapHost Write FTrapHost;
property GenTrap: Integer read FGenTrap Write FGenTrap;
property SpecTrap: Integer read FSpecTrap Write FSpecTrap;
property TimeTicks: Integer read FTimeTicks Write FTimeTicks;
property SNMPMibList: TList read FSNMPMibList;
end;
TTrapSNMP = class(TObject)
private
sock: TUDPBlockSocket;
FSock: TUDPBlockSocket;
FTrap: TTrapPDU;
FSNMPHost: string;
FTimeout: Integer;
public
Trap: TTrapPDU;
SNMPHost: string;
Timeout: integer;
constructor Create;
destructor Destroy; override;
function Send: integer;
function Recv: integer;
function Send: Integer;
function Recv: Integer;
published
property Trap: TTrapPDU read FTrap;
property SNMPHost: string read FSNMPHost Write FSNMPHost;
property Timeout: Integer read FTimeout Write FTimeout;
end;
function SendTrap(Dest, Source, Enterprise, Community: string;
Generic, Specific, Seconds: integer; MIBName, MIBValue: string; MIBtype:integer): integer;
function SendTrap(const Dest, Source, Enterprise, Community: string;
Generic, Specific, Seconds: Integer; const MIBName, MIBValue: string;
MIBtype: Integer): Integer;
function RecvTrap(var Dest, Source, Enterprise, Community: string;
var Generic, Specific, Seconds: integer; var MIBName, MIBValue: TStringList): integer;
var Generic, Specific, Seconds: Integer; const MIBName,
MIBValue: TStringList): Integer;
implementation
constructor TTrapPDU.Create;
begin
inherited Create;
SNMPMibList := TList.create;
TrapPort := TRAP_PORT;
Version := SNMP_VERSION;
PDUType := PDU_TRAP;
Community := 'public';
FSNMPMibList := TList.Create;
FTrapPort := cSnmpTrapProtocol;
FVersion := SNMP_VERSION;
FPDUType := PDU_TRAP;
FCommunity := 'public';
end;
destructor TTrapPDU.Destroy;
var
i:integer;
i: Integer;
begin
for i := 0 to SNMPMibList.count - 1 do
TSNMPMib(SNMPMibList[i]).Free;
SNMPMibList.free;
for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Free;
inherited Destroy;
end;
procedure TTrapPDU.Clear;
var
i:integer;
i: Integer;
begin
for i := 0 to SNMPMibList.count - 1 do
TSNMPMib(SNMPMibList[i]).Free;
SNMPMibList.Clear;
TrapPort := TRAP_PORT;
Version := SNMP_VERSION;
PDUType := PDU_TRAP;
Community := 'public';
for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Clear;
FTrapPort := cSnmpTrapProtocol;
FVersion := SNMP_VERSION;
FPDUType := PDU_TRAP;
FCommunity := 'public';
end;
procedure TTrapPDU.MIBAdd(MIB, Value: string; ValueType:integer);
procedure TTrapPDU.MIBAdd(const MIB, Value: string; ValueType: Integer);
var
SNMPMib: TSNMPMib;
begin
@ -131,216 +149,207 @@ begin
SNMPMib.OID := MIB;
SNMPMib.Value := Value;
SNMPMib.ValueType := ValueType;
SNMPMibList.Add(SNMPMib);
FSNMPMibList.Add(SNMPMib);
end;
procedure TTrapPDU.MIBDelete(Index: integer);
procedure TTrapPDU.MIBDelete(Index: Integer);
begin
if (Index >= 0) and (Index < SNMPMibList.count) then
begin
TSNMPMib(SNMPMibList[Index]).Free;
SNMPMibList.Delete(Index);
end;
if (Index >= 0) and (Index < FSNMPMibList.Count) then
begin
TSNMPMib(FSNMPMibList[Index]).Free;
FSNMPMibList.Delete(Index);
end;
end;
function TTrapPDU.MIBGet(MIB: string): string;
function TTrapPDU.MIBGet(const MIB: string): string;
var
i: integer;
i: Integer;
begin
Result := '';
for i := 0 to SNMPMibList.count - 1 do
for i := 0 to FSNMPMibList.Count - 1 do
begin
if TSNMPMib(FSNMPMibList[i]).OID = MIB then
begin
if ((TSNMPMib(SNMPMibList[i])).OID = MIB) then
begin
Result := (TSNMPMib(SNMPMibList[i])).Value;
break;
end;
Result := TSNMPMib(FSNMPMibList[i]).Value;
Break;
end;
end;
end;
function TTrapPDU.EncodeTrap: integer;
function TTrapPDU.EncodeTrap: Integer;
var
s: string;
n: integer;
n: Integer;
SNMPMib: TSNMPMib;
begin
Buffer := '';
for n:=0 to SNMPMibList.Count-1 do
begin
SNMPMib := SNMPMibList[n];
case (SNMPMib.ValueType) of
ASN1_INT:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID)
+ASNObject(ASNEncInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID)
+ASNObject(ASNEncUInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
ASN1_OBJID:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(MibToID(SNMPMib.Value),SNMPMib.ValueType);
end;
ASN1_IPADDR:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(IPToID(SNMPMib.Value),SNMPMib.ValueType);
end;
ASN1_NULL:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject('',ASN1_NULL);
end;
else
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(SNMPMib.Value,SNMPMib.ValueType);
end;
Buffer := Buffer + ASNObject(s, ASN1_SEQ);
FBuffer := '';
for n := 0 to FSNMPMibList.Count - 1 do
begin
SNMPMib := FSNMPMibList[n];
case SNMPMib.ValueType of
ASN1_INT:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_OBJID:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_IPADDR:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_NULL:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject('', ASN1_NULL);
else
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(SNMPMib.Value, SNMPMib.ValueType);
end;
Buffer := ASNObject(Buffer, ASN1_SEQ);
Buffer := ASNObject(ASNEncInt(GenTrap), ASN1_INT)
+ ASNObject(ASNEncInt(SpecTrap), ASN1_INT)
+ ASNObject(ASNEncUInt(TimeTicks), ASN1_TIMETICKS)
+ Buffer;
Buffer := ASNObject(MibToID(Enterprise), ASN1_OBJID)
+ ASNObject(IPToID(TrapHost), ASN1_IPADDR)
+ Buffer;
Buffer := ASNObject(ASNEncInt(Version), ASN1_INT)
+ ASNObject(Community, ASN1_OCTSTR)
+ ASNObject(Buffer, Self.PDUType);
Buffer := ASNObject(Buffer, ASN1_SEQ);
FBuffer := FBuffer + ASNObject(s, ASN1_SEQ);
end;
FBuffer := ASNObject(FBuffer, ASN1_SEQ);
FBuffer := ASNObject(ASNEncInt(FGenTrap), ASN1_INT) +
ASNObject(ASNEncInt(FSpecTrap), ASN1_INT) +
ASNObject(ASNEncUInt(FTimeTicks), ASN1_TIMETICKS) +
FBuffer;
FBuffer := ASNObject(MibToID(FEnterprise), ASN1_OBJID) +
ASNObject(IPToID(FTrapHost), ASN1_IPADDR) +
FBuffer;
FBuffer := ASNObject(ASNEncInt(FVersion), ASN1_INT) +
ASNObject(FCommunity, ASN1_OCTSTR) +
ASNObject(FBuffer, Self.FPDUType);
FBuffer := ASNObject(FBuffer, ASN1_SEQ);
Result := 1;
end;
function TTrapPDU.DecodeTrap: boolean;
function TTrapPDU.DecodeTrap: Boolean;
var
Pos, EndPos: integer;
Pos, EndPos: Integer;
Sm, Sv: string;
Svt:integer;
Svt: Integer;
begin
clear;
result:=false;
if length(buffer)<2
then exit;
if (ord(buffer[1]) and $20)=0
then exit;
Clear;
Result := False;
if Length(FBuffer) < 2 then
Exit;
if (Ord(FBuffer[1]) and $20) = 0 then
Exit;
Pos := 2;
EndPos := ASNDecLen(Pos, Buffer);
Version := StrToIntDef(ASNItem(Pos, Buffer,svt), 0);
Community := ASNItem(Pos, Buffer,svt);
PDUType := StrToIntDef(ASNItem(Pos, Buffer,svt), PDU_TRAP);
Enterprise := ASNItem(Pos, Buffer,svt);
TrapHost := ASNItem(Pos, Buffer,svt);
GenTrap := StrToIntDef(ASNItem(Pos, Buffer,svt), 0);
Spectrap := StrToIntDef(ASNItem(Pos, Buffer,svt), 0);
TimeTicks := StrToIntDef(ASNItem(Pos, Buffer,svt), 0);
ASNItem(Pos, Buffer,svt);
while (Pos < EndPos) do
begin
ASNItem(Pos, Buffer,svt);
Sm := ASNItem(Pos, Buffer,svt);
Sv := ASNItem(Pos, Buffer,svt);
MIBAdd(Sm, Sv, svt);
end;
Result := true;
EndPos := ASNDecLen(Pos, FBuffer);
FVersion := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
FCommunity := ASNItem(Pos, FBuffer, Svt);
FPDUType := StrToIntDef(ASNItem(Pos, FBuffer, Svt), PDU_TRAP);
FEnterprise := ASNItem(Pos, FBuffer, Svt);
FTrapHost := ASNItem(Pos, FBuffer, Svt);
FGenTrap := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
FSpecTrap := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
FTimeTicks := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
ASNItem(Pos, FBuffer, Svt);
while Pos < EndPos do
begin
ASNItem(Pos, FBuffer, Svt);
Sm := ASNItem(Pos, FBuffer, Svt);
Sv := ASNItem(Pos, FBuffer, Svt);
MIBAdd(Sm, Sv, Svt);
end;
Result := True;
end;
constructor TTrapSNMP.Create;
begin
inherited Create;
Sock := TUDPBlockSocket.Create;
Trap := TTrapPDU.Create;
Timeout := 5000;
SNMPHost := '127.0.0.1';
Sock.CreateSocket;
FSock := TUDPBlockSocket.Create;
FTrap := TTrapPDU.Create;
FTimeout := 5000;
FSNMPHost := cLocalhost;
FSock.CreateSocket;
end;
destructor TTrapSNMP.Destroy;
begin
Trap.Free;
Sock.Free;
FTrap.Free;
FSock.Free;
inherited Destroy;
end;
function TTrapSNMP.Send: integer;
function TTrapSNMP.Send: Integer;
begin
Trap.EncodeTrap;
Sock.Connect(SNMPHost, IntToStr(Trap.TrapPort));
Sock.SendBuffer(PChar(Trap.Buffer), Length(Trap.Buffer));
FTrap.EncodeTrap;
FSock.Connect(SNMPHost, FTrap.TrapPort);
FSock.SendBuffer(PChar(FTrap.FBuffer), Length(FTrap.FBuffer));
Result := 1;
end;
function TTrapSNMP.Recv: integer;
function TTrapSNMP.Recv: Integer;
var
x: integer;
x: Integer;
begin
Result := 0;
Sock.Bind('0.0.0.0', IntToStr(Trap.TrapPort));
if Sock.CanRead(Timeout) then
FSock.Bind('0.0.0.0', FTrap.TrapPort);
if FSock.CanRead(FTimeout) then
begin
x := FSock.WaitingData;
if x > 0 then
begin
x := Sock.WaitingData;
if (x > 0) then
begin
SetLength(Trap.Buffer, x);
Sock.RecvBuffer(PChar(Trap.Buffer), x);
if Trap.DecodeTrap
then Result:=1;
end;
SetLength(FTrap.FBuffer, x);
FSock.RecvBuffer(PChar(FTrap.FBuffer), x);
if FTrap.DecodeTrap then
Result := 1;
end;
end;
end;
function SendTrap(Dest, Source, Enterprise, Community: string;
Generic, Specific, Seconds: integer; MIBName, MIBValue: string; MIBtype:integer): integer;
var
SNMP: TTrapSNMP;
function SendTrap(const Dest, Source, Enterprise, Community: string;
Generic, Specific, Seconds: Integer; const MIBName, MIBValue: string;
MIBtype: Integer): Integer;
begin
SNMP := TTrapSNMP.Create;
with TTrapSNMP.Create do
try
SNMP.SNMPHost := Dest;
SNMP.Trap.TrapHost := Source;
SNMP.Trap.Enterprise := Enterprise;
SNMP.Trap.Community := Community;
SNMP.Trap.GenTrap := Generic;
SNMP.Trap.SpecTrap := Specific;
SNMP.Trap.TimeTicks := Seconds;
SNMP.Trap.MIBAdd(MIBName,MIBValue,MIBType);
Result := SNMP.Send;
SNMPHost := Dest;
Trap.TrapHost := Source;
Trap.Enterprise := Enterprise;
Trap.Community := Community;
Trap.GenTrap := Generic;
Trap.SpecTrap := Specific;
Trap.TimeTicks := Seconds;
Trap.MIBAdd(MIBName, MIBValue, MIBType);
Result := Send;
finally
SNMP.Free;
Free;
end;
end;
function RecvTrap(var Dest, Source, Enterprise, Community: string;
var Generic, Specific, Seconds: integer; var MIBName, MIBValue: TStringList):
integer;
var Generic, Specific, Seconds: Integer;
const MIBName, MIBValue: TStringList): Integer;
var
SNMP: TTrapSNMP;
i: integer;
i: Integer;
begin
SNMP := TTrapSNMP.Create;
with TTrapSNMP.Create do
try
SNMP.SNMPHost := Dest;
Result := SNMP.Recv;
if (Result <> 0) then
SNMPHost := Dest;
Result := Recv;
if Result <> 0 then
begin
Dest := SNMP.SNMPHost;
Source := SNMP.Trap.TrapHost;
Enterprise := SNMP.Trap.Enterprise;
Community := SNMP.Trap.Community;
Generic := SNMP.Trap.GenTrap;
Specific := SNMP.Trap.SpecTrap;
Seconds := SNMP.Trap.TimeTicks;
Dest := SNMPHost;
Source := Trap.TrapHost;
Enterprise := Trap.Enterprise;
Community := Trap.Community;
Generic := Trap.GenTrap;
Specific := Trap.SpecTrap;
Seconds := Trap.TimeTicks;
MIBName.Clear;
MIBValue.Clear;
for i:=0 to (SNMP.Trap.SNMPMibList.count - 1) do
begin
MIBName.Add(TSNMPMib(SNMP.Trap.SNMPMibList[i]).OID);
MIBValue.Add(TSNMPMib(SNMP.Trap.SNMPMibList[i]).Value);
end;
for i := 0 to Trap.SNMPMibList.Count - 1 do
begin
MIBName.Add(TSNMPMib(Trap.SNMPMibList[i]).OID);
MIBValue.Add(TSNMPMib(Trap.SNMPMibList[i]).Value);
end;
end;
finally
SNMP.Free;
Free;
end;
end;
end.

204
sntpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.000.000 |
| Project : Delphree - Synapse | 002.000.001 |
|==============================================================================|
| Content: SNTP client |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000. |
| Portions created by Lukas Gebauer are Copyright (c)2000,2001. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -24,142 +24,144 @@
|==============================================================================}
{$Q-}
{$WEAKPACKAGEUNIT ON}
unit SNTPsend;
interface
uses
synsock, SysUtils, blcksock;
SysUtils,
synsock, blcksock;
const
cNtpProtocol = 'ntp';
type
PNtp = ^TNtp;
TNtp = packed record
mode:Byte;
stratum:Byte;
poll:Byte;
Precision:Byte;
RootDelay : longint;
RootDisperson : longint;
RefID : longint;
Ref1, Ref2,
Org1, Org2,
Rcv1, Rcv2,
Xmit1, Xmit2 : longint;
mode: Byte;
stratum: Byte;
poll: Byte;
Precision: Byte;
RootDelay: Longint;
RootDisperson: Longint;
RefID: Longint;
Ref1: Longint;
Ref2: Longint;
Org1: Longint;
Org2: Longint;
Rcv1: Longint;
Rcv2: Longint;
Xmit1: Longint;
Xmit2: Longint;
end;
TSNTPSend=class(TObject)
TSNTPSend = class(TObject)
private
Sock:TUDPBlockSocket;
Buffer:string;
FNTPReply: TNtp;
FNTPTime: TDateTime;
FSntpHost: string;
FTimeout: Integer;
FSock: TUDPBlockSocket;
FBuffer: string;
public
timeout:integer;
SntpHost:string;
NTPReply:TNtp;
NTPTime:TDateTime;
constructor Create;
destructor Destroy; override;
function DecodeTs(nsec,nfrac:Longint):tdatetime;
function GetNTP:Boolean;
function GetBroadcastNTP:Boolean;
end;
function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
function GetNTP: Boolean;
function GetBroadcastNTP: Boolean;
published
property NTPReply: TNtp read FNTPReply;
property NTPTime: TDateTime read FNTPTime;
property SntpHost: string read FSntpHost write FSntpHost;
property Timeout: Integer read FTimeout write FTimeout;
end;
implementation
{==============================================================================}
{TSNTPSend.Create}
Constructor TSNTPSend.Create;
constructor TSNTPSend.Create;
begin
inherited Create;
sock:=TUDPBlockSocket.create;
sock.CreateSocket;
timeout:=5000;
sntphost:='localhost';
FSock := TUDPBlockSocket.Create;
FSock.CreateSocket;
FTimeout := 5000;
FSntpHost := cLocalhost;
end;
{TSNTPSend.Destroy}
Destructor TSNTPSend.Destroy;
destructor TSNTPSend.Destroy;
begin
Sock.free;
inherited destroy;
FSock.Free;
inherited Destroy;
end;
{TSNTPSend.DecodeTs}
function TSNTPSend.DecodeTs(nsec,nfrac:Longint):tdatetime;
function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
const
maxi = 4294967296.0;
var
d, d1: double;
d, d1: Double;
begin
nsec:=synsock.htonl(nsec);
nfrac:=synsock.htonl(nfrac);
d:=nsec;
if d<0
then d:=maxi+d-1;
d1 := nfrac;
if d1<0
then d1:=maxi+d1-1;
d1:=d1/maxi;
d1:=trunc(d1*1000)/1000;
result:=(d+d1)/86400;
result := Result + 2;
Nsec := synsock.htonl(Nsec);
Nfrac := synsock.htonl(Nfrac);
d := Nsec;
if d < 0 then
d := maxi + d - 1;
d1 := Nfrac;
if d1 < 0 then
d1 := maxi + d1 - 1;
d1 := d1 / maxi;
d1 := Trunc(d1 * 1000) / 1000;
Result := (d + d1) / 86400;
Result := Result + 2;
end;
{TSNTPSend.GetBroadcastNTP}
function TSNTPSend.GetBroadcastNTP:Boolean;
function TSNTPSend.GetBroadcastNTP: Boolean;
var
PNtp:^TNtp;
x:integer;
NtpPtr: PNtp;
x: Integer;
begin
Result:=False;
sock.bind('0.0.0.0','ntp');
if sock.canread(timeout)
then begin
x:=sock.waitingdata;
setlength(Buffer,x);
sock.recvbufferFrom(Pointer(Buffer),x);
if (sntphost='0.0.0.0') or (sock.GetRemoteSinIP=sntphost) then
if x>=SizeOf(NTPReply) then
begin
PNtp:=Pointer(Buffer);
NtpReply:=PNtp^;
NTPtime:=DeCodeTs(ntpreply.Xmit1,ntpreply.Xmit2);
Result:=True;
end;
end;
Result := False;
FSock.Bind('0.0.0.0', cNtpProtocol);
if FSock.CanRead(Timeout) then
begin
x := FSock.WaitingData;
SetLength(FBuffer, x);
FSock.RecvBufferFrom(Pointer(FBuffer), x);
if (SntpHost = '0.0.0.0') or (FSock.GetRemoteSinIP = SntpHost) then
if x >= SizeOf(NTPReply) then
begin
NtpPtr := Pointer(FBuffer);
FNTPReply := NtpPtr^;
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
Result := True;
end;
end;
end;
{TSNTPSend.GetNTP}
function TSNTPSend.GetNTP:Boolean;
function TSNTPSend.GetNTP: Boolean;
var
q:Tntp;
PNtp:^TNtp;
x:integer;
q: TNtp;
NtpPtr: PNtp;
x: Integer;
begin
Result:=False;
sock.Connect(sntphost,'ntp');
fillchar(q,SizeOf(q),0);
q.mode:=$1b;
sock.SendBuffer(@q,SizeOf(q));
if sock.canread(timeout)
then begin
x:=sock.waitingdata;
setlength(Buffer,x);
sock.recvbuffer(Pointer(Buffer),x);
if x>=SizeOf(NTPReply) then
begin
PNtp:=Pointer(Buffer);
NtpReply:=PNtp^;
NTPtime:=DeCodeTs(ntpreply.Xmit1,ntpreply.Xmit2);
Result:=True;
end;
Result := False;
FSock.Connect(sntphost, cNtpProtocol);
FillChar(q, SizeOf(q), 0);
q.mode := $1B;
FSock.SendBuffer(@q, SizeOf(q));
if FSock.CanRead(Timeout) then
begin
x := FSock.WaitingData;
SetLength(FBuffer, x);
FSock.RecvBuffer(Pointer(FBuffer), x);
if x >= SizeOf(NTPReply) then
begin
NtpPtr := Pointer(FBuffer);
FNTPReply := NtpPtr^;
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
Result := True;
end;
end;
end;
{==============================================================================}
end.

1191
synachar.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1031
synacode.pas
View File

File diff suppressed because it is too large Load Diff

21
synahook.pas Normal file
View File

@ -0,0 +1,21 @@
unit SynaHook;
interface
type
THookReason = (
HR_connect,
HR_login,
HR_logout,
HR_command,
HR_result,
HR_beginTransfer,
HR_endTransfer,
HR_TransferCounter
);
THookEvent = procedure(Sender: TObject; Reason: THookReason; Value: string) of object;
implementation
end.

707
synautil.pas
View File

@ -1,11 +1,11 @@
{==============================================================================|
| Project : Delphree - Synapse | 002.000.000 |
| Project : Delphree - Synapse | 002.000.001 |
|==============================================================================|
| Content: support procedures and functions |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| License. You may obtain a Copy of the License at http://www.mozilla.org/MPL/ |
| |
| Software distributed under the License is distributed on an "AS IS" basis, |
| WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
@ -32,428 +32,447 @@ unit SynaUtil;
interface
uses
sysutils, classes,
SysUtils, Classes,
{$IFDEF LINUX}
libc;
Libc;
{$ELSE}
windows;
Windows;
{$ENDIF}
function timezone:string;
function Rfc822DateTime(t:TDateTime):String;
function CodeInt(Value:word):string;
function DeCodeInt(Value:string;Index:integer):word;
function IsIP(Value:string):Boolean;
function ReverseIP(Value:string):string;
procedure Dump (Buffer:string;DumpFile:string);
function SeparateLeft(value,delimiter:string):string;
function SeparateRight(value,delimiter:string):string;
function getparameter(value,parameter:string):string;
function GetEmailAddr(value:string):string;
function GetEmailDesc(value:string):string;
function StrToHex(value:string):string;
function IntToBin(value:integer;digits:byte):string;
function BinToInt(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 Timezone: string;
function Rfc822DateTime(t: TDateTime): string;
function CodeInt(Value: Word): string;
function DecodeInt(const Value: string; Index: Integer): Word;
function IsIP(const Value: string): Boolean;
function ReverseIP(Value: string): string;
procedure Dump(const Buffer, DumpFile: string);
function SeparateLeft(const Value, Delimiter: string): string;
function SeparateRight(const Value, Delimiter: string): string;
function GetParameter(const Value, Parameter: string): string;
function GetEmailAddr(const Value: string): string;
function GetEmailDesc(Value: string): string;
function StrToHex(const Value: string): string;
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;
implementation
{==============================================================================}
{timezone}
function timezone:string;
function Timezone: string;
{$IFDEF LINUX}
var
t: TTime_T;
UT: TUnixTime;
bias:integer;
h,m:integer;
UT: TUnixTime;
bias: Integer;
h, m: Integer;
begin
__time(@T);
localtime_r(@T,UT);
bias:=ut.__tm_gmtoff div 60;
if bias>=0 then result:='+'
else result:='-';
{$ELSE}
localtime_r(@T, UT);
bias := ut.__tm_gmtoff div 60;
if bias >= 0 then
Result := '+'
else
Result := '-';
{$ELSE}
var
zoneinfo:TTimeZoneInformation;
bias:integer;
h,m:integer;
zoneinfo: TTimeZoneInformation;
bias: Integer;
h, m: Integer;
begin
case GetTimeZoneInformation(Zoneinfo) of
2: bias:=zoneinfo.bias+zoneinfo.DaylightBias;
1: bias:=zoneinfo.bias+zoneinfo.StandardBias;
else
bias:=zoneinfo.bias;
2:
bias := zoneinfo.Bias + zoneinfo.DaylightBias;
1:
bias := zoneinfo.Bias + zoneinfo.StandardBias;
else
bias := zoneinfo.Bias;
end;
if bias<=0 then result:='+'
else result:='-';
if bias <= 0 then
Result := '+'
else
Result := '-';
{$ENDIF}
bias:=abs(bias);
h:=bias div 60;
m:=bias mod 60;
result:=result+format('%.2d%.2d',[h,m]);
bias := Abs(bias);
h := bias div 60;
m := bias mod 60;
Result := Result + Format('%.2d%.2d', [h, m]);
end;
{==============================================================================}
{Rfc822DateTime}
function Rfc822DateTime(t:TDateTime):String;
function Rfc822DateTime(t: TDateTime): string;
var
I: Integer;
SaveDayNames: array[1..7] of string;
SaveMonthNames: array[1..12] of string;
const
MyDayNames: array[1..7] of string =
('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
MyMonthNames: array[1..12] of string =
('Jan', 'Feb', 'Mar', 'Apr',
'May', 'Jun', 'Jul', 'Aug',
'Sep', 'Oct', 'Nov', 'Dec');
('Jan', 'Feb', 'Mar', 'Apr',
'May', 'Jun', 'Jul', 'Aug',
'Sep', 'Oct', 'Nov', 'Dec');
begin
if ShortDayNames[1] = MyDayNames[1]
then Result := FormatDateTime('ddd, d mmm yyyy hh:mm:ss', t)
if ShortDayNames[1] = MyDayNames[1] then
Result := FormatDateTime('ddd, d mmm yyyy hh:mm:ss', t)
else
begin
for I := Low(ShortDayNames) to High(ShortDayNames) do
begin
SaveDayNames[I] := ShortDayNames[I];
ShortDayNames[I] := MyDayNames[I];
end;
for I := Low(ShortMonthNames) to High(ShortMonthNames) do
begin
SaveMonthNames[I] := ShortMonthNames[I];
ShortMonthNames[I] := MyMonthNames[I];
end;
Result := FormatDateTime('ddd, d mmm yyyy hh:mm:ss', t);
for I := Low(ShortDayNames) to High(ShortDayNames) do
ShortDayNames[I] := SaveDayNames[I];
for I := Low(ShortMonthNames) to High(ShortMonthNames) do
ShortMonthNames[I] := SaveMonthNames[I];
end;
Result := Result + ' ' + Timezone;
end;
{==============================================================================}
function CodeInt(Value: Word): string;
begin
Result := Chr(Hi(Value)) + Chr(Lo(Value))
end;
{==============================================================================}
function DecodeInt(const Value: string; Index: Integer): Word;
var
x, y: Byte;
begin
if Length(Value) > Index then
x := Ord(Value[Index])
else
x := 0;
if Length(Value) > (Index + 1) then
y := Ord(Value[Index + 1])
else
y := 0;
Result := x * 256 + y;
end;
{==============================================================================}
function IsIP(const Value: string): Boolean;
var
n, x: Integer;
begin
Result := true;
x := 0;
for n := 1 to Length(Value) do
if not (Value[n] in ['0'..'9', '.']) then
begin
Result := False;
Break;
end
else
begin
for I := Low(ShortDayNames) to High(ShortDayNames) do
begin
SaveDayNames[I] := ShortDayNames[I];
ShortDayNames[I] := MyDayNames[I];
end;
for I := Low(ShortMonthNames) to High(ShortMonthNames) do
begin
SaveMonthNames[I] := ShortMonthNames[I];
ShortMonthNames[I] := MyMonthNames[I];
end;
Result := FormatDateTime('ddd, d mmm yyyy hh:mm:ss', t);
for I := Low(ShortDayNames) to High(ShortDayNames) do
ShortDayNames[I] := SaveDayNames[I];
for I := Low(ShortMonthNames) to High(ShortMonthNames) do
ShortMonthNames[I] := SaveMonthNames[I];
end;
Result:=Result+' '+Timezone;
begin
if Value[n] = '.' then
Inc(x);
end;
if x <> 3 then
Result := False;
end;
{==============================================================================}
{CodeInt}
function CodeInt(Value:word):string;
begin
Result := Chr(Hi(Value))+ Chr(Lo(Value))
end;
{==============================================================================}
{DeCodeInt}
function DeCodeInt(Value:string;Index:integer):word;
function ReverseIP(Value: string): string;
var
x,y:Byte;
x: Integer;
begin
if Length(Value)>index then x:=Ord(Value[index])
else x:=0;
if Length(Value)>(Index+1) then y:=Ord(Value[Index+1])
else y:=0;
Result:=x*256+y;
end;
{==============================================================================}
{IsIP}
function IsIP(Value:string):Boolean;
var
n,x:integer;
begin
Result:=true;
x:=0;
for n:=1 to Length(Value) do
if not (Value[n] in ['0'..'9','.'])
then begin
Result:=False;
break;
end
else begin
if Value[n]='.' then Inc(x);
end;
if x<>3 then Result:=False;
end;
{==============================================================================}
{ReverseIP}
function ReverseIP(Value:string):string;
var
x:integer;
begin
Result:='';
Result := '';
repeat
x:=LastDelimiter('.',Value);
Result:=Result+'.'+Copy(Value,x+1,Length(Value)-x);
Delete(Value,x,Length(Value)-x+1);
until x<1;
if Length(Result)>0 then
if Result[1]='.' then
x := LastDelimiter('.', Value);
Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
Delete(Value, x, Length(Value) - x + 1);
until x < 1;
if Length(Result) > 0 then
if Result[1] = '.' then
Delete(Result, 1, 1);
end;
{==============================================================================}
{dump}
procedure dump (Buffer:string;DumpFile:string);
procedure Dump(const Buffer, DumpFile: string);
var
n:integer;
s:string;
f:Text;
n: Integer;
s: string;
f: Text;
begin
s:='';
for n:=1 to Length(Buffer) do
s:=s+' +#$'+IntToHex(Ord(Buffer[n]),2);
Assignfile(f,DumpFile);
if fileexists(DumpFile) then deletefile(PChar(DumpFile));
rewrite(f);
s := '';
for n := 1 to Length(Buffer) do
s := s + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
AssignFile(f, DumpFile);
if FileExists(DumpFile) then
DeleteFile(PChar(DumpFile));
Rewrite(f);
try
writeln(f,s);
Writeln(f, s);
finally
closefile(f);
CloseFile(f);
end;
end;
{==============================================================================}
{SeparateLeft}
function SeparateLeft(value,delimiter:string):string;
function SeparateLeft(const Value, Delimiter: string): string;
var
x:integer;
x: Integer;
begin
x:=pos(delimiter,value);
if x<1
then result:=trim(value)
else result:=trim(copy(value,1,x-1));
x := Pos(Delimiter, Value);
if x < 1 then
Result := Trim(Value)
else
Result := Trim(Copy(Value, 1, x - 1));
end;
{==============================================================================}
{SeparateRight}
function SeparateRight(value,delimiter:string):string;
function SeparateRight(const Value, Delimiter: string): string;
var
x:integer;
x: Integer;
begin
x:=pos(delimiter,value);
if x>0
then x:=x+length(delimiter)-1;
result:=trim(copy(value,x+1,length(value)-x));
x := Pos(Delimiter, Value);
if x > 0 then
x := x + Length(Delimiter) - 1;
Result := Trim(Copy(Value, x + 1, Length(Value) - x));
end;
{==============================================================================}
{GetParameter}
function getparameter(value,parameter:string):string;
function GetParameter(const Value, Parameter: string): string;
var
x,x1:integer;
s:string;
x, x1: Integer;
s: string;
begin
x:=pos(uppercase(parameter),uppercase(value));
result:='';
if x>0 then
x := Pos(UpperCase(Parameter), UpperCase(Value));
Result := '';
if x > 0 then
begin
s := Copy(Value, x + Length(Parameter), Length(Value)
- (x + Length(Parameter)) + 1);
s := Trim(s);
x1 := Length(s);
if Length(s) > 1 then
begin
s:=copy(value,x+length(parameter),length(value)-(x+length(parameter))+1);
s:=trim(s);
x1:=length(s);
if length(s)>1 then
begin
if s[1]='"'
then
begin
s:=copy(s,2,length(s)-1);
x:=pos('"',s);
if x>0 then x1:=x-1;
end
else
begin
x:=pos(' ',s);
if x>0 then x1:=x-1;
end;
end;
result:=copy(s,1,x1);
end;
end;
{==============================================================================}
{GetEmailAddr}
function GetEmailAddr(value:string):string;
var
s:string;
begin
s:=separateright(value,'<');
s:=separateleft(s,'>');
result:=trim(s);
end;
{==============================================================================}
{GetEmailDesc}
function GetEmailDesc(value:string):string;
var
s:string;
begin
value:=trim(value);
s:=separateright(value,'"');
if s<>value
then s:=separateleft(s,'"')
else
if s[1] = '"' then
begin
s:=separateright(value,'(');
if s<>value
then s:=separateleft(s,')')
else
begin
s:=separateleft(value,'<');
if s=value
then s:='';
end;
s := Copy(s, 2, Length(s) - 1);
x := Pos('"', s);
if x > 0 then
x1 := x - 1;
end
else
begin
x := Pos(' ', s);
if x > 0 then
x1 := x - 1;
end;
result:=trim(s);
end;
{==============================================================================}
{StrToHex}
function StrToHex(value:string):string;
var
n:integer;
begin
result:='';
for n:=1 to length(value) do
Result:=Result+IntToHex(Byte(value[n]),2);
result:=lowercase(result);
end;
{==============================================================================}
{IntToBin}
function IntToBin(value:integer;digits:byte):string;
var
x,y,n:integer;
begin
result:='';
x:=value;
repeat
y:=x mod 2;
x:=x div 2;
if y>0
then result:='1'+result
else result:='0'+result;
until x=0;
x:=length(result);
for n:=x to digits-1 do
result:='0'+result;
end;
{==============================================================================}
{BinToInt}
function BinToInt(value:string):integer;
var
x,n:integer;
begin
result:=0;
for n:=1 to length(value) do
begin
if value[n]='0'
then x:=0
else x:=1;
result:=result*2+x;
end;
Result := Copy(s, 1, x1);
end;
end;
{==============================================================================}
{ParseURL}
function ParseURL(URL:string; var Prot,User,Pass,Host,Port,Path,Para:string):string;
var
x:integer;
sURL:string;
s:string;
s1,s2:string;
begin
prot:='http';
user:='';
pass:='';
port:='80';
para:='';
x:=pos('://',URL);
if x>0 then
begin
prot:=separateleft(URL,'://');
sURL:=separateright(URL,'://');
end
else sURL:=URL;
x:=pos('@',sURL);
if x>0 then
begin
s:=separateleft(sURL,'@');
sURL:=separateright(sURL,'@');
x:=pos(':',s);
if x>0 then
begin
user:=separateleft(s,':');
pass:=separateright(s,':');
end
else user:=s;
end;
x:=pos('/',sURL);
if x>0 then
begin
s1:=separateleft(sURL,'/');
s2:=separateright(sURL,'/');
end
function GetEmailAddr(const Value: string): string;
var
s: string;
begin
s := SeparateRight(Value, '<');
s := SeparateLeft(s, '>');
Result := Trim(s);
end;
{==============================================================================}
function GetEmailDesc(Value: string): string;
var
s: string;
begin
Value := Trim(Value);
s := SeparateRight(Value, '"');
if s <> Value then
s := SeparateLeft(s, '"')
else
begin
s := SeparateRight(Value, '(');
if s <> Value then
s := SeparateLeft(s, ')')
else
begin
s1:=sURL;
s2:='';
s := SeparateLeft(Value, '<');
if s = Value then
s := '';
end;
x:=pos(':',s1);
if x>0 then
begin
host:=separateleft(s1,':');
port:=separateright(s1,':');
end
else host:=s1;
result:='/'+s2;
x:=pos('?',s2);
if x>0 then
begin
path:='/'+separateleft(s2,'?');
para:=separateright(s2,'?');
end
else path:='/'+s2;
if host=''
then host:='localhost';
end;
Result := Trim(s);
end;
{==============================================================================}
{StringReplace}
function StringReplace(value,search,replace:string):string;
function StrToHex(const Value: string): string;
var
x,l,ls,lr:integer;
n: Integer;
begin
if (value='') or (Search='') then
begin
result:=value;
Exit;
end;
ls:=length(search);
lr:=length(replace);
result:='';
x:=pos(search,value);
while x>0 do
begin
l:=length(result);
setlength(result,l+x-1);
Move(pointer(value)^,Pointer(@result[l+1])^, x-1);
// result:=result+copy(value,1,x-1);
l:=length(result);
setlength(result,l+lr);
Move(pointer(replace)^,Pointer(@result[l+1])^, lr);
// result:=result+replace;
delete(value,1,x-1+ls);
x:=pos(search,value);
end;
result:=result+value;
Result := '';
for n := 1 to Length(Value) do
Result := Result + IntToHex(Byte(Value[n]), 2);
Result := LowerCase(Result);
end;
{==============================================================================}
function IntToBin(Value: Integer; Digits: Byte): string;
var
x, y, n: Integer;
begin
Result := '';
x := Value;
repeat
y := x mod 2;
x := x div 2;
if y > 0 then
Result := '1' + Result
else
Result := '0' + Result;
until x = 0;
x := Length(Result);
for n := x to Digits - 1 do
Result := '0' + Result;
end;
{==============================================================================}
function BinToInt(const Value: string): Integer;
var
n: Integer;
begin
Result := 0;
for n := 1 to Length(Value) do
begin
if Value[n] = '0' then
Result := Result * 2
else
if Value[n] = '1' then
Result := Result * 2 + 1
else
Break;
end;
end;
{==============================================================================}
function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
Para: string): string;
var
x: Integer;
sURL: string;
s: string;
s1, s2: string;
begin
Prot := 'http';
User := '';
Pass := '';
Port := '80';
Para := '';
x := Pos('://', URL);
if x > 0 then
begin
Prot := SeparateLeft(URL, '://');
sURL := SeparateRight(URL, '://');
end
else
sURL := URL;
x := Pos('@', sURL);
if x > 0 then
begin
s := SeparateLeft(sURL, '@');
sURL := SeparateRight(sURL, '@');
x := Pos(':', s);
if x > 0 then
begin
User := SeparateLeft(s, ':');
Pass := SeparateRight(s, ':');
end
else
User := s;
end;
x := Pos('/', sURL);
if x > 0 then
begin
s1 := SeparateLeft(sURL, '/');
s2 := SeparateRight(sURL, '/');
end
else
begin
s1 := sURL;
s2 := '';
end;
x := Pos(':', s1);
if x > 0 then
begin
Host := SeparateLeft(s1, ':');
Port := SeparateRight(s1, ':');
end
else
Host := s1;
Result := '/' + s2;
x := Pos('?', s2);
if x > 0 then
begin
Path := '/' + SeparateLeft(s2, '?');
Para := SeparateRight(s2, '?');
end
else
Path := '/' + s2;
if Host = '' then
Host := 'localhost';
end;
{==============================================================================}
function StringReplace(Value, Search, Replace: string): string;
var
x, l, ls, lr: Integer;
begin
if (Value = '') or (Search = '') then
begin
Result := Value;
Exit;
end;
ls := Length(Search);
lr := Length(Replace);
Result := '';
x := Pos(Search, Value);
while x > 0 do
begin
l := Length(Result);
SetLength(Result, l + x - 1);
Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1);
// Result:=Result+Copy(Value,1,x-1);
l := Length(Result);
SetLength(Result, l + lr);
Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr);
// Result:=Result+Replace;
Delete(Value, 1, x - 1 + ls);
x := Pos(Search, Value);
end;
Result := Result + Value;
end;
end.

623
synsock.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.000.001 |
| Project : Delphree - Synapse | 001.000.002 |
|==============================================================================|
| Content: Socket Independent Platform |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| The contents of this file are subject to the Mozilla Public License Ver. 1.1 |
| (the "License"); you may not use this file except in compliance with the |
| License. You may obtain a copy of the License at http://www.mozilla.org/MPL/ |
| |
@ -23,83 +23,86 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit synsock;
interface
uses
{$IFDEF LINUX}
libc, kernelioctl;
Libc, KernelIoctl;
{$ELSE}
winsock, windows;
Windows, WinSock;
{$ENDIF}
{$IFDEF LINUX}
const
WSAEINTR = EINTR;
WSAEBADF = EBADF;
WSAEACCES = EACCES;
WSAEFAULT = EFAULT;
WSAEINVAL = EINVAL;
WSAEMFILE = EMFILE;
WSAEWOULDBLOCK = EWOULDBLOCK;
WSAEINPROGRESS = EINPROGRESS;
WSAEALREADY = EALREADY;
WSAENOTSOCK = ENOTSOCK;
WSAEDESTADDRREQ = EDESTADDRREQ;
WSAEMSGSIZE = EMSGSIZE;
WSAEPROTOTYPE = EPROTOTYPE;
WSAENOPROTOOPT = ENOPROTOOPT;
WSAEINTR = EINTR;
WSAEBADF = EBADF;
WSAEACCES = EACCES;
WSAEFAULT = EFAULT;
WSAEINVAL = EINVAL;
WSAEMFILE = EMFILE;
WSAEWOULDBLOCK = EWOULDBLOCK;
WSAEINPROGRESS = EINPROGRESS;
WSAEALREADY = EALREADY;
WSAENOTSOCK = ENOTSOCK;
WSAEDESTADDRREQ = EDESTADDRREQ;
WSAEMSGSIZE = EMSGSIZE;
WSAEPROTOTYPE = EPROTOTYPE;
WSAENOPROTOOPT = ENOPROTOOPT;
WSAEPROTONOSUPPORT = EPROTONOSUPPORT;
WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT;
WSAEOPNOTSUPP = EOPNOTSUPP;
WSAEPFNOSUPPORT = EPFNOSUPPORT;
WSAEAFNOSUPPORT = EAFNOSUPPORT;
WSAEADDRINUSE = EADDRINUSE;
WSAEADDRNOTAVAIL = EADDRNOTAVAIL;
WSAENETDOWN = ENETDOWN;
WSAENETUNREACH = ENETUNREACH;
WSAENETRESET = ENETRESET;
WSAECONNABORTED = ECONNABORTED;
WSAECONNRESET = ECONNRESET;
WSAENOBUFS = ENOBUFS;
WSAEISCONN = EISCONN;
WSAENOTCONN = ENOTCONN;
WSAESHUTDOWN = ESHUTDOWN;
WSAETOOMANYREFS = ETOOMANYREFS;
WSAETIMEDOUT = ETIMEDOUT;
WSAECONNREFUSED = ECONNREFUSED;
WSAELOOP = ELOOP;
WSAENAMETOOLONG = ENAMETOOLONG;
WSAEHOSTDOWN = EHOSTDOWN;
WSAEHOSTUNREACH = EHOSTUNREACH;
WSAENOTEMPTY = ENOTEMPTY;
WSAEPROCLIM = -1;
WSAEUSERS = EUSERS;
WSAEDQUOT = EDQUOT;
WSAESTALE = ESTALE;
WSAEREMOTE = EREMOTE;
WSASYSNOTREADY = -2;
WSAEOPNOTSUPP = EOPNOTSUPP;
WSAEPFNOSUPPORT = EPFNOSUPPORT;
WSAEAFNOSUPPORT = EAFNOSUPPORT;
WSAEADDRINUSE = EADDRINUSE;
WSAEADDRNOTAVAIL = EADDRNOTAVAIL;
WSAENETDOWN = ENETDOWN;
WSAENETUNREACH = ENETUNREACH;
WSAENETRESET = ENETRESET;
WSAECONNABORTED = ECONNABORTED;
WSAECONNRESET = ECONNRESET;
WSAENOBUFS = ENOBUFS;
WSAEISCONN = EISCONN;
WSAENOTCONN = ENOTCONN;
WSAESHUTDOWN = ESHUTDOWN;
WSAETOOMANYREFS = ETOOMANYREFS;
WSAETIMEDOUT = ETIMEDOUT;
WSAECONNREFUSED = ECONNREFUSED;
WSAELOOP = ELOOP;
WSAENAMETOOLONG = ENAMETOOLONG;
WSAEHOSTDOWN = EHOSTDOWN;
WSAEHOSTUNREACH = EHOSTUNREACH;
WSAENOTEMPTY = ENOTEMPTY;
WSAEPROCLIM = -1;
WSAEUSERS = EUSERS;
WSAEDQUOT = EDQUOT;
WSAESTALE = ESTALE;
WSAEREMOTE = EREMOTE;
WSASYSNOTREADY = -2;
WSAVERNOTSUPPORTED = -3;
WSANOTINITIALISED = -4;
WSAEDISCON = -5;
WSAHOST_NOT_FOUND = HOST_NOT_FOUND;
WSATRY_AGAIN = TRY_AGAIN;
WSANO_RECOVERY = NO_RECOVERY;
WSANOTINITIALISED = -4;
WSAEDISCON = -5;
WSAHOST_NOT_FOUND = HOST_NOT_FOUND;
WSATRY_AGAIN = TRY_AGAIN;
WSANO_RECOVERY = NO_RECOVERY;
// WSANO_DATA = NO_DATA;
WSANO_DATA = -6;
WSANO_DATA = -6;
{$ELSE}
const
DLLStackName = 'wsock32.dll';
var
LibHandle : THandle = 0;
LibHandle: THandle = 0;
{$ENDIF}
{$IFDEF LINUX}
const
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
TWSAData = packed record
@ -111,321 +114,328 @@ type
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;
DWORD=integer;
TLinger=Linger;
DWORD = Integer;
TLinger = Linger;
{$ENDIF}
type
TWSAStartup = function (wVersionRequired: word;
var WSData: TWSAData): Integer; stdcall;
TWSACleanup = function : Integer; stdcall;
TWSAGetLastError = function : Integer; stdcall;
TGetServByName = function (name, proto: PChar): PServEnt; stdcall;
TGetServByPort = function (port: Integer; proto: PChar): PServEnt; stdcall;
TGetProtoByName = function (name: PChar): PProtoEnt; stdcall;
TGetProtoByNumber = function (proto: Integer): PProtoEnt; stdcall;
TGetHostByName = function (name: PChar): PHostEnt; stdcall;
TGetHostByAddr = function (addr: Pointer; len, Struct: Integer): PHostEnt; stdcall;
TGetHostName = function (name: PChar; len: Integer): Integer; stdcall;
TShutdown = function (s: TSocket; how: Integer): Integer; stdcall;
TSetSockOpt = function (s: TSocket; level, optname: Integer;
optval: PChar;
optlen: Integer): Integer; stdcall;
TGetSockOpt = function (s: TSocket; level, optname: Integer;
optval: PChar;
var optlen: Integer): Integer; stdcall;
TSendTo = function (s: TSocket; var Buf;
len, flags: Integer;
var addrto: TSockAddr;
tolen: Integer): Integer; stdcall;
TSend = function (s: TSocket; var Buf;
len, flags: Integer): Integer; stdcall;
TRecv = function (s: TSocket;
var Buf;
len, flags: Integer): Integer; stdcall;
TRecvFrom = function (s: TSocket;
var Buf; len, flags: Integer;
var from: TSockAddr;
var fromlen: Integer): Integer; stdcall;
Tntohs = function (netshort: u_short): u_short; stdcall;
Tntohl = function (netlong: u_long): u_long; stdcall;
TListen = function (s: TSocket;
backlog: Integer): Integer; stdcall;
TIoctlSocket = function (s: TSocket; cmd: DWORD;
var arg: u_long): Integer; stdcall;
TInet_ntoa = function (inaddr: TInAddr): PChar; stdcall;
TInet_addr = function (cp: PChar): u_long; stdcall;
Thtons = function (hostshort: u_short): u_short; stdcall;
Thtonl = function (hostlong: u_long): u_long; stdcall;
TGetSockName = function (s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer; stdcall;
TGetPeerName = function (s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer; stdcall;
TConnect = function (s: TSocket; var name: TSockAddr;
namelen: Integer): Integer; stdcall;
TCloseSocket = function (s: TSocket): Integer; stdcall;
TBind = function (s: TSocket; var addr: TSockAddr;
namelen: Integer): Integer; stdcall;
TAccept = function (s: TSocket; addr: PSockAddr;
addrlen: PInteger): TSocket; stdcall;
TSocketProc = function (af, Struct, protocol: Integer): TSocket; stdcall;
TSelect = function (nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint; stdcall;
TWSAStartup = function(wVersionRequired: Word;
var WSData: TWSAData): Integer; stdcall;
TWSACleanup = function: Integer; stdcall;
TWSAGetLastError = function: Integer; stdcall;
TGetServByName = function(name, proto: PChar): PServEnt; stdcall;
TGetServByPort = function(port: Integer; proto: PChar): PServEnt; stdcall;
TGetProtoByName = function(name: PChar): PProtoEnt; stdcall;
TGetProtoByNumber = function(proto: Integer): PProtoEnt; stdcall;
TGetHostByName = function(name: PChar): PHostEnt; stdcall;
TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt; stdcall;
TGetHostName = function(name: PChar; len: Integer): Integer; stdcall;
TShutdown = function(s: TSocket; how: Integer): Integer; stdcall;
TSetSockOpt = function(s: TSocket; level, optname: Integer;
optval: PChar; optlen: Integer): Integer; stdcall;
TGetSockOpt = function(s: TSocket; level, optname: Integer;
optval: PChar; var optlen: Integer): Integer; stdcall;
TSendTo = function(s: TSocket; var Buf;
len, flags: Integer; var addrto: TSockAddr;
tolen: Integer): Integer; stdcall;
TSend = function(s: TSocket; var Buf;
len, flags: Integer): Integer; stdcall;
TRecv = function(s: TSocket;
var Buf; len, flags: Integer): Integer; stdcall;
TRecvFrom = function(s: TSocket;
var Buf; len, flags: Integer; var from: TSockAddr;
var fromlen: Integer): Integer; stdcall;
Tntohs = function(netshort: u_short): u_short; stdcall;
Tntohl = function(netlong: u_long): u_long; stdcall;
TListen = function(s: TSocket; backlog: Integer): Integer; stdcall;
TIoctlSocket = function(s: TSocket; cmd: DWORD;
var arg: u_long): Integer; stdcall;
TInet_ntoa = function(inaddr: TInAddr): PChar; stdcall;
TInet_addr = function(cp: PChar): u_long; stdcall;
Thtons = function(hostshort: u_short): u_short; stdcall;
Thtonl = function(hostlong: u_long): u_long; stdcall;
TGetSockName = function(s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer; stdcall;
TGetPeerName = function(s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer; stdcall;
TConnect = function(s: TSocket; var name: TSockAddr;
namelen: Integer): Integer; stdcall;
TCloseSocket = function(s: TSocket): Integer; stdcall;
TBind = function(s: TSocket; var addr: TSockAddr;
namelen: Integer): Integer; stdcall;
TAccept = function(s: TSocket; addr: PSockAddr;
addrlen: PInteger): TSocket; stdcall;
TSocketProc = function(af, Struc, Protocol: Integer): TSocket; stdcall;
TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint; stdcall;
var
WSAStartup : TWSAStartup =nil;
WSACleanup : TWSACleanup =nil;
WSAGetLastError : TWSAGetLastError =nil;
GetServByName : TGetServByName =nil;
GetServByPort : TGetServByPort =nil;
GetProtoByName : TGetProtoByName =nil;
GetProtoByNumber : TGetProtoByNumber =nil;
GetHostByName : TGetHostByName =nil;
GetHostByAddr : TGetHostByAddr =nil;
GetHostName : TGetHostName =nil;
Shutdown : TShutdown =nil;
SetSockOpt : TSetSockOpt =nil;
GetSockOpt : TGetSockOpt =nil;
SendTo : TSendTo =nil;
Send : TSend =nil;
Recv : TRecv =nil;
RecvFrom : TRecvFrom =nil;
ntohs : Tntohs =nil;
ntohl : Tntohl =nil;
Listen : TListen =nil;
IoctlSocket : TIoctlSocket =nil;
Inet_ntoa : TInet_ntoa =nil;
Inet_addr : TInet_addr =nil;
htons : Thtons =nil;
htonl : Thtonl =nil;
GetSockName : TGetSockName =nil;
GetPeerName : TGetPeerName =nil;
Connect : TConnect =nil;
CloseSocket : TCloseSocket =nil;
Bind : TBind =nil;
Accept : TAccept =nil;
Socket : TSocketProc =nil;
Select : TSelect =nil;
WSAStartup: TWSAStartup = nil;
WSACleanup: TWSACleanup = nil;
WSAGetLastError: TWSAGetLastError = nil;
GetServByName: TGetServByName = nil;
GetServByPort: TGetServByPort = nil;
GetProtoByName: TGetProtoByName = nil;
GetProtoByNumber: TGetProtoByNumber = nil;
GetHostByName: TGetHostByName = nil;
GetHostByAddr: TGetHostByAddr = nil;
GetHostName: TGetHostName = nil;
Shutdown: TShutdown = nil;
SetSockOpt: TSetSockOpt = nil;
GetSockOpt: TGetSockOpt = nil;
SendTo: TSendTo = nil;
Send: TSend = nil;
Recv: TRecv = nil;
RecvFrom: TRecvFrom = nil;
ntohs: Tntohs = nil;
ntohl: Tntohl = nil;
Listen: TListen = nil;
IoctlSocket: TIoctlSocket = nil;
Inet_ntoa: TInet_ntoa = nil;
Inet_addr: TInet_addr = nil;
htons: Thtons = nil;
htonl: Thtonl = nil;
GetSockName: TGetSockName = nil;
GetPeerName: TGetPeerName = nil;
Connect: TConnect = nil;
CloseSocket: TCloseSocket = nil;
Bind: TBind = nil;
Accept: TAccept = nil;
Socket: TSocketProc = nil;
Select: TSelect = nil;
function InitSocketInterface(stack:string):Boolean;
function DestroySocketInterface:Boolean;
function InitSocketInterface(stack: string): Boolean;
function DestroySocketInterface: Boolean;
{$IFDEF LINUX}
function LSWSAStartup (wVersionRequired: Word; var WSData: TWSAData): Integer; stdcall;
function LSWSACleanup : Integer; stdcall;
function LSWSAGetLastError : Integer; stdcall;
function LSGetServByName (name, proto: PChar): PServEnt; stdcall;
function LSGetServByPort (port: Integer; proto: PChar): PServEnt; stdcall;
function LSGetProtoByName (name: PChar): PProtoEnt; stdcall;
function LSGetProtoByNumber (proto: Integer): PProtoEnt; stdcall;
function LSGetHostByName (name: PChar): PHostEnt; stdcall;
function LSGetHostByAddr (addr: Pointer; len, Struct: Integer): PHostEnt; stdcall;
function LSGetHostName (name: PChar; len: Integer): Integer; stdcall;
function LSShutdown (s: TSocket; how: Integer): Integer; stdcall;
function LSSetSockOpt (s: TSocket; level, optname: Integer; optval: PChar; optlen: Integer): Integer; stdcall;
function LSGetSockOpt (s: TSocket; level, optname: Integer; optval: PChar; var optlen: Integer): Integer; stdcall;
function LSSendTo (s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr; tolen: Integer): Integer; stdcall;
function LSSend (s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
function LSRecv (s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
function LSRecvFrom (s: TSocket; var Buf; len, flags: Integer; var from: TSockAddr; var fromlen: Integer): Integer; stdcall;
function LSntohs (netshort: u_short): u_short; stdcall;
function LSntohl (netlong: u_long): u_long; stdcall;
function LSListen (s: TSocket; backlog: Integer): Integer; stdcall;
function LSIoctlSocket (s: TSocket; cmd: DWORD; var arg: u_long): Integer; stdcall;
function LSInet_ntoa (inaddr: TInAddr): PChar; stdcall;
function LSInet_addr (cp: PChar): u_long; stdcall;
function LShtons (hostshort: u_short): u_short; stdcall;
function LShtonl (hostlong: u_long): u_long; stdcall;
function LSGetSockName (s: TSocket; var name: TSockAddr; var namelen: Integer): Integer; stdcall;
function LSGetPeerName (s: TSocket; var name: TSockAddr; var namelen: Integer): Integer; stdcall;
function LSConnect (s: TSocket; var name: TSockAddr; namelen: Integer): Integer; stdcall;
function LSCloseSocket (s: TSocket): Integer; stdcall;
function LSBind (s: TSocket; var addr: TSockAddr; namelen: Integer): Integer; stdcall;
function LSAccept (s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket; stdcall;
function LSSocketProc (af, Struct, protocol: Integer): TSocket; stdcall;
function LSSelect (nfds: Integer; readfds, writefds, exceptfds: PFDSet; timeout: PTimeVal): Longint; stdcall;
function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; stdcall;
function LSWSACleanup: Integer; stdcall;
function LSWSAGetLastError: Integer; stdcall;
function LSGetServByName(name, proto: PChar): PServEnt; stdcall;
function LSGetServByPort(port: Integer; proto: PChar): PServEnt; stdcall;
function LSGetProtoByName(name: PChar): PProtoEnt; stdcall;
function LSGetProtoByNumber(proto: Integer): PProtoEnt; stdcall;
function LSGetHostByName(name: PChar): PHostEnt; stdcall;
function LSGetHostByAddr(addr: Pointer; len, Struc: Integer): PHostEnt; stdcall;
function LSGetHostName(name: PChar; len: Integer): Integer; stdcall;
function LSShutdown(s: TSocket; how: Integer): Integer; stdcall;
function LSSetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
optlen: Integer): Integer; stdcall;
function LSGetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
var optlen: Integer): Integer; stdcall;
function LSSendTo(s: TSocket; var Buf; len, flags: Integer;
var addrto: TSockAddr; tolen: Integer): Integer; stdcall;
function LSSend(s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
function LSRecv(s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
function LSRecvFrom(s: TSocket; var Buf; len, flags: Integer;
var from: TSockAddr; var fromlen: Integer): Integer; stdcall;
function LSntohs(netshort: u_short): u_short; stdcall;
function LSntohl(netlong: u_long): u_long; stdcall;
function LSListen(s: TSocket; backlog: Integer): Integer; stdcall;
function LSIoctlSocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer; stdcall;
function LSInet_ntoa(inaddr: TInAddr): PChar; stdcall;
function LSInet_addr(cp: PChar): u_long; stdcall;
function LShtons(hostshort: u_short): u_short; stdcall;
function LShtonl(hostlong: u_long): u_long; stdcall;
function LSGetSockName(s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer; stdcall;
function LSGetPeerName(s: TSocket; var name: TSockAddr;
var namelen: Integer): Integer; stdcall;
function LSConnect(s: TSocket; var name: TSockAddr; namelen: Integer): Integer; stdcall;
function LSCloseSocket(s: TSocket): Integer; stdcall;
function LSBind(s: TSocket; var addr: TSockAddr; namelen: Integer): Integer; stdcall;
function LSAccept(s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket; stdcall;
function LSSocketProc(af, Struc, Protocol: Integer): TSocket; stdcall;
function LSSelect(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint; stdcall;
{$ENDIF}
implementation
{$IFDEF LINUX}
function LSWSAStartup (wVersionRequired: Word; var WSData: TWSAData): Integer;
function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
begin
WSData.wVersion:=wVersionRequired;
WSData.wHighVersion:=$101;
WSData.szDescription:='Synapse Platform Independent Socket Layer';
WSData.szSystemStatus:='On Linux';
WSData.iMaxSockets:=32768;
WSData.iMaxUdpDg:=8192;
result:=0;
with WSData do
begin
wVersion := wVersionRequired;
wHighVersion := $101;
szDescription := 'Synapse Platform Independent Socket Layer';
szSystemStatus := 'On Linux';
iMaxSockets := 32768;
iMaxUdpDg := 8192;
end;
Result := 0;
end;
function LSWSACleanup : Integer;
function LSWSACleanup: Integer;
begin
Result:=0;
Result := 0;
end;
function LSWSAGetLastError : Integer;
function LSWSAGetLastError: Integer;
begin
result:=System.GetLastError;
Result := System.GetLastError;
end;
function LSGetServByName (name, proto: PChar): PServEnt;
function LSGetServByName(name, proto: PChar): PServEnt;
begin
result:=libc.GetServByName(name,proto);
Result := libc.GetServByName(name, proto);
end;
function LSGetServByPort (port: Integer; proto: PChar): PServEnt;
function LSGetServByPort(port: Integer; proto: PChar): PServEnt;
begin
result:=libc.GetServByPort(port,proto);
Result := libc.GetServByPort(port, proto);
end;
function LSGetProtoByName (name: PChar): PProtoEnt;
function LSGetProtoByName(name: PChar): PProtoEnt;
begin
result:=libc.getprotobyname(Name);
Result := libc.GetProtoByName(Name);
end;
function LSGetProtoByNumber (proto: Integer): PProtoEnt;
function LSGetProtoByNumber(proto: Integer): PProtoEnt;
begin
result:=libc.getprotobynumber(proto);
Result := libc.GetProtoByNumber(proto);
end;
function LSGetHostByName (name: PChar): PHostEnt;
function LSGetHostByName(name: PChar): PHostEnt;
begin
result:=libc.GetHostByName(Name);
Result := libc.GetHostByName(Name);
end;
function LSGetHostByAddr (addr: Pointer; len, Struct: Integer): PHostEnt;
function LSGetHostByAddr(addr: Pointer; len, Struc: Integer): PHostEnt;
begin
Result:=libc.GetHostByAddr(Addr,len,struct);
Result := libc.GetHostByAddr(Addr, len, struc);
end;
function LSGetHostName (name: PChar; len: Integer): Integer;
function LSGetHostName(name: PChar; len: Integer): Integer;
begin
Result:=libc.GetHostName(Name,Len);
Result := libc.GetHostName(Name, Len);
end;
function LSShutdown (s: TSocket; how: Integer): Integer;
function LSShutdown(s: TSocket; how: Integer): Integer;
begin
result:=libc.Shutdown(S,How);
Result := libc.Shutdown(S, How);
end;
function LSSetSockOpt (s: TSocket; level, optname: Integer; optval: PChar; optlen: Integer): Integer;
function LSSetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
optlen: Integer): Integer;
begin
result:=libc.SetSockOpt(S,Level,OptName,OptVal,OptLen);
Result := libc.SetSockOpt(S, Level, OptName, OptVal, OptLen);
end;
function LSGetSockOpt (s: TSocket; level, optname: Integer; optval: PChar; var optlen: Integer): Integer;
function LSGetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
var optlen: Integer): Integer;
begin
result:=libc.getsockopt(s,level,optname,optval,cardinal(optlen));
Result := libc.getsockopt(s, level, optname, optval, cardinal(optlen));
end;
function LSSendTo (s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr; tolen: Integer): Integer;
function LSSendTo(s: TSocket; var Buf; len, flags: Integer;
var addrto: TSockAddr; tolen: Integer): Integer;
begin
result:=libc.SendTo(S,Buf,Len,Flags,Addrto,Tolen);
Result := libc.SendTo(S, Buf, Len, Flags, Addrto, Tolen);
end;
function LSSend (s: TSocket; var Buf; len, flags: Integer): Integer;
function LSSend(s: TSocket; var Buf; len, flags: Integer): Integer;
begin
result:=libc.Send(S,Buf,Len,Flags);
Result := libc.Send(S, Buf, Len, Flags);
end;
function LSRecv (s: TSocket; var Buf; len, flags: Integer): Integer;
function LSRecv(s: TSocket; var Buf; len, flags: Integer): Integer;
begin
result:=libc.Recv(S,Buf,Len,Flags);
Result := libc.Recv(S, Buf, Len, Flags);
end;
function LSRecvFrom (s: TSocket; var Buf; len, flags: Integer; var from: TSockAddr; var fromlen: Integer): Integer;
function LSRecvFrom(s: TSocket; var Buf; len, flags: Integer;
var from: TSockAddr; var fromlen: Integer): Integer;
begin
result:=libc.RecvFrom(S,Buf,Len,Flags,@from,@fromlen);
Result := libc.RecvFrom(S, Buf, Len, Flags, @from, @fromlen);
end;
function LSntohs (netshort: u_short): u_short;
function LSntohs(netshort: u_short): u_short;
begin
Result:=libc.NToHS(netshort);
Result := libc.NToHS(netshort);
end;
function LSntohl (netlong: u_long): u_long;
function LSntohl(netlong: u_long): u_long;
begin
Result:=libc.NToHL(netlong);
Result := libc.NToHL(netlong);
end;
function LSListen (s: TSocket; backlog: Integer): Integer;
function LSListen(s: TSocket; backlog: Integer): Integer;
begin
result:=libc.Listen(S,Backlog);
Result := libc.Listen(S, Backlog);
end;
function LSIoctlSocket (s: TSocket; cmd: DWORD; var arg: u_long): Integer;
function LSIoctlSocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer;
begin
result:=libc.ioctl(s,cmd,@arg);
Result := libc.ioctl(s, cmd, @arg);
end;
function LSInet_ntoa (inaddr: TInAddr): PChar;
function LSInet_ntoa(inaddr: TInAddr): PChar;
begin
result:=libc.inet_ntoa(inaddr);
Result := libc.inet_ntoa(inaddr);
end;
function LSInet_addr (cp: PChar): u_long;
function LSInet_addr(cp: PChar): u_long;
begin
result:=libc.inet_addr(cp);
Result := libc.inet_addr(cp);
end;
function LShtons (hostshort: u_short): u_short;
function LShtons(hostshort: u_short): u_short;
begin
result:=libc.HToNs(HostShort);
Result := libc.HToNs(HostShort);
end;
function LShtonl (hostlong: u_long): u_long;
function LShtonl(hostlong: u_long): u_long;
begin
Result:=libc.HToNL(HostLong);
Result := libc.HToNL(HostLong);
end;
function LSGetSockName (s: TSocket; var name: TSockAddr; var namelen: Integer): Integer;
function LSGetSockName(s: TSocket; var name: TSockAddr; var namelen: Integer): Integer;
begin
Result:=libc.GetSockName(S,Name,cardinal(namelen));
Result := libc.GetSockName(S, Name, cardinal(namelen));
end;
function LSGetPeerName (s: TSocket; var name: TSockAddr; var namelen: Integer): Integer;
function LSGetPeerName(s: TSocket; var name: TSockAddr; var namelen: Integer): Integer;
begin
Result:=libc.GetPeerName(S,Name,cardinal(namelen));
Result := libc.GetPeerName(S, Name, cardinal(namelen));
end;
function LSConnect (s: TSocket; var name: TSockAddr; namelen: Integer): Integer;
function LSConnect(s: TSocket; var name: TSockAddr; namelen: Integer): Integer;
begin
result:=libc.Connect(S,name,namelen);
Result := libc.Connect(S, name, namelen);
end;
function LSCloseSocket (s: TSocket): Integer;
function LSCloseSocket(s: TSocket): Integer;
begin
result:=libc.__close(s);
Result := libc.__close(s);
end;
function LSBind (s: TSocket; var addr: TSockAddr; namelen: Integer): Integer;
function LSBind(s: TSocket; var addr: TSockAddr; namelen: Integer): Integer;
begin
result:=libc.Bind(S,addr,namelen);
Result := libc.Bind(S, addr, namelen);
end;
function LSAccept (s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket;
function LSAccept(s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket;
begin
result:=libc.Accept(S,addr,psocketlength(addrlen));
Result := libc.Accept(S, addr, psocketlength(addrlen));
end;
function LSSocketProc (af, Struct, protocol: Integer): TSocket;
function LSSocketProc(af, Struc, Protocol: Integer): TSocket;
begin
result:=libc.Socket(Af,Struct,Protocol);
Result := libc.Socket(Af, Struc, Protocol);
end;
function LSSelect (nfds: Integer; readfds, writefds, exceptfds: PFDSet; timeout: PTimeVal): Longint;
function LSSelect(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint;
begin
Result:=libc.Select(nfds,readfds,writefds,exceptfds,timeout);
Result := libc.Select(nfds, readfds, writefds, exceptfds, timeout);
end;
{$ENDIF}
function InitSocketInterface(stack:string):Boolean;
function InitSocketInterface(stack: string): Boolean;
begin
{$IFDEF LINUX}
Accept := LSAccept;
@ -451,72 +461,71 @@ begin
SetSockOpt := LSsetsockopt;
ShutDown := LSshutdown;
Socket := LSsocketProc;
GetHostByAddr := LSgethostbyaddr;
GetHostByName := LSgethostbyname;
GetProtoByName := LSgetprotobyname;
GetProtoByNumber := LSgetprotobynumber;
GetServByName := LSgetservbyname;
GetServByPort := LSgetservbyport;
GetHostName := LSgethostname;
GetHostByAddr := LSGetHostByAddr;
GetHostByName := LSGetHostByName;
GetProtoByName := LSGetProtoByName;
GetProtoByNumber := LSGetProtoByNumber;
GetServByName := LSGetServByName;
GetServByPort := LSGetServByPort;
GetHostName := LSGetHostName;
WSAGetLastError := LSWSAGetLastError;
WSAStartup := LSWSAStartup;
WSACleanup := LSWSACleanup;
Result:=True;
Result := True;
{$ELSE}
Result:=False;
if stack=''
then stack:=DLLStackName;
Result := False;
if stack = '' then
stack := DLLStackName;
LibHandle := Windows.LoadLibrary(PChar(Stack));
if LibHandle <> 0 then begin
Accept := Windows.GetProcAddress (LibHandle, PChar('accept'));
Bind := Windows.GetProcAddress (LibHandle, PChar('bind'));
CloseSocket := Windows.GetProcAddress (LibHandle, PChar('closesocket'));
Connect := Windows.GetProcAddress (LibHandle, PChar('connect'));
GetPeerName := Windows.GetProcAddress (LibHandle, PChar('getpeername'));
GetSockName := Windows.GetProcAddress (LibHandle, PChar('getsockname'));
GetSockOpt := Windows.GetProcAddress (LibHandle, PChar('getsockopt'));
Htonl := Windows.GetProcAddress (LibHandle, PChar('htonl'));
Htons := Windows.GetProcAddress (LibHandle, PChar('htons'));
Inet_Addr := Windows.GetProcAddress (LibHandle, PChar('inet_addr'));
Inet_Ntoa := Windows.GetProcAddress (LibHandle, PChar('inet_ntoa'));
IoctlSocket := Windows.GetProcAddress (LibHandle, PChar('ioctlsocket'));
Listen := Windows.GetProcAddress (LibHandle, PChar('listen'));
Ntohl := Windows.GetProcAddress (LibHandle, PChar('ntohl'));
Ntohs := Windows.GetProcAddress (LibHandle, PChar('ntohs'));
Recv := Windows.GetProcAddress (LibHandle, PChar('recv'));
RecvFrom := Windows.GetProcAddress (LibHandle, PChar('recvfrom'));
Select := Windows.GetProcAddress (LibHandle, PChar('select'));
Send := Windows.GetProcAddress (LibHandle, PChar('send'));
SendTo := Windows.GetProcAddress (LibHandle, PChar('sendto'));
SetSockOpt := Windows.GetProcAddress (LibHandle, PChar('setsockopt'));
ShutDown := Windows.GetProcAddress (LibHandle, PChar('shutdown'));
Socket := Windows.GetProcAddress (LibHandle, PChar('socket'));
GetHostByAddr := Windows.GetProcAddress (LibHandle, PChar('gethostbyaddr'));
GetHostByName := Windows.GetProcAddress (LibHandle, PChar('gethostbyname'));
GetProtoByName := Windows.GetProcAddress (LibHandle, PChar('getprotobyname'));
GetProtoByNumber := Windows.GetProcAddress (LibHandle, PChar('getprotobynumber'));
GetServByName := Windows.GetProcAddress (LibHandle, PChar('getservbyname'));
GetServByPort := Windows.GetProcAddress (LibHandle, PChar('getservbyport'));
GetHostName := Windows.GetProcAddress (LibHandle, PChar('gethostname'));
WSAGetLastError := Windows.GetProcAddress (LibHandle, PChar('WSAGetLastError'));
WSAStartup := Windows.GetProcAddress (LibHandle, PChar('WSAStartup'));
WSACleanup := Windows.GetProcAddress (LibHandle, PChar('WSACleanup'));
Result:=True;
if LibHandle <> 0 then
begin
Accept := Windows.GetProcAddress(LibHandle, PChar('accept'));
Bind := Windows.GetProcAddress(LibHandle, PChar('bind'));
CloseSocket := Windows.GetProcAddress(LibHandle, PChar('closesocket'));
Connect := Windows.GetProcAddress(LibHandle, PChar('connect'));
GetPeerName := Windows.GetProcAddress(LibHandle, PChar('getpeername'));
GetSockName := Windows.GetProcAddress(LibHandle, PChar('getsockname'));
GetSockOpt := Windows.GetProcAddress(LibHandle, PChar('getsockopt'));
Htonl := Windows.GetProcAddress(LibHandle, PChar('htonl'));
Htons := Windows.GetProcAddress(LibHandle, PChar('htons'));
Inet_Addr := Windows.GetProcAddress(LibHandle, PChar('inet_addr'));
Inet_Ntoa := Windows.GetProcAddress(LibHandle, PChar('inet_ntoa'));
IoctlSocket := Windows.GetProcAddress(LibHandle, PChar('ioctlsocket'));
Listen := Windows.GetProcAddress(LibHandle, PChar('listen'));
Ntohl := Windows.GetProcAddress(LibHandle, PChar('ntohl'));
Ntohs := Windows.GetProcAddress(LibHandle, PChar('ntohs'));
Recv := Windows.GetProcAddress(LibHandle, PChar('recv'));
RecvFrom := Windows.GetProcAddress(LibHandle, PChar('recvfrom'));
Select := Windows.GetProcAddress(LibHandle, PChar('select'));
Send := Windows.GetProcAddress(LibHandle, PChar('send'));
SendTo := Windows.GetProcAddress(LibHandle, PChar('sendto'));
SetSockOpt := Windows.GetProcAddress(LibHandle, PChar('setsockopt'));
ShutDown := Windows.GetProcAddress(LibHandle, PChar('shutdown'));
Socket := Windows.GetProcAddress(LibHandle, PChar('socket'));
GetHostByAddr := Windows.GetProcAddress(LibHandle, PChar('gethostbyaddr'));
GetHostByName := Windows.GetProcAddress(LibHandle, PChar('gethostbyname'));
GetProtoByName := Windows.GetProcAddress(LibHandle, PChar('getprotobyname'));
GetProtoByNumber := Windows.GetProcAddress(LibHandle, PChar('getprotobynumber'));
GetServByName := Windows.GetProcAddress(LibHandle, PChar('getservbyname'));
GetServByPort := Windows.GetProcAddress(LibHandle, PChar('getservbyport'));
GetHostName := Windows.GetProcAddress(LibHandle, PChar('gethostname'));
WSAGetLastError := Windows.GetProcAddress(LibHandle, PChar('WSAGetLastError'));
WSAStartup := Windows.GetProcAddress(LibHandle, PChar('WSAStartup'));
WSACleanup := Windows.GetProcAddress(LibHandle, PChar('WSACleanup'));
Result := True;
end;
{$ENDIF}
end;
function DestroySocketInterface:Boolean;
function DestroySocketInterface: Boolean;
begin
{$IFDEF LINUX}
{$ELSE}
if LibHandle <> 0 then begin
if LibHandle <> 0 then
Windows.FreeLibrary(libHandle);
end;
LibHandle := 0;
{$ENDIF}
Result:=True;
Result := True;
end;
end.