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

287
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;
if b then
xm := xm or $80;
if x>0
then b:=true;
result:=char(xm)+result;
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)
if Len < $80 then
Result := Char(Len)
else
begin
x:=len;
result:='';
x := Len;
Result := '';
repeat
y := x mod 256;
x := x div 256;
result:=char(y)+result;
Result := Char(y) + Result;
until x = 0;
y:=length(result);
y := Length(Result);
y := y or $80;
result:=char(y)+result;
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]);
Inc(Start);
if (x<$80)
then Result:=x
if x < $80 then
Result := x
else
begin
result:=0;
x:=x and $7f;
Result := 0;
x := x and $7F;
for n := 1 to x do
begin
result:=result*256;
Result := Result * 256;
x := Ord(Buffer[Start]);
Inc(Start);
result:=result+x;
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:='';
Result := '';
repeat
y := x mod 256;
x := x div 256;
result:=char(y)+result;
Result := Char(y) + Result;
until x = 0;
if (not neg) and (result[1]>#$7F)
then result:=#0+result;
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;
neg := Value < 0;
x := Value;
if neg
then x:=x and $7FFFFFFF;
result:='';
if neg then
x := x and $7FFFFFFF;
Result := '';
repeat
y := x mod 256;
x := x div 256;
result:=char(y)+result;
Result := Char(y) + Result;
until x = 0;
if neg
then result[1]:=char(ord(result[1]) or $80);
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;
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;
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,17 +298,17 @@ 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;
x: Integer;
function WalkInt(var s: string): Integer;
var
x: Integer;
t: string;
begin
x:=pos('.',s);
x := Pos('.', s);
if x < 1 then
begin
t := s;
@ -317,62 +316,64 @@ var
end
else
begin
t:=copy(s,1,x-1);
s:=copy(s,x+1,length(s)-x);
t := Copy(s, 1, x - 1);
s := Copy(s, x + 1, Length(s) - x);
end;
result:=StrToIntDef(t,0);
Result := StrToIntDef(t, 0);
end;
begin
result:='';
x:=walkint(mib);
x:=x*40+walkint(mib);
result:=ASNEncOIDItem(x);
while mib<>'' do
Result := '';
x := WalkInt(Mib);
x := x * 40 + WalkInt(Mib);
Result := ASNEncOIDItem(x);
while Mib <> '' do
begin
x:=walkint(mib);
result:=result+ASNEncOIDItem(x);
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:='';
Result := '';
n := 1;
while length(id)+1>n do
while Length(Id) + 1 > n do
begin
x:=ASNDecOIDItem(n,id);
x := ASNDecOIDItem(n, Id);
if (n - 1) = 1 then
begin
y := x div 40;
x := x mod 40;
result:=IntTostr(y);
Result := IntToStr(y);
end;
result:=result+'.'+IntToStr(x);
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);
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
@ -381,19 +382,11 @@ begin
s := StrScan(PChar(Host), '.');
t := Copy(Host, 1, (Length(Host) - Length(s)));
Delete(Host, 1, (Length(Host) - Length(s) + 1));
i := StrTointDef(t, 0);
i := StrToIntDef(t, 0);
Result := Result + Chr(i);
end;
i := StrTointDef(Host, 0);
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.

996
blcksock.pas
View File

File diff suppressed because it is too large Load Diff

363
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): |
@ -26,306 +26,296 @@
// 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;
FTimeout: Integer;
FDNSHost: string;
FRCode: Integer;
FBuffer: string;
FSock: TUDPBlockSocket;
function CompressName(const 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;
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)
if Value = '' then
Result := #0
else
begin
s := '';
for n := 1 to Length(Value) do
if Value[n] = '.' then
begin
Result:=Result+char(Length(s))+s;
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);
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;
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 := '';
while True do
begin
l:=Ord(Buffer[From]);
l := Ord(FBuffer[From]);
Inc(From);
if l=0 then break;
if Result<>'' then Result:=Result+'.';
if (l and $C0)=$C0
then
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;
f := f * 256 + Ord(FBuffer[From]) + 1;
Inc(From);
Result:=Result+Self.decodelabels(f);
break;
Result := Result + DecodeLabels(f);
Break;
end
else
begin
Result:=Result+Copy(Buffer,From,l);
Result := Result + Copy(FBuffer, From, l);
Inc(From, l);
end;
end;
end;
{TDNSSend.DecodeResource}
function TDNSSend.DecodeResource(var i:integer; Name:string;
Qtype:integer):string;
function TDNSSend.DecodeResource(var i: Integer; const Name: string;
QType: Integer): string;
var
Rname: string;
RType,Len,j,x,n:integer;
RType, Len, j, x, n: Integer;
begin
Result := '';
Rname:=decodelabels(i);
Rtype:=DeCodeint(Buffer,i);
Rname := DecodeLabels(i);
RType := DecodeInt(FBuffer, i);
Inc(i, 8);
Len:=DeCodeint(Buffer,i);
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
if (Name = Rname) and (QType = RType) then
begin
case Rtype of
Qtype_A :
case RType of
QTYPE_A:
begin
Result:=IntToStr(Ord(Buffer[j]));
Result := IntToStr(Ord(FBuffer[j]));
Inc(j);
Result:=Result+'.'+IntToStr(Ord(Buffer[j]));
Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j);
Result:=Result+'.'+IntToStr(Ord(Buffer[j]));
Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j);
Result:=Result+'.'+IntToStr(Ord(Buffer[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:
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);
end;
Qtype_SOA :
begin
Result:=Decodelabels(j);
Result:=Result+','+Decodelabels(j);
Result := DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
for n := 1 to 5 do
begin
x:=DecodeInt(Buffer,j)*65536+DecodeInt(Buffer,j+2);
x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
Inc(j, 4);
Result := Result + ',' + IntToStr(x);
end;
end;
Qtype_NULL :
QTYPE_NULL:
begin
end;
Qtype_WKS :
QTYPE_WKS:
begin
end;
Qtype_HINFO,
Qtype_MINFO,
Qtype_RP,
Qtype_ISDN :
QTYPE_HINFO, QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
begin
Result:=Decodelabels(j);
Result:=Result+','+Decodelabels(j);
Result := DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
end;
Qtype_MX,
Qtype_AFSDB,
Qtype_RT,
Qtype_KX :
QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
begin
x:=DecodeInt(Buffer,j);
x := DecodeInt(FBuffer, j);
Inc(j, 2);
Result := IntToStr(x);
Result:=Result+','+Decodelabels(j);
Result := Result + ',' + DecodeLabels(j);
end;
Qtype_TXT :
QTYPE_TXT:
Result := DecodeLabels(j);
QTYPE_GPOS:
begin
Result:=Decodelabels(j);
Result := DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
end;
Qtype_GPOS :
QTYPE_PX:
begin
Result:=Decodelabels(j);
Result:=Result+','+Decodelabels(j);
Result:=Result+','+Decodelabels(j);
end;
Qtype_PX :
begin
x:=DecodeInt(Buffer,j);
x := DecodeInt(FBuffer, j);
Inc(j, 2);
Result := IntToStr(x);
Result:=Result+','+Decodelabels(j);
Result:=Result+','+Decodelabels(j);
Result := Result + ',' + DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
end;
end;
end;
end;
{TDNSSend.DNSQuery}
Function TDNSSend.DNSQuery(Name:string;Qtype:integer;Reply:TStrings):Boolean;
function TDNSSend.DNSQuery(Name: string; QType: Integer;
const Reply: TStrings): Boolean;
var
x,n,i:integer;
flag,qdcount, ancount, nscount, arcount:integer;
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';
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
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
qdcount:=DeCodeint(Buffer,5);
ancount:=DeCodeint(Buffer,7);
nscount:=DeCodeint(Buffer,9);
arcount:=DeCodeint(Buffer,11);
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 (Buffer[i]<>#0) and ((Ord(Buffer[i]) and $C0)<>$C0) do
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);
s := DecodeResource(i, Name, QType);
if s <> '' then
Reply.Add(s);
end;
@ -336,19 +326,20 @@ 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;
n, m, x: Integer;
begin
Result := False;
servers.Clear;
Servers.Clear;
t := TStringList.Create;
DNS := TDNSSend.Create;
try
DNS.DNSHost := DNSHost;
if DNS.DNSQuery(domain,QType_MX,t) then
if DNS.DNSQuery(Domain, QType_MX, t) then
begin
{ normalize preference number to 5 digits }
for n := 0 to t.Count - 1 do
@ -364,7 +355,7 @@ begin
for n := 0 to t.Count - 1 do
begin
x := Pos(',', t[n]);
servers.Add(Copy(t[n],x+1,Length(t[n])-x));
Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x));
end;
Result := True;
end;
@ -375,5 +366,3 @@ begin
end;
end.

501
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;
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;
Sending, Receiving: Boolean;
status100: Boolean;
status100error: string;
ToClose:boolean;
size:integer;
ToClose: Boolean;
Size: Integer;
Prot, User, Pass, Host, Port, Path, Para, URI: string;
n:integer;
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
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
Headers.insert(0,'Content-Length: '+inttostr(Document.size));
if MimeType<>''
then Headers.insert(0,'Content-Type: '+MimeType);
FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
if FMimeType <> '' then
FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
end;
{seting KeepAlives}
if not KeepAlive
then Headers.insert(0,'Connection: close');
{ setting KeepAlives }
if not FKeepAlive then
FHeaders.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
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
HttpHost:=host;
HttpPort:=port;
FHTTPHost := Host;
FHTTPPort := Port;
end
else
begin
HttpHost:=Proxyhost;
HttpPort:=Proxyport;
FHTTPHost := FProxyHost;
FHTTPPort := FProxyPort;
end;
if headers[headers.count-1]<>''
then headers.add('');
if FHeaders[FHeaders.Count - 1] <> '' then
FHeaders.Add('');
{ connect }
if (Alivehost<>HTTPhost) or (AlivePort<>HTTPport)
then
if (FAliveHost <> FHTTPHost) or (FAlivePort <> FHTTPPort) then
begin
sock.CloseSocket;
sock.CreateSocket;
sock.Connect(HTTPHost,HTTPPort);
if sock.lasterror<>0 then Exit;
Alivehost:=HTTPhost;
AlivePort:=HTTPport;
FSock.CloseSocket;
FSock.CreateSocket;
FSock.Connect(FHTTPHost, FHTTPPort);
if FSock.LastError <> 0 then
Exit;
FAliveHost := FHTTPHost;
FAlivePort := FHTTPPort;
end
else
begin
if sock.canread(0) then
if FSock.CanRead(0) then
begin
sock.CloseSocket;
sock.createsocket;
sock.Connect(HTTPHost,HTTPPort);
if sock.lasterror<>0 then Exit;
FSock.CloseSocket;
FSock.CreateSocket;
FSock.Connect(FHTTPHost, FHTTPPort);
if FSock.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;
{ 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;
{ reading Status }
Status100Error := '';
if status100 then
begin
repeat
s:=sock.recvstring(timeout);
if s<>'' then break;
until sock.lasterror<>0;
s := FSock.RecvString(FTimeout);
if s <> '' then
Break;
until FSock.LastError <> 0;
DecodeStatus(s);
if (ResultCode>=100) and (ResultCode<200)
then
begin
if (FResultCode >= 100) and (FResultCode < 200) then
repeat
s:=sock.recvstring(timeout);
if s='' then break;
until sock.lasterror<>0;
end
s := FSock.recvstring(FTimeout);
if s = '' then
Break;
until FSock.LastError <> 0
else
begin
sending:=false;
Sending := False;
Status100Error := s;
end;
end;
{ send document }
if sending then
if Sending then
begin
Sock.SendBuffer(Document.memory,Document.size);
if sock.lasterror<>0 then Exit;
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
if FSock.LastError <> 0 then
Exit;
end;
clear;
size:=-1;
TransferEncoding:=TE_UNKNOWN;
Clear;
Size := -1;
FTransferEncoding := TE_UNKNOWN;
{ read status }
If Status100Error=''
then
if Status100Error = '' then
begin
repeat
s:=sock.recvstring(timeout);
if s<>'' then break;
until sock.lasterror<>0;
if pos('HTTP/',uppercase(s))=1
then
s := FSock.RecvString(FTimeout);
if s <> '' then
Break;
until FSock.LastError <> 0;
if Pos('HTTP/', UpperCase(s)) = 1 then
begin
Headers.add(s);
decodeStatus(s);
FHeaders.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;
FDocument.Write(Pointer(s)^, Length(s));
FResultCode := 0;
end;
end
else Headers.add(Status100Error);
else
FHeaders.Add(Status100Error);
{ if need receive hedaers, receive and parse it }
ToClose:=protocol<>'1.1';
if Headers.count>0 then
ToClose := FProtocol <> '1.1';
if FHeaders.Count > 0 then
repeat
s:=sock.recvstring(timeout);
Headers.Add(s);
if s=''
then break;
su:=uppercase(s);
if pos('CONTENT-LENGTH:',su)=1 then
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);
TransferEncoding:=TE_IDENTITY;
Size := StrToIntDef(SeparateRight(s, ' '), -1);
FTransferEncoding := TE_IDENTITY;
end;
if pos('CONTENT-TYPE:',su)=1 then
MimeType:=separateright(s,' ');
if pos('TRANSFER-ENCODING:',su)=1 then
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
TransferEncoding:=TE_CHUNKED;
s := SeparateRight(su, ' ');
if Pos('CHUNKED', s) > 0 then
FTransferEncoding := TE_CHUNKED;
end;
if pos('CONNECTION: CLOSE',su)=1 then
ToClose:=true;
until sock.lasterror<>0;
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 := 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:='';
FSock.CloseSocket;
FAliveHost := '';
FAlivePort := '';
end;
end;
{THTTPSend.ReadUnknown}
function THTTPSend.ReadUnknown:boolean;
function THTTPSend.ReadUnknown: Boolean;
var
s: string;
begin
result:=false;
repeat
s:=sock.recvstring(timeout);
s := FSock.RecvString(FTimeout);
s := s + CRLF;
document.Write(pointer(s)^,length(s));
until sock.lasterror<>0;
result:=true;
FDocument.Write(Pointer(s)^, Length(s));
until FSock.LastError <> 0;
Result := True;
end;
{THTTPSend.ReadIdentity}
function THTTPSend.ReadIdentity(size:integer):boolean;
function THTTPSend.ReadIdentity(Size: Integer): Boolean;
var
mem: TMemoryStream;
begin
mem:=TMemoryStream.create;
mem := TMemoryStream.Create;
try
mem.SetSize(size);
sock.RecvBufferEx(mem.memory,size,timeout);
result:=sock.lasterror=0;
document.CopyFrom(mem,0);
mem.SetSize(Size);
FSock.RecvBufferEx(mem.Memory, Size, FTimeout);
Result := FSock.LastError = 0;
FDocument.CopyFrom(mem, 0);
finally
mem.free;
mem.Free;
end;
end;
{THTTPSend.ReadChunked}
function THTTPSend.ReadChunked:boolean;
function THTTPSend.ReadChunked: Boolean;
var
s: string;
size:integer;
Size: Integer;
begin
repeat
repeat
s:=sock.recvstring(timeout);
s := FSock.RecvString(FTimeout);
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;
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;
begin
Result:=False;
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;
begin
Result:=False;
HTTP := THTTPSend.Create;
try
Result:=HTTP.HTTPmethod('GET',URL);
Result := HTTP.HTTPMethod('GET', URL);
Response.Seek(0, soFromBeginning);
Response.CopyFrom(HTTP.document,0);
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;
begin
Result:=False;
HTTP := THTTPSend.Create;
try
HTTP.Document.CopyFrom(data,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);
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;
begin
Result:=False;
HTTP := THTTPSend.Create;
try
HTTP.Document.Write(pointer(URLData)^,Length(URLData));
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);
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

162
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;
function InlineDecode(const Value: string; CP: TMimeChar): string;
var
s, su: string;
x,y,z,n:integer;
x, y, z, n: Integer;
ichar: TMimeChar;
c:char;
c: Char;
function SearchEndInline(value:string;be:integer):integer;
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
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
Inc(q);
if (q > 2) and (Value[n + 1] = '=') then
begin
result:=n;
break;
Result := n;
Break;
end;
end;
end;
begin
result:=value;
x:=pos('=?',result);
y:=SearchEndInline(result,x);
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
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);
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);
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:=DecodeChar(s,ichar,CP);
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);
Result := Copy(Result, 1, x - 1) + s +
Copy(Result, y + 2, Length(Result) - y - 1);
x := Pos('=?', Result);
y := SearchEndInline(Result, x);
end;
end;
{==============================================================================}
{InlineEncode}
function InlineEncode(value:string;CP,MimeP:TMimeChar):string;
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
var
s, s1: string;
n:integer;
n: Integer;
begin
s:=DecodeChar(value,CP,MimeP);
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+'?=';
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 NeedInline(const Value: string): boolean;
var
n:integer;
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
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;
Result := True;
Break;
end;
end;
{==============================================================================}
{InlineCode}
function InlineCode(value:string):string;
function InlineCode(const Value: string): string;
var
c: TMimeChar;
begin
if NeedInline(value)
then
if NeedInline(Value) then
begin
c:=IdealCoding(value,GetCurCP,
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);
Result := InlineEncode(Value, GetCurCP, c);
end
else result:=value;
else
Result := Value;
end;
{==============================================================================}
{InlineEmail}
function InlineEmail(value:string):string;
function InlineEmail(const Value: string): string;
var
sd, se: string;
begin
sd:=getEmaildesc(value);
se:=getEmailAddr(value);
if sd=''
then result:=se
else result:='"'+InlineCode(sd)+'"<'+se+'>';
sd := GetEmailDesc(Value);
se := GetEmailAddr(Value);
if sd = '' then
Result := se
else
Result := '"' + InlineCode(sd) + '"<' + se + '>';
end;
{==============================================================================}
begin
exit;
asm
db 'Synapse Inline MIME encoding and decoding library by Lukas Gebauer',0
end;
end.

318
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,112 +19,144 @@
|==============================================================================|
| 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;
TMessHeader = class(TObject)
private
FFrom: string;
FToList: TStringList;
FSubject: string;
FOrganization: string;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
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
PartList:TList;
Lines:TStringList;
header:TMessHeader;
constructor Create;
destructor Destroy; override;
procedure Clear;
function AddPart:integer;
procedure AddPartText(value:tstringList);
procedure AddPartHTML(value:tstringList);
function AddPart: Integer;
procedure AddPartText(Value: TStringList);
procedure AddPartHTML(Value: TStringList);
procedure AddPartHTMLBinary(Value, Cid: string);
procedure AddPartBinary(value:string);
procedure AddPartBinary(Value: string);
procedure EncodeMessage;
procedure FinalizeHeaders;
procedure ParseHeaders;
procedure DecodeMessage;
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;
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,
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;
@ -133,19 +165,19 @@ begin
end;
{==============================================================================}
{TMimeMess.AddPartHTML}
procedure TMimeMess.AddPartHTML(value:tstringList);
procedure TMimeMess.AddPartHTML(Value: TStringList);
var
x:integer;
x: Integer;
begin
x:=Addpart;
x := AddPart;
with TMimePart(PartList[x]) do
begin
value.SaveToStream(decodedlines);
primary:='text';
secondary:='html';
description:='HTML text';
disposition:='inline';
Value.SaveToStream(DecodedLines);
Primary := 'text';
Secondary := 'html';
Description := 'HTML text';
Disposition := 'inline';
CharsetCode := UTF_8;
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
@ -153,164 +185,154 @@ begin
end;
{==============================================================================}
{TMimeMess.AddPartBinary}
procedure TMimeMess.AddPartBinary(value:string);
procedure TMimeMess.AddPartBinary(Value: string);
var
x:integer;
x: Integer;
s: string;
begin
x:=Addpart;
x := AddPart;
with TMimePart(PartList[x]) do
begin
DecodedLines.LoadFromFile(Value);
s:=ExtractFileName(value);
s := ExtractFileName(Value);
MimeTypeFromExt(s);
description:='Attached file: '+s;
disposition:='attachment';
filename:=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;
x: Integer;
s: string;
begin
x:=Addpart;
x := AddPart;
with TMimePart(PartList[x]) do
begin
DecodedLines.LoadFromFile(Value);
s:=ExtractFileName(value);
s := ExtractFileName(Value);
MimeTypeFromExt(s);
description:='Included file: '+s;
disposition:='inline';
contentID:=cid;
filename:=s;
Description := 'Included file: ' + s;
Disposition := 'inline';
ContentID := cid;
FileName := s;
EncodingCode := ME_BASE64;
EncodePart;
end;
end;
{==============================================================================}
{TMimeMess.Encodemessage}
procedure TMimeMess.Encodemessage;
procedure TMimeMess.EncodeMessage;
var
bound: string;
n:integer;
m:TMimepart;
n: Integer;
begin
lines.clear;
If PartList.Count=1
then
Lines.assign(TMimePart(PartList[0]).lines)
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
bound := GenerateBoundary;
for n := 0 to PartList.Count - 1 do
begin
Lines.add('--'+bound);
lines.AddStrings(TMimePart(PartList[n]).lines);
Lines.Add('--' + bound);
Lines.AddStrings(TMimePart(PartList[n]).Lines);
end;
Lines.add('--'+bound);
m:=TMimePart.Create;
Lines.Add('--' + bound);
with TMimePart.Create do
try
Lines.SaveToStream(m.DecodedLines);
m.Primary:='Multipart';
m.secondary:='mixed';
m.description:='Multipart message';
m.boundary:=bound;
m.EncodePart;
Lines.assign(m.lines);
Self.Lines.SaveToStream(DecodedLines);
Primary := 'Multipart';
Secondary := 'mixed';
Description := 'Multipart message';
Boundary := bound;
EncodePart;
Self.Lines.Assign(Lines);
finally
m.free;
Free;
end;
end;
end;
{==============================================================================}
{TMimeMess.FinalizeHeaders}
procedure TMimeMess.FinalizeHeaders;
var
n:integer;
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));
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;
{==============================================================================}
{TMimeMess.ParseHeaders}
procedure TMimeMess.ParseHeaders;
var
s: string;
x:integer;
x: Integer;
cp: TMimeChar;
begin
cp:=getCurCP;
header.ToList.clear;
cp := GetCurCP;
FHeader.Clear;
x := 0;
while lines.count>x do
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));
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;
{==============================================================================}
{TMimeMess.DecodeMessage}
procedure TMimeMess.DecodeMessage;
var
l:tstringlist;
m:tmimepart;
x,i:integer;
l: TStringList;
m: TMimePart;
x, i: Integer;
bound: string;
begin
l:=tstringlist.create;
m:=tmimepart.create;
l := TStringList.Create;
m := TMimePart.Create;
try
l.assign(lines);
with header do
begin
from:='';
ToList.clear;
subject:='';
organization:='';
end;
l.Assign(Lines);
FHeader.Clear;
ParseHeaders;
m.ExtractPart(l, 0);
if m.primarycode=MP_MULTIPART
then
if m.PrimaryCode = MP_MULTIPART then
begin
bound:=m.boundary;
bound := m.Boundary;
i := 0;
repeat
x := AddPart;
with TMimePart(PartList[x]) do
begin
boundary:=bound;
Boundary := bound;
i := ExtractPart(l, i);
DecodePart;
end;
until i>=l.count-2;
until i >= l.Count - 2;
end
else
begin
@ -322,11 +344,9 @@ begin
end;
end;
finally
m.free;
l.free;
m.Free;
l.Free;
end;
end;
{==============================================================================}
end.

615
mimepart.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.004.000 |
| Project : Delphree - Synapse | 001.004.001 |
|==============================================================================|
| Content: 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/ |
| |
@ -28,57 +28,61 @@ unit MIMEpart;
interface
uses
sysutils, classes, MIMEchar, SynaCode, SynaUtil, MIMEinLn;
SysUtils, Classes,
SynaChar, SynaCode, SynaUtil, MIMEinLn;
type
TMimePrimary=(MP_TEXT,
MP_MULTIPART,
MP_MESSAGE,
MP_BINARY);
TMimePrimary = (MP_TEXT, MP_MULTIPART,
MP_MESSAGE, MP_BINARY);
TMimeEncoding=(ME_7BIT,
ME_8BIT,
ME_QUOTED_PRINTABLE,
ME_BASE64,
ME_UU,
ME_XX);
TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE,
ME_BASE64, ME_UU, ME_XX);
TMimePart=class
TMimePart = class(TObject)
private
FPrimary: string;
FEncoding: string;
FCharset: string;
procedure Setprimary(Value:string);
FPrimaryCode: TMimePrimary;
FEncodingCode: TMimeEncoding;
FCharsetCode: TMimeChar;
FTargetCharset: TMimeChar;
FSecondary: string;
FDescription: string;
FDisposition: string;
FContentID: string;
FBoundary: string;
FFileName: string;
FLines: TStringList;
FDecodedLines: TMemoryStream;
procedure SetPrimary(Value: string);
procedure SetEncoding(Value: string);
procedure SetCharset(Value: string);
protected
public
PrimaryCode:TMimePrimary;
EncodingCode:TMimeEncoding;
CharsetCode:TMimeChar;
TargetCharset:TMimeChar;
secondary:string;
description:string;
disposition:string;
contentID:string;
boundary:string;
FileName:string;
Lines:TStringList;
DecodedLines:TmemoryStream;
constructor Create;
destructor Destroy; override;
procedure clear;
function ExtractPart(value:TStringList; BeginLine:integer):integer;
procedure Clear;
function ExtractPart(Value: TStringList; BeginLine: Integer): Integer;
procedure DecodePart;
procedure EncodePart;
procedure MimeTypeFromExt(value:string);
property
Primary:string read FPrimary Write SetPrimary;
property
encoding:string read FEncoding write SetEncoding;
property
Charset:string read FCharset write SetCharset;
procedure MimeTypeFromExt(Value: string);
published
property Primary: string read FPrimary write SetPrimary;
property Encoding: string read FEncoding write SetEncoding;
property Charset: string read FCharset write SetCharset;
property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode;
property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode;
property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset;
property Secondary: string read FSecondary Write FSecondary;
property Description: string read FDescription Write FDescription;
property Disposition: string read FDisposition Write FDisposition;
property ContentID: string read FContentID Write FContentID;
property Boundary: string read FBoundary Write FBoundary;
property FileName: string read FFileName Write FFileName;
property Lines: TStringList read FLines Write FLines;
property DecodedLines: TMemoryStream read FDecodedLines Write FDecodedLines;
end;
const
@ -113,468 +117,443 @@ const
('ZIP', 'application', 'ZIP')
);
function NormalizeHeader(value:TStringList;var index:integer):string;
function NormalizeHeader(Value: TStringList; var Index: Integer): string;
function GenerateBoundary: string;
implementation
function NormalizeHeader(value:TStringList;var index:integer):string;
function NormalizeHeader(Value: TStringList; var Index: Integer): string;
var
s, t: string;
n:integer;
n: Integer;
begin
s:=value[index];
inc(index);
if s<>''
then
while (value.Count-1) > index do
s := Value[Index];
Inc(Index);
if s <> '' then
while (Value.Count - 1) > Index do
begin
t:=value[index];
if t=''
then break;
for n:=1 to length(t) do
if t[n]=#9
then t[n]:=' ';
if t[1]<>' '
then break
t := Value[Index];
if t = '' then
Break;
for n := 1 to Length(t) do
if t[n] = #9 then
t[n] := ' ';
if t[1] <> ' ' then
Break
else
begin
s:=s+' '+trim(t);
inc(index);
s := s + ' ' + Trim(t);
Inc(Index);
end;
end;
result:=s;
Result := s;
end;
{==============================================================================}
{TMIMEPart.Create}
Constructor TMIMEPart.Create;
constructor TMIMEPart.Create;
begin
inherited Create;
Lines:=TStringList.Create;
DecodedLines:=TmemoryStream.create;
TargetCharset:=GetCurCP;
FLines := TStringList.Create;
FDecodedLines := TMemoryStream.Create;
FTargetCharset := GetCurCP;
end;
{TMIMEPart.Destroy}
Destructor TMIMEPart.Destroy;
destructor TMIMEPart.Destroy;
begin
DecodedLines.free;
Lines.free;
inherited destroy;
FDecodedLines.Free;
FLines.Free;
inherited Destroy;
end;
{==============================================================================}
{TMIMEPart.Clear}
procedure TMIMEPart.Clear;
begin
FPrimary := '';
FEncoding := '';
FCharset := '';
PrimaryCode:=MP_TEXT;
EncodingCode:=ME_7BIT;
CharsetCode:=ISO_8859_1;
TargetCharset:=GetCurCP;
secondary:='';
disposition:='';
contentID:='';
description:='';
boundary:='';
FileName:='';
Lines.clear;
DecodedLines.clear;
FPrimaryCode := MP_TEXT;
FEncodingCode := ME_7BIT;
FCharsetCode := ISO_8859_1;
FTargetCharset := GetCurCP;
FSecondary := '';
FDisposition := '';
FContentID := '';
FDescription := '';
FBoundary := '';
FFileName := '';
FLines.Clear;
FDecodedLines.Clear;
end;
{==============================================================================}
{TMIMEPart.ExtractPart}
function TMIMEPart.ExtractPart(value:TStringList; BeginLine:integer):integer;
function TMIMEPart.ExtractPart(Value: TStringList; BeginLine: Integer): Integer;
var
n,x,x1,x2:integer;
t:tstringlist;
n, x, x1, x2: Integer;
t: TStringList;
s, su, b: string;
st, st2: string;
e:boolean;
e: Boolean;
fn: string;
begin
t:=tstringlist.create;
t := TStringlist.Create;
try
{ defaults }
lines.clear;
primary:='text';
secondary:='plain';
description:='';
charset:='US-ASCII';
FileName:='';
encoding:='7BIT';
FLines.Clear;
Primary := 'text';
FSecondary := 'plain';
FDescription := '';
Charset := 'US-ASCII';
FFileName := '';
Encoding := '7BIT';
fn := '';
x:=beginline;
b:=boundary;
x := BeginLine;
b := FBoundary;
if b <> '' then
while value.count>x do
while Value.Count > x do
begin
s:=value[x];
inc(x);
if pos('--'+b,s)>0
then break;
s := Value[x];
Inc(x);
if Pos('--' + b, s) > 0 then
Break;
end;
{ parse header }
while value.count>x do
while Value.Count > x do
begin
s:=normalizeheader(value,x);
if s=''
then break;
su:=uppercase(s);
if pos('CONTENT-TYPE:',su)=1 then
s := NormalizeHeader(Value, x);
if s = '' then
Break;
su := UpperCase(s);
if Pos('CONTENT-TYPE:', su) = 1 then
begin
st:=separateright(su,':');
st2:=separateleft(st,';');
primary:=separateleft(st2,'/');
secondary:=separateright(st2,'/');
if (secondary=primary) and (pos('/',st2)<1)
then secondary:='';
case primarycode of
st := SeparateRight(su, ':');
st2 := SeparateLeft(st, ';');
Primary := SeparateLeft(st2, '/');
FSecondary := SeparateRight(st2, '/');
if (FSecondary = Primary) and (Pos('/', st2) < 1) then FSecondary := '';
case FPrimaryCode of
MP_TEXT:
begin
charset:=uppercase(getparameter(s,'charset='));
end;
Charset := UpperCase(GetParameter(s, 'charset='));
MP_MULTIPART:
begin
boundary:=getparameter(s,'boundary=');
end;
FBoundary := GetParameter(s, 'Boundary=');
MP_MESSAGE:
begin
end;
MP_BINARY:
FFileName := GetParameter(s, 'name=');
end;
end;
if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then
Encoding := SeparateRight(su, ':');
if Pos('CONTENT-DESCRIPTION:', su) = 1 then
FDescription := SeparateRight(s, ':');
if Pos('CONTENT-DISPOSITION:', su) = 1 then
begin
filename:=getparameter(s,'name=');
end;
end;
end;
if pos('CONTENT-TRANSFER-ENCODING:',su)=1 then
begin
encoding:=separateright(su,':');
end;
if pos('CONTENT-DESCRIPTION:',su)=1 then
begin
description:=separateright(s,':');
end;
if pos('CONTENT-DISPOSITION:',su)=1 then
begin
disposition:=separateright(su,':');
disposition:=trim(separateleft(disposition,';'));
fn:=getparameter(s,'filename=');
end;
if pos('CONTENT-ID:',su)=1 then
begin
contentID:=separateright(s,':');
FDisposition := SeparateRight(su, ':');
FDisposition := Trim(SeparateLeft(FDisposition, ';'));
fn := GetParameter(s, 'FileName=');
end;
if Pos('CONTENT-ID:', su) = 1 then
FContentID := SeparateRight(s, ':');
end;
if (primarycode=MP_BINARY) and (filename='')
then filename:=fn;
filename:=InlineDecode(filename,getCurCP);
filename:=extractfilename(filename);
if (PrimaryCode = MP_BINARY) and (FFileName = '') then
FFileName := fn;
FFileName := InlineDecode(FFileName, getCurCP);
FFileName := ExtractFileName(FFileName);
x1 := x;
x2:=value.count-1;
x2 := Value.Count - 1;
if b <> '' then
begin
for n:=x to value.count-1 do
for n := x to Value.Count - 1 do
begin
x2 := n;
s:=value[n];
if pos('--'+b,s)>0
then begin
dec(x2);
break;
end;
end;
end;
if primarycode=MP_MULTIPART then
s := Value[n];
if Pos('--' + b, s) > 0 then
begin
for n:=x to value.count-1 do
Dec(x2);
Break;
end;
end;
end;
if FPrimaryCode = MP_MULTIPART then
begin
s:=value[n];
if pos('--'+boundary,s)>0 then
for n := x to Value.Count - 1 do
begin
s := Value[n];
if Pos('--' + Boundary, s) > 0 then
begin
x1 := n;
break;
Break;
end;
end;
for n:=value.count-1 downto x do
for n := Value.Count - 1 downto x do
begin
s:=value[n];
if pos('--'+boundary,s)>0 then
s := Value[n];
if Pos('--' + Boundary, s) > 0 then
begin
x2 := n;
break;
Break;
end;
end;
end;
for n := x1 to x2 do
lines.add(value[n]);
result:=x2;
if primarycode=MP_MULTIPART then
FLines.Add(Value[n]);
Result := x2;
if FPrimaryCode = MP_MULTIPART then
begin
e:=false;
for n:=x2+1 to value.count-1 do
if pos('--'+boundary,value[n])>0 then
e := False;
for n := x2 + 1 to Value.Count - 1 do
if Pos('--' + Boundary, Value[n]) > 0 then
begin
e:=true;
break;
e := True;
Break;
end;
if not e
then result:=value.count-1;
if not e then
Result := Value.Count - 1;
end;
finally
t.free;
t.Free;
end;
end;
{==============================================================================}
{TMIMEPart.DecodePart}
procedure TMIMEPart.DecodePart;
const
CRLF=#$0D+#$0A;
CRLF = #13#10;
var
n:integer;
n: Integer;
s: string;
begin
decodedLines.Clear;
for n:=0 to lines.count-1 do
FDecodedLines.Clear;
for n := 0 to FLines.Count - 1 do
begin
s:=lines[n];
case EncodingCode of
s := FLines[n];
case FEncodingCode of
ME_7BIT:
begin
s := s + CRLF;
end;
ME_8BIT:
begin
s:=decodeChar(s,CharsetCode,TargetCharset);
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
s := s + CRLF;
end;
ME_QUOTED_PRINTABLE:
begin
if s=''
then s:=CRLF
if s = '' then
s := CRLF
else
if s[length(s)]<>'='
then s:=s+CRLF;
if s[Length(s)] <> '=' then
s := s + CRLF;
s := DecodeQuotedPrintable(s);
if PrimaryCode=MP_TEXT
then s:=decodeChar(s,CharsetCode,TargetCharset);
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end;
ME_BASE64:
begin
if s<>''
then s:=DecodeBase64(s);
if PrimaryCode=MP_TEXT
then s:=decodeChar(s,CharsetCode,TargetCharset);
if s <> '' then
s := DecodeBase64(s);
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end;
ME_UU:
begin
if s<>''
then s:=DecodeUU(s);
end;
if s <> '' then
s := DecodeUU(s);
ME_XX:
begin
if s<>''
then s:=DecodeXX(s);
if s <> '' then
s := DecodeXX(s);
end;
FDecodedLines.Write(Pointer(s)^, Length(s));
end;
Decodedlines.Write(pointer(s)^,length(s));
end;
decodedlines.Seek(0,soFromBeginning);
FDecodedLines.Seek(0, soFromBeginning);
end;
{==============================================================================}
{TMIMEPart.EncodePart}
procedure TMIMEPart.EncodePart;
var
l: TStringList;
s, buff: string;
n,x:integer;
n, x: Integer;
begin
if EncodingCode=ME_UU
then encoding:='base64';
if EncodingCode=ME_XX
then encoding:='base64';
l:=tstringlist.create;
Lines.clear;
decodedlines.Seek(0,soFromBeginning);
if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
Encoding := 'base64';
l := TStringList.Create;
FLines.Clear;
FDecodedLines.Seek(0, soFromBeginning);
try
case primarycode of
MP_MULTIPART,
MP_MESSAGE:
case FPrimaryCode of
MP_MULTIPART, MP_MESSAGE:
FLines.LoadFromStream(FDecodedLines);
MP_TEXT, MP_BINARY:
if FEncodingCode = ME_BASE64 then
begin
lines.LoadFromStream(DecodedLines);
end;
MP_TEXT,
MP_BINARY:
if EncodingCode=ME_BASE64
then
begin
while decodedlines.Position<decodedlines.Size do
while FDecodedLines.Position < FDecodedLines.Size do
begin
Setlength(Buff, 54);
s := '';
x:=Decodedlines.Read(pointer(Buff)^,54);
x := FDecodedLines.Read(pointer(Buff)^, 54);
for n := 1 to x do
s := s + Buff[n];
if PrimaryCode=MP_TEXT
then s:=decodeChar(s,TargetCharset,CharsetCode);
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FTargetCharset, FCharsetCode);
s := EncodeBase64(s);
if x<>54
then s:=s+'=';
Lines.add(s);
if x <> 54 then
s := s + '=';
FLines.Add(s);
end;
end
else
begin
l.LoadFromStream(DecodedLines);
for n:=0 to l.count-1 do
l.LoadFromStream(FDecodedLines);
for n := 0 to l.Count - 1 do
begin
s := l[n];
if PrimaryCode=MP_TEXT
then s:=decodeChar(s,TargetCharset,CharsetCode);
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FTargetCharset, FCharsetCode);
s := EncodeQuotedPrintable(s);
Lines.add(s);
FLines.Add(s);
end;
end;
end;
Lines.add('');
lines.insert(0,'');
if secondary='' then
case PrimaryCode of
MP_TEXT: secondary:='plain';
MP_MULTIPART: secondary:='mixed';
MP_MESSAGE: secondary:='rfc822';
MP_BINARY: secondary:='octet-stream';
FLines.Add('');
FLines.Insert(0, '');
if FSecondary = '' then
case FPrimaryCode of
MP_TEXT:
FSecondary := 'plain';
MP_MULTIPART:
FSecondary := 'mixed';
MP_MESSAGE:
FSecondary := 'rfc822';
MP_BINARY:
FSecondary := 'octet-stream';
end;
if description<>''
then lines.insert(0,'Content-Description: '+Description);
if disposition<>'' then
if FDescription <> '' then
FLines.Insert(0, 'Content-Description: ' + FDescription);
if FDisposition <> '' then
begin
s := '';
if filename<>''
then s:='; filename="'+filename+'"';
lines.insert(0,'Content-Disposition: '+lowercase(disposition)+s);
if FFileName <> '' then
s := '; FileName="' + FFileName + '"';
FLines.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
end;
if contentID<>''
then lines.insert(0,'Content-ID: '+contentID);
if FContentID <> '' then
FLines.Insert(0, 'Content-ID: ' + FContentID);
case EncodingCode of
ME_7BIT: s:='7bit';
ME_8BIT: s:='8bit';
ME_QUOTED_PRINTABLE: s:='Quoted-printable';
ME_BASE64: s:='Base64';
case FEncodingCode of
ME_7BIT:
s := '7bit';
ME_8BIT:
s := '8bit';
ME_QUOTED_PRINTABLE:
s := 'Quoted-printable';
ME_BASE64:
s := 'Base64';
end;
case PrimaryCode of
case FPrimaryCode of
MP_TEXT,
MP_BINARY: lines.insert(0,'Content-Transfer-Encoding: '+s);
MP_BINARY: FLines.Insert(0, 'Content-Transfer-Encoding: ' + s);
end;
case PrimaryCode of
MP_TEXT: s:=primary+'/'+secondary+'; charset='+GetIDfromCP(charsetcode);
MP_MULTIPART: s:=primary+'/'+secondary+'; boundary="'+boundary+'"';
MP_MESSAGE: s:=primary+'/'+secondary+'';
MP_BINARY: s:=primary+'/'+secondary+'; name="'+FileName+'"';
case FPrimaryCode of
MP_TEXT:
s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode);
MP_MULTIPART:
s := FPrimary + '/' + FSecondary + '; boundary="' + Boundary + '"';
MP_MESSAGE:
s := FPrimary + '/' + FSecondary + '';
MP_BINARY:
s := FPrimary + '/' + FSecondary + '; name="' + FFileName + '"';
end;
lines.insert(0,'Content-type: '+s);
FLines.Insert(0, 'Content-type: ' + s);
finally
l.free;
l.Free;
end;
end;
{==============================================================================}
{TMIMEPart.MimeTypeFromExt}
procedure TMIMEPart.MimeTypeFromExt(value:string);
procedure TMIMEPart.MimeTypeFromExt(Value: string);
var
s: string;
n:integer;
n: Integer;
begin
primary:='';
secondary:='';
s:=uppercase(extractfileext(value));
if s=''
then s:=uppercase(value);
s:=separateright(s,'.');
Primary := '';
FSecondary := '';
s := UpperCase(ExtractFileExt(Value));
if s = '' then
s := UpperCase(Value);
s := SeparateRight(s, '.');
for n := 0 to MaxMimeType do
if MimeType[n, 0] = s then
begin
primary:=MimeType[n,1];
secondary:=MimeType[n,2];
break;
Primary := MimeType[n, 1];
FSecondary := MimeType[n, 2];
Break;
end;
if primary=''
then primary:='application';
if secondary=''
then secondary:='mixed';
if Primary = '' then
Primary := 'application';
if FSecondary = '' then
FSecondary := 'mixed';
end;
{==============================================================================}
{TMIMEPart.Setprimary}
procedure TMIMEPart.Setprimary(Value:string);
procedure TMIMEPart.SetPrimary(Value: string);
var
s: string;
begin
Fprimary:=Value;
s:=uppercase(Value);
PrimaryCode:=MP_BINARY;
if Pos('TEXT',s)=1
then PrimaryCode:=MP_TEXT;
if Pos('MULTIPART',s)=1
then PrimaryCode:=MP_MULTIPART;
if Pos('MESSAGE',s)=1
then PrimaryCode:=MP_MESSAGE;
FPrimary := Value;
s := UpperCase(Value);
FPrimaryCode := MP_BINARY;
if Pos('TEXT', s) = 1 then
FPrimaryCode := MP_TEXT;
if Pos('MULTIPART', s) = 1 then
FPrimaryCode := MP_MULTIPART;
if Pos('MESSAGE', s) = 1 then
FPrimaryCode := MP_MESSAGE;
end;
{TMIMEPart.SetEncoding}
procedure TMIMEPart.SetEncoding(Value: string);
var
s: string;
begin
FEncoding := Value;
s:=uppercase(Value);
EncodingCode:=ME_7BIT;
if Pos('8BIT',s)=1
then EncodingCode:=ME_8BIT;
if Pos('QUOTED-PRINTABLE',s)=1
then EncodingCode:=ME_QUOTED_PRINTABLE;
if Pos('BASE64',s)=1
then EncodingCode:=ME_BASE64;
if Pos('X-UU',s)=1
then EncodingCode:=ME_UU;
if Pos('X-XX',s)=1
then EncodingCode:=ME_XX;
s := UpperCase(Value);
FEncodingCode := ME_7BIT;
if Pos('8BIT', s) = 1 then
FEncodingCode := ME_8BIT;
if Pos('QUOTED-PRINTABLE', s) = 1 then
FEncodingCode := ME_QUOTED_PRINTABLE;
if Pos('BASE64', s) = 1 then
FEncodingCode := ME_BASE64;
if Pos('X-UU', s) = 1 then
FEncodingCode := ME_UU;
if Pos('X-XX', s) = 1 then
FEncodingCode := ME_XX;
end;
{TMIMEPart.SetCharset}
procedure TMIMEPart.SetCharset(Value: string);
begin
FCharset := Value;
CharsetCode:=GetCPfromID(value);
FCharsetCode := GetCPFromID(Value);
end;
{==============================================================================}
{GenerateBoundary}
function GenerateBoundary: string;
var
x:integer;
x: Integer;
begin
randomize;
x:=random(maxint);
result:='----'+Inttohex(x,8)+'_Synapse_message_boundary';
Randomize;
x := Random(MaxInt);
Result := '----' + IntToHex(x, 8) + '_Synapse_message_boundary';
end;
{==============================================================================}
begin
exit;
asm
db 'Synapse MIME messages encoding and decoding library by Lukas Gebauer',0
end;
end.

217
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;
type
TIcmpEchoHeader = Record
TIcmpEchoHeader = record
i_type: Byte;
i_code: Byte;
i_checkSum: Word;
i_Id: Word;
i_seq: Word;
TimeStamp : ULong;
End;
TimeStamp: ULONG;
end;
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;
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;
x: Integer;
begin
Result := FSock.CanRead(FTimeout);
if Result then
begin
x := FSock.WaitingData;
SetLength(FBuffer, x);
FSock.RecvBuffer(Pointer(FBuffer), x);
end;
end;
function TPINGSend.Ping(const Host: string): Boolean;
var
IPHeadPtr: ^TIPHeader;
IpHdrLen: Integer;
PIcmpEchoHeader:^TICMPEchoHeader;
n,x:integer;
IcmpEchoHeaderPtr: ^TICMPEchoHeader;
n: Integer;
t: Boolean;
begin
Result := False;
sock.connect(host,'0');
Buffer:=StringOfChar(#0,SizeOf(TICMPEchoHeader)+packetSize);
PIcmpEchoHeader := Pointer(Buffer);
With PIcmpEchoHeader^ Do Begin
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;
id:=Random(32767);
i_Id:=id;
FId := Random(32767);
i_Id := FId;
TimeStamp := GetTick;
Inc(Seq);
i_Seq:=Seq;
for n:=Succ(SizeOf(TicmpEchoHeader)) to Length(Buffer) do
Buffer[n]:=#$55;
Inc(FSeq);
i_Seq := FSeq;
for n := Succ(SizeOf(TIcmpEchoHeader)) to Length(FBuffer) do
FBuffer[n] := #$55;
i_CheckSum := CheckSum;
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
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
PingTime:=GetTick-PIcmpEchoHeader^.TimeStamp;
FPingTime := GetTick - IcmpEchoHeaderPtr^.TimeStamp;
Result := True;
end;
end;
end;
{TPINGSend.checksum}
function TPINGSend.checksum:integer;
function TPINGSend.Checksum: Integer;
type
tWordArray=Array[0..0] Of Word;
TWordArray = array[0..0] of Word;
var
PWordArray:^TWordArray;
CkSum:Dword;
WordArr: ^TWordArray;
CkSum: DWORD;
Num, Remain: Integer;
n: Integer;
begin
Num:=length(Buffer) div 2;
Remain:=length(Buffer) mod 2;
PWordArray:=Pointer(Buffer);
Num := Length(FBuffer) div 2;
Remain := Length(FBuffer) mod 2;
WordArr := Pointer(FBuffer);
CkSum := 0;
for n := 0 to Num - 1 do
CkSum:=CkSum+PWordArray^[n];
CkSum := CkSum + WordArr^[n];
if Remain <> 0 then
CkSum:=CkSum+ord(Buffer[Length(Buffer)]);
CkSum := CkSum + Ord(FBuffer[Length(FBuffer)]);
CkSum := (CkSum shr 16) + (CkSum and $FFFF);
CkSum := CkSum + (CkSum shr 16);
Result := Word(not CkSum);
end;
{TPINGSend.GetTick}
function TPINGSend.GetTick:cardinal;
begin
{$IFDEF LINUX}
result:=clock div (CLOCKS_PER_SEC div 1000);
{$ELSE}
result:=windows.GetTickCount;
{$ENDIF}
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;

317
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);
TPOP3Send = class
TPOP3Send = class(TObject)
private
Sock:TTCPBlockSocket;
function ReadResult(full:boolean):integer;
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;
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;
public
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;
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
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;
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;
var
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;
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;
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;
begin
Result := False;
TimeStamp:='';
if not Connect then Exit;
if readresult(false)<>1 then Exit;
s:=separateright(Resultstring,'<');
if s<>Resultstring then
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 TimeStamp:='<'+s1+'>';
s1 := SeparateLeft(s, '>');
if s1 <> s then
FTimeStamp := '<' + 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;
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;
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 := 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.

520
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,359 +23,359 @@
| (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;
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;
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 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 Connect: Boolean;
public
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(value:string):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;
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;
begin
Result := 0;
FullResult.Clear;
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;
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;
var
s: string;
begin
Result:=false;
Sock.SendString('AUTH CRAM-MD5'+CRLF);
if readresult<>334 then Exit;
s:=copy(ResultString,5,length(ResultString)-4);
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,password);
s:=Username+' '+strtohex(s);
Sock.SendString(Encodebase64(s)+CRLF);
if readresult<>235 then Exit;
Result:=True;
s := HMAC_MD5(s, FPassword);
s := FUsername + ' ' + StrToHex(s);
FSock.SendString(EncodeBase64(s) + CRLF);
Result := ReadResult = 235;
end;
{TSMTPSend.Connect}
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;
var
x:integer;
x: Integer;
begin
Result:=false;
Sock.SendString('HELO '+SystemName+CRLF);
FSock.SendString('HELO ' + FSystemName + CRLF);
x := ReadResult;
if (x<250) or (x>259) then Exit;
Result:=True;
Result := (x >= 250) and (x <= 259);
end;
{TSMTPSend.Ehlo}
function TSMTPSend.Ehlo: Boolean;
var
x:integer;
x: Integer;
begin
Result:=false;
Sock.SendString('EHLO '+SystemName+CRLF);
FSock.SendString('EHLO ' + FSystemName + CRLF);
x := ReadResult;
if (x<250) or (x>259) then Exit;
Result:=True;
Result := (x >= 250) and (x <= 259);
end;
{TSMTPSend.login}
function TSMTPSend.login:Boolean;
function TSMTPSend.Login: Boolean;
var
n:integer;
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;
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
ESMTP:=false;
if not Helo then exit;
FESMTP := False;
if not Helo then
Exit;
end;
Result := True;
if ESMTP then
if FESMTP 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
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
s := FindCap('AUTH ');
if s=''
then s:=FindCap('AUTH=');
auths:=uppercase(s);
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;
if Pos('CRAM-MD5', auths) > 0 then
FAuthDone := AuthCram;
if (Pos('LOGIN', auths) > 0) and (not FauthDone) then
FAuthDone := AuthLogin;
end;
if AuthDone
then Ehlo;
if FAuthDone then
Ehlo;
end;
s := FindCap('SIZE');
if s <> '' then
begin
ESMTPsize:=true;
MaxSize:=StrToIntDef(copy(s,6,length(s)-5),0);
FESMTPsize := True;
FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0);
end;
end;
end;
{TSMTPSend.logout}
procedure TSMTPSend.logout;
procedure TSMTPSend.Logout;
begin
Sock.SendString('QUIT'+CRLF);
readresult;
Sock.CloseSocket;
FSock.SendString('QUIT' + CRLF);
ReadResult;
FSock.CloseSocket;
end;
{TSMTPSend.reset}
function TSMTPSend.reset:Boolean;
function TSMTPSend.Reset: Boolean;
begin
Result:=false;
Sock.SendString('RSET'+CRLF);
if readresult<>250 then Exit;
Result:=True;
FSock.SendString('RSET' + CRLF);
Result := ReadResult = 250;
end;
{TSMTPSend.noop}
function TSMTPSend.noop:Boolean;
function TSMTPSend.NoOp: Boolean;
begin
Result:=false;
Sock.SendString('NOOP'+CRLF);
if readresult<>250 then Exit;
Result:=True;
FSock.SendString('NOOP' + CRLF);
Result := ReadResult = 250;
end;
{TSMTPSend.mailfrom}
function TSMTPSend.mailfrom(Value:string; size:integer):Boolean;
function TSMTPSend.MailFrom(const 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;
if FESMTPsize and (Size > 0) then
s := s + ' SIZE=' + IntToStr(Size);
FSock.SendString(s + CRLF);
Result := ReadResult = 250;
end;
{TSMTPSend.mailto}
function TSMTPSend.mailto(Value:string):Boolean;
function TSMTPSend.MailTo(const Value: string): Boolean;
begin
Result:=false;
Sock.SendString('RCPT TO:<'+Value+'>'+CRLF);
if readresult<>250 then Exit;
Result:=True;
FSock.SendString('RCPT TO:<' + Value + '>' + CRLF);
Result := ReadResult = 250;
end;
{TSMTPSend.maildata}
function TSMTPSend.maildata(Value:Tstrings):Boolean;
function TSMTPSend.MailData(const Value: TStrings): Boolean;
var
n:integer;
n: Integer;
s: string;
begin
Result:=false;
Sock.SendString('DATA'+CRLF);
if readresult<>354 then Exit;
Result := False;
FSock.SendString('DATA' + CRLF);
if ReadResult <> 354 then
Exit;
for n := 0 to Value.Count - 1 do
begin
s:=value[n];
s := Value[n];
if Length(s) >= 1 then
if s[1]='.' then s:='.'+s;
Sock.SendString(s+CRLF);
if s[1] = '.' then
s := '.' + s;
FSock.SendString(s + CRLF);
end;
Sock.SendString('.'+CRLF);
if readresult<>250 then Exit;
Result:=True;
FSock.SendString('.' + CRLF);
Result := ReadResult = 250;
end;
{TSMTPSend.etrn}
function TSMTPSend.etrn(Value:string):Boolean;
function TSMTPSend.Etrn(const Value: string): Boolean;
var
x:integer;
x: Integer;
begin
Result:=false;
Sock.SendString('ETRN '+Value+CRLF);
FSock.SendString('ETRN ' + Value + CRLF);
x := ReadResult;
if (x<250) or (x>259) then Exit;
Result:=True;
Result := (x >= 250) and (x <= 259);
end;
{TSMTPSend.verify}
function TSMTPSend.verify(Value:string):Boolean;
function TSMTPSend.Verify(const Value: string): Boolean;
var
x:integer;
x: Integer;
begin
Result:=false;
Sock.SendString('VRFY '+Value+CRLF);
FSock.SendString('VRFY ' + Value + CRLF);
x := ReadResult;
if (x<250) or (x>259) then Exit;
Result:=True;
Result := (x >= 250) and (x <= 259);
end;
{TSMTPSend.EnhCodeString}
function TSMTPSend.EnhCodeString: string;
var
s, t: string;
begin
s:=inttostr(EnhCode2)+'.'+inttostr(EnhCode3);
s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3);
t := '';
if s = '0.0' then t := 'Other undefined Status';
if s = '1.0' then t := 'Other address status';
@ -390,7 +390,7 @@ begin
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.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';
@ -427,35 +427,33 @@ begin
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;
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;
{TSMTPSend.FindCap}
function TSMTPSend.FindCap(value:string):string;
function TSMTPSend.FindCap(const Value: string): string;
var
n:integer;
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 := UpperCase(Value);
Result := '';
for n := 0 to FESMTPcap.Count - 1 do
if Pos(s, UpperCase(FESMTPcap[n])) = 1 then
begin
result:=ESMTPcap[n];
break;
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;
begin
Result := False;
SMTP := TSMTPSend.Create;
@ -463,45 +461,43 @@ begin
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;
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;
begin
// Result:=False;
t := TStringList.Create;
try
t.assign(Maildata);
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, '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.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.

345
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,22 +25,25 @@
|==============================================================================}
{$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;
@ -51,175 +54,184 @@ EReadOnly=4;
EGenErr = 5;
type
TSNMPMib = class
OID: string;
Value: string;
ValueType: integer;
TSNMPMib = class(TObject)
private
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
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 DecodeBuf(const Buffer: string): Boolean;
function EncodeBuf: string;
procedure Clear;
procedure MIBAdd(MIB,Value:string; ValueType:integer);
procedure MIBdelete(Index:integer);
function MIBGet(MIB:string):string;
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;
TSNMPSend = class(TObject)
private
Sock:TUDPBlockSocket;
Buffer:string;
FSock: TUDPBlockSocket;
FBuffer: string;
FTimeout: Integer;
FHost: string;
FHostIP: string;
FQuery: TSNMPRec;
FReply: TSNMPRec;
public
Timeout:integer;
Host:string;
HostIP:string;
Query:TSNMPrec;
Reply:TSNMPrec;
constructor Create;
destructor Destroy; override;
function DoIt:boolean;
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 (Oid, Community, SNMPHost:string; var Value:string):Boolean;
function SNMPSet (Oid, Community, SNMPHost, Value: string; ValueType: integer): boolean;
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;
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;
Pos: Integer;
EndPos: Integer;
sm, sv: string;
svt: integer;
Svt: Integer;
begin
result:=false;
if length(buffer)<2
then exit;
if (ord(buffer[1]) and $20)=0
then exit;
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
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);
ASNItem(Pos, Buffer, Svt);
Sm := ASNItem(Pos, Buffer, Svt);
Sv := ASNItem(Pos, Buffer, Svt);
Self.MIBAdd(sm, sv, Svt);
end;
result:=true;
Result := True;
end;
{TSNMPRec.EncodeBuf}
function TSNMPRec.EncodeBuf: string;
var
data, s: string;
SNMPMib: TSNMPMib;
n:integer;
n: Integer;
begin
data := '';
for n:=0 to SNMPMibList.Count-1 do
for n := 0 to FSNMPMibList.Count - 1 do
begin
SNMPMib := SNMPMibList[n];
case (SNMPMib.ValueType) of
SNMPMib := FSNMPMibList[n];
case SNMPMib.ValueType of
ASN1_INT:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID)
+ASNObject(ASNEncInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID)
+ASNObject(ASNEncUInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_OBJID:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(MibToID(SNMPMib.Value),SNMPMib.ValueType);
end;
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_IPADDR:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(IPToID(SNMPMib.Value),SNMPMib.ValueType);
end;
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_NULL:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject('',ASN1_NULL);
end;
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject('', ASN1_NULL);
else
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(SNMPMib.Value,SNMPMib.ValueType);
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(SNMPMib.Value, SNMPMib.ValueType);
end;
data := data + ASNObject(s, ASN1_SEQ);
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(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
if (Index >= 0) and (Index < FSNMPMibList.Count) then
begin
TSNMPMib(SNMPMibList[Index]).Free;
SNMPMibList.Delete(Index);
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(SNMPMibList[i])).OID = MIB) then
if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then
begin
Result := (TSNMPMib(SNMPMibList[i])).Value;
break;
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;
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(Buffer,x);
sock.RecvBuffer(PChar(Buffer),x);
result:=true;
SetLength(FBuffer, x);
FSock.RecvBuffer(PChar(FBuffer), x);
Result := True;
end;
end;
if Result
then result:=reply.DecodeBuf(Buffer);
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;
begin
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.

363
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,16 +25,18 @@
|==============================================================================}
{$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;
@ -47,83 +49,99 @@ const
type
TTrapPDU = class(TObject)
private
protected
Buffer: string;
FBuffer: string;
FTrapPort: string;
FVersion: Integer;
FPDUType: Integer;
FCommunity: string;
FEnterprise: string;
FTrapHost: string;
FGenTrap: Integer;
FSpecTrap: Integer;
FTimeTicks: Integer;
FSNMPMibList: TList;
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;
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
if (Index >= 0) and (Index < FSNMPMibList.Count) then
begin
TSNMPMib(SNMPMibList[Index]).Free;
SNMPMibList.Delete(Index);
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(SNMPMibList[i])).OID = MIB) then
if TSNMPMib(FSNMPMibList[i]).OID = MIB then
begin
Result := (TSNMPMib(SNMPMibList[i])).Value;
break;
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
FBuffer := '';
for n := 0 to FSNMPMibList.Count - 1 do
begin
SNMPMib := SNMPMibList[n];
case (SNMPMib.ValueType) of
SNMPMib := FSNMPMibList[n];
case SNMPMib.ValueType of
ASN1_INT:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID)
+ASNObject(ASNEncInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID)
+ASNObject(ASNEncUInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_OBJID:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(MibToID(SNMPMib.Value),SNMPMib.ValueType);
end;
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_IPADDR:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(IPToID(SNMPMib.Value),SNMPMib.ValueType);
end;
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_NULL:
begin
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject('',ASN1_NULL);
end;
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject('', ASN1_NULL);
else
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(SNMPMib.Value,SNMPMib.ValueType);
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(SNMPMib.Value, SNMPMib.ValueType);
end;
Buffer := Buffer + ASNObject(s, ASN1_SEQ);
FBuffer := FBuffer + ASNObject(s, ASN1_SEQ);
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 := 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
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, Buffer,svt);
Sm := ASNItem(Pos, Buffer,svt);
Sv := ASNItem(Pos, Buffer,svt);
MIBAdd(Sm, Sv, svt);
ASNItem(Pos, FBuffer, Svt);
Sm := ASNItem(Pos, FBuffer, Svt);
Sv := ASNItem(Pos, FBuffer, Svt);
MIBAdd(Sm, Sv, Svt);
end;
Result := true;
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 := Sock.WaitingData;
if (x > 0) then
x := FSock.WaitingData;
if x > 0 then
begin
SetLength(Trap.Buffer, x);
Sock.RecvBuffer(PChar(Trap.Buffer), x);
if Trap.DecodeTrap
then Result:=1;
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
for i := 0 to Trap.SNMPMibList.Count - 1 do
begin
MIBName.Add(TSNMPMib(SNMP.Trap.SNMPMibList[i]).OID);
MIBValue.Add(TSNMPMib(SNMP.Trap.SNMPMibList[i]).Value);
MIBName.Add(TSNMPMib(Trap.SNMPMibList[i]).OID);
MIBValue.Add(TSNMPMib(Trap.SNMPMibList[i]).Value);
end;
end;
finally
SNMP.Free;
Free;
end;
end;
end.

160
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;
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)
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 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;
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;
d1 := Trunc(d1 * 1000) / 1000;
Result := (d + d1) / 86400;
Result := Result + 2;
end;
{TSNTPSend.GetBroadcastNTP}
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
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
PNtp:=Pointer(Buffer);
NtpReply:=PNtp^;
NTPtime:=DeCodeTs(ntpreply.Xmit1,ntpreply.Xmit2);
NtpPtr := Pointer(FBuffer);
FNTPReply := NtpPtr^;
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
Result := True;
end;
end;
end;
{TSNTPSend.GetNTP}
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);
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
PNtp:=Pointer(Buffer);
NtpReply:=PNtp^;
NTPtime:=DeCodeTs(ntpreply.Xmit1,ntpreply.Xmit2);
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

711
synacode.pas
View File

@ -1,11 +1,11 @@
{==============================================================================|
| Project : Delphree - Synapse | 001.004.000 |
| Project : Delphree - Synapse | 001.004.001 |
|==============================================================================|
| Content: Coding and decoding support |
|==============================================================================|
| 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 |
@ -24,26 +24,28 @@
|==============================================================================}
{$Q-}
{$WEAKPACKAGEUNIT ON}
unit SynaCode;
interface
uses
sysutils;
SysUtils;
type
TSpecials=set of char;
TSpecials = set of Char;
const
SpecialChar:TSpecials
=['=','(',')','[',']','<','>',':',';','.',',','@','/','?','\','"','_'];
URLFullSpecialChar:TSpecials
=[';','/','?',':','@','=','&','#'];
URLSpecialChar:TSpecials
=[#$00..#$1f,'_','<','>','"','%','{','}','|','\','^','~','[',']','`',#$7f..#$ff];
SpecialChar: TSpecials =
['=', '(', ')', '[', ']', '<', '>', ':', ';', '.', ',', '@', '/', '?', '\',
'"', '_'];
URLFullSpecialChar: TSpecials =
[';', '/', '?', ':', '@', '=', '&', '#'];
URLSpecialChar: TSpecials =
[#$00..#$20, '_', '<', '>', '"', '%', '{', '}', '|', '\', '^', '~', '[', ']',
'`', #$7F..#$FF];
TableBase64 =
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';
TableUU =
@ -52,286 +54,291 @@ const
'+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_';
Crc32Tab: array[0..255] of integer = (
Integer($00000000),Integer($77073096),Integer($ee0e612c),Integer($990951ba),
Integer($076dc419),Integer($706af48f),Integer($e963a535),Integer($9e6495a3),
Integer($0edb8832),Integer($79dcb8a4),Integer($e0d5e91e),Integer($97d2d988),
Integer($09b64c2b),Integer($7eb17cbd),Integer($e7b82d07),Integer($90bf1d91),
Integer($1db71064),Integer($6ab020f2),Integer($f3b97148),Integer($84be41de),
Integer($1adad47d),Integer($6ddde4eb),Integer($f4d4b551),Integer($83d385c7),
Integer($136c9856),Integer($646ba8c0),Integer($fd62f97a),Integer($8a65c9ec),
Integer($14015c4f),Integer($63066cd9),Integer($fa0f3d63),Integer($8d080df5),
Integer($3b6e20c8),Integer($4c69105e),Integer($d56041e4),Integer($a2677172),
Integer($3c03e4d1),Integer($4b04d447),Integer($d20d85fd),Integer($a50ab56b),
Integer($35b5a8fa),Integer($42b2986c),Integer($dbbbc9d6),Integer($acbcf940),
Integer($32d86ce3),Integer($45df5c75),Integer($dcd60dcf),Integer($abd13d59),
Integer($26d930ac),Integer($51de003a),Integer($c8d75180),Integer($bfd06116),
Integer($21b4f4b5),Integer($56b3c423),Integer($cfba9599),Integer($b8bda50f),
Integer($2802b89e),Integer($5f058808),Integer($c60cd9b2),Integer($b10be924),
Integer($2f6f7c87),Integer($58684c11),Integer($c1611dab),Integer($b6662d3d),
Integer($76dc4190),Integer($01db7106),Integer($98d220bc),Integer($efd5102a),
Integer($71b18589),Integer($06b6b51f),Integer($9fbfe4a5),Integer($e8b8d433),
Integer($7807c9a2),Integer($0f00f934),Integer($9609a88e),Integer($e10e9818),
Integer($7f6a0dbb),Integer($086d3d2d),Integer($91646c97),Integer($e6635c01),
Integer($6b6b51f4),Integer($1c6c6162),Integer($856530d8),Integer($f262004e),
Integer($6c0695ed),Integer($1b01a57b),Integer($8208f4c1),Integer($f50fc457),
Integer($65b0d9c6),Integer($12b7e950),Integer($8bbeb8ea),Integer($fcb9887c),
Integer($62dd1ddf),Integer($15da2d49),Integer($8cd37cf3),Integer($fbd44c65),
Integer($4db26158),Integer($3ab551ce),Integer($a3bc0074),Integer($d4bb30e2),
Integer($4adfa541),Integer($3dd895d7),Integer($a4d1c46d),Integer($d3d6f4fb),
Integer($4369e96a),Integer($346ed9fc),Integer($ad678846),Integer($da60b8d0),
Integer($44042d73),Integer($33031de5),Integer($aa0a4c5f),Integer($dd0d7cc9),
Integer($5005713c),Integer($270241aa),Integer($be0b1010),Integer($c90c2086),
Integer($5768b525),Integer($206f85b3),Integer($b966d409),Integer($ce61e49f),
Integer($5edef90e),Integer($29d9c998),Integer($b0d09822),Integer($c7d7a8b4),
Integer($59b33d17),Integer($2eb40d81),Integer($b7bd5c3b),Integer($c0ba6cad),
Integer($edb88320),Integer($9abfb3b6),Integer($03b6e20c),Integer($74b1d29a),
Integer($ead54739),Integer($9dd277af),Integer($04db2615),Integer($73dc1683),
Integer($e3630b12),Integer($94643b84),Integer($0d6d6a3e),Integer($7a6a5aa8),
Integer($e40ecf0b),Integer($9309ff9d),Integer($0a00ae27),Integer($7d079eb1),
Integer($f00f9344),Integer($8708a3d2),Integer($1e01f268),Integer($6906c2fe),
Integer($f762575d),Integer($806567cb),Integer($196c3671),Integer($6e6b06e7),
Integer($fed41b76),Integer($89d32be0),Integer($10da7a5a),Integer($67dd4acc),
Integer($f9b9df6f),Integer($8ebeeff9),Integer($17b7be43),Integer($60b08ed5),
Integer($d6d6a3e8),Integer($a1d1937e),Integer($38d8c2c4),Integer($4fdff252),
Integer($d1bb67f1),Integer($a6bc5767),Integer($3fb506dd),Integer($48b2364b),
Integer($d80d2bda),Integer($af0a1b4c),Integer($36034af6),Integer($41047a60),
Integer($df60efc3),Integer($a867df55),Integer($316e8eef),Integer($4669be79),
Integer($cb61b38c),Integer($bc66831a),Integer($256fd2a0),Integer($5268e236),
Integer($cc0c7795),Integer($bb0b4703),Integer($220216b9),Integer($5505262f),
Integer($c5ba3bbe),Integer($b2bd0b28),Integer($2bb45a92),Integer($5cb36a04),
Integer($c2d7ffa7),Integer($b5d0cf31),Integer($2cd99e8b),Integer($5bdeae1d),
Integer($9b64c2b0),Integer($ec63f226),Integer($756aa39c),Integer($026d930a),
Integer($9c0906a9),Integer($eb0e363f),Integer($72076785),Integer($05005713),
Integer($95bf4a82),Integer($e2b87a14),Integer($7bb12bae),Integer($0cb61b38),
Integer($92d28e9b),Integer($e5d5be0d),Integer($7cdcefb7),Integer($0bdbdf21),
Integer($86d3d2d4),Integer($f1d4e242),Integer($68ddb3f8),Integer($1fda836e),
Integer($81be16cd),Integer($f6b9265b),Integer($6fb077e1),Integer($18b74777),
Integer($88085ae6),Integer($ff0f6a70),Integer($66063bca),Integer($11010b5c),
Integer($8f659eff),Integer($f862ae69),Integer($616bffd3),Integer($166ccf45),
Integer($a00ae278),Integer($d70dd2ee),Integer($4e048354),Integer($3903b3c2),
Integer($a7672661),Integer($d06016f7),Integer($4969474d),Integer($3e6e77db),
Integer($aed16a4a),Integer($d9d65adc),Integer($40df0b66),Integer($37d83bf0),
Integer($a9bcae53),Integer($debb9ec5),Integer($47b2cf7f),Integer($30b5ffe9),
Integer($bdbdf21c),Integer($cabac28a),Integer($53b39330),Integer($24b4a3a6),
Integer($bad03605),Integer($cdd70693),Integer($54de5729),Integer($23d967bf),
Integer($b3667a2e),Integer($c4614ab8),Integer($5d681b02),Integer($2a6f2b94),
Integer($b40bbe37),Integer($c30c8ea1),Integer($5a05df1b),Integer($2d02ef8d)
function DecodeTriplet(const Value: string; Delimiter: Char): string;
function DecodeQuotedPrintable(const Value: string): string;
function DecodeURL(const Value: string): string;
function EncodeTriplet(const Value: string; Delimiter: Char;
Specials: TSpecials): string;
function EncodeQuotedPrintable(const Value: string): string;
function EncodeURLElement(const Value: string): string;
function EncodeURL(const Value: string): string;
function Decode4to3(const Value, Table: string): string;
function DecodeBase64(const Value: string): string;
function EncodeBase64(const Value: string): string;
function DecodeUU(const Value: string): string;
function DecodeXX(const Value: string): string;
function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
function Crc32(const Value: string): Integer;
function UpdateCrc16(Value: Byte; Crc16: Word): Word;
function Crc16(const Value: string): Word;
function MD5(const Value: string): string;
function HMAC_MD5(Text, Key: string): string;
implementation
const
Crc32Tab: array[0..255] of Integer = (
Integer($00000000), Integer($77073096), Integer($EE0E612C), Integer($990951BA),
Integer($076DC419), Integer($706AF48F), Integer($E963A535), Integer($9E6495A3),
Integer($0EDB8832), Integer($79DCB8A4), Integer($E0D5E91E), Integer($97D2D988),
Integer($09B64C2B), Integer($7EB17CBD), Integer($E7B82D07), Integer($90BF1D91),
Integer($1DB71064), Integer($6AB020F2), Integer($F3B97148), Integer($84BE41DE),
Integer($1ADAD47D), Integer($6DDDE4EB), Integer($F4D4B551), Integer($83D385C7),
Integer($136C9856), Integer($646BA8C0), Integer($FD62F97A), Integer($8A65C9EC),
Integer($14015C4F), Integer($63066CD9), Integer($FA0F3D63), Integer($8D080DF5),
Integer($3B6E20C8), Integer($4C69105E), Integer($D56041E4), Integer($A2677172),
Integer($3C03E4D1), Integer($4B04D447), Integer($D20D85FD), Integer($A50AB56B),
Integer($35B5A8FA), Integer($42B2986C), Integer($DBBBC9D6), Integer($ACBCF940),
Integer($32D86CE3), Integer($45DF5C75), Integer($DCD60DCF), Integer($ABD13D59),
Integer($26D930AC), Integer($51DE003A), Integer($C8D75180), Integer($BFD06116),
Integer($21B4F4B5), Integer($56B3C423), Integer($CFBA9599), Integer($B8BDA50F),
Integer($2802B89E), Integer($5F058808), Integer($C60CD9B2), Integer($B10BE924),
Integer($2F6F7C87), Integer($58684C11), Integer($C1611DAB), Integer($B6662D3D),
Integer($76DC4190), Integer($01DB7106), Integer($98D220BC), Integer($EFD5102A),
Integer($71B18589), Integer($06B6B51F), Integer($9FBFE4A5), Integer($E8B8D433),
Integer($7807C9A2), Integer($0F00F934), Integer($9609A88E), Integer($E10E9818),
Integer($7F6A0DBB), Integer($086D3D2D), Integer($91646C97), Integer($E6635C01),
Integer($6B6B51F4), Integer($1C6C6162), Integer($856530D8), Integer($F262004E),
Integer($6C0695ED), Integer($1B01A57B), Integer($8208F4C1), Integer($F50FC457),
Integer($65B0D9C6), Integer($12B7E950), Integer($8BBEB8EA), Integer($FCB9887C),
Integer($62DD1DDF), Integer($15DA2D49), Integer($8CD37CF3), Integer($FBD44C65),
Integer($4DB26158), Integer($3AB551CE), Integer($A3BC0074), Integer($D4BB30E2),
Integer($4ADFA541), Integer($3DD895D7), Integer($A4D1C46D), Integer($D3D6F4FB),
Integer($4369E96A), Integer($346ED9FC), Integer($AD678846), Integer($DA60B8D0),
Integer($44042D73), Integer($33031DE5), Integer($AA0A4C5F), Integer($DD0D7CC9),
Integer($5005713C), Integer($270241AA), Integer($BE0B1010), Integer($C90C2086),
Integer($5768B525), Integer($206F85B3), Integer($B966D409), Integer($CE61E49F),
Integer($5EDEF90E), Integer($29D9C998), Integer($B0D09822), Integer($C7D7A8B4),
Integer($59B33D17), Integer($2EB40D81), Integer($B7BD5C3B), Integer($C0BA6CAD),
Integer($EDB88320), Integer($9ABFB3B6), Integer($03B6E20C), Integer($74B1D29A),
Integer($EAD54739), Integer($9DD277AF), Integer($04DB2615), Integer($73DC1683),
Integer($E3630B12), Integer($94643B84), Integer($0D6D6A3E), Integer($7A6A5AA8),
Integer($E40ECF0B), Integer($9309FF9D), Integer($0A00AE27), Integer($7D079EB1),
Integer($F00F9344), Integer($8708A3D2), Integer($1E01F268), Integer($6906C2FE),
Integer($F762575D), Integer($806567CB), Integer($196C3671), Integer($6E6B06E7),
Integer($FED41B76), Integer($89D32BE0), Integer($10DA7A5A), Integer($67DD4ACC),
Integer($F9B9DF6F), Integer($8EBEEFF9), Integer($17B7BE43), Integer($60B08ED5),
Integer($D6D6A3E8), Integer($A1D1937E), Integer($38D8C2C4), Integer($4FDFF252),
Integer($D1BB67F1), Integer($A6BC5767), Integer($3FB506DD), Integer($48B2364B),
Integer($D80D2BDA), Integer($AF0A1B4C), Integer($36034AF6), Integer($41047A60),
Integer($DF60EFC3), Integer($A867DF55), Integer($316E8EEF), Integer($4669BE79),
Integer($CB61B38C), Integer($BC66831A), Integer($256FD2A0), Integer($5268E236),
Integer($CC0C7795), Integer($BB0B4703), Integer($220216B9), Integer($5505262F),
Integer($C5BA3BBE), Integer($B2BD0B28), Integer($2BB45A92), Integer($5CB36A04),
Integer($C2D7FFA7), Integer($B5D0CF31), Integer($2CD99E8B), Integer($5BDEAE1D),
Integer($9B64C2B0), Integer($EC63F226), Integer($756AA39C), Integer($026D930A),
Integer($9C0906A9), Integer($EB0E363F), Integer($72076785), Integer($05005713),
Integer($95BF4A82), Integer($E2B87A14), Integer($7BB12BAE), Integer($0CB61B38),
Integer($92D28E9B), Integer($E5D5BE0D), Integer($7CDCEFB7), Integer($0BDBDF21),
Integer($86D3D2D4), Integer($F1D4E242), Integer($68DDB3F8), Integer($1FDA836E),
Integer($81BE16CD), Integer($F6B9265B), Integer($6FB077E1), Integer($18B74777),
Integer($88085AE6), Integer($FF0F6A70), Integer($66063BCA), Integer($11010B5C),
Integer($8F659EFF), Integer($F862AE69), Integer($616BFFD3), Integer($166CCF45),
Integer($A00AE278), Integer($D70DD2EE), Integer($4E048354), Integer($3903B3C2),
Integer($A7672661), Integer($D06016F7), Integer($4969474D), Integer($3E6E77DB),
Integer($AED16A4A), Integer($D9D65ADC), Integer($40DF0B66), Integer($37D83BF0),
Integer($A9BCAE53), Integer($DEBB9EC5), Integer($47B2CF7F), Integer($30B5FFE9),
Integer($BDBDF21C), Integer($CABAC28A), Integer($53B39330), Integer($24B4A3A6),
Integer($BAD03605), Integer($CDD70693), Integer($54DE5729), Integer($23D967BF),
Integer($B3667A2E), Integer($C4614AB8), Integer($5D681B02), Integer($2A6F2B94),
Integer($B40BBE37), Integer($C30C8EA1), Integer($5A05DF1B), Integer($2D02EF8D)
);
Crc16Tab: array[0..255] of word = (
$0000, $1189, $2312, $329b, $4624, $57ad, $6536, $74bf,
$8c48, $9dc1, $af5a, $bed3, $ca6c, $dbe5, $e97e, $f8f7,
$1081, $0108, $3393, $221a, $56a5, $472c, $75b7, $643e,
$9cc9, $8d40, $bfdb, $ae52, $daed, $cb64, $f9ff, $e876,
$2102, $308b, $0210, $1399, $6726, $76af, $4434, $55bd,
$ad4a, $bcc3, $8e58, $9fd1, $eb6e, $fae7, $c87c, $d9f5,
$3183, $200a, $1291, $0318, $77a7, $662e, $54b5, $453c,
$bdcb, $ac42, $9ed9, $8f50, $fbef, $ea66, $d8fd, $c974,
$4204, $538d, $6116, $709f, $0420, $15a9, $2732, $36bb,
$ce4c, $dfc5, $ed5e, $fcd7, $8868, $99e1, $ab7a, $baf3,
$5285, $430c, $7197, $601e, $14a1, $0528, $37b3, $263a,
$decd, $cf44, $fddf, $ec56, $98e9, $8960, $bbfb, $aa72,
$6306, $728f, $4014, $519d, $2522, $34ab, $0630, $17b9,
$ef4e, $fec7, $cc5c, $ddd5, $a96a, $b8e3, $8a78, $9bf1,
$7387, $620e, $5095, $411c, $35a3, $242a, $16b1, $0738,
$ffcf, $ee46, $dcdd, $cd54, $b9eb, $a862, $9af9, $8b70,
$8408, $9581, $a71a, $b693, $c22c, $d3a5, $e13e, $f0b7,
$0840, $19c9, $2b52, $3adb, $4e64, $5fed, $6d76, $7cff,
$9489, $8500, $b79b, $a612, $d2ad, $c324, $f1bf, $e036,
$18c1, $0948, $3bd3, $2a5a, $5ee5, $4f6c, $7df7, $6c7e,
$a50a, $b483, $8618, $9791, $e32e, $f2a7, $c03c, $d1b5,
$2942, $38cb, $0a50, $1bd9, $6f66, $7eef, $4c74, $5dfd,
$b58b, $a402, $9699, $8710, $f3af, $e226, $d0bd, $c134,
$39c3, $284a, $1ad1, $0b58, $7fe7, $6e6e, $5cf5, $4d7c,
$c60c, $d785, $e51e, $f497, $8028, $91a1, $a33a, $b2b3,
$4a44, $5bcd, $6956, $78df, $0c60, $1de9, $2f72, $3efb,
$d68d, $c704, $f59f, $e416, $90a9, $8120, $b3bb, $a232,
$5ac5, $4b4c, $79d7, $685e, $1ce1, $0d68, $3ff3, $2e7a,
$e70e, $f687, $c41c, $d595, $a12a, $b0a3, $8238, $93b1,
$6b46, $7acf, $4854, $59dd, $2d62, $3ceb, $0e70, $1ff9,
$f78f, $e606, $d49d, $c514, $b1ab, $a022, $92b9, $8330,
$7bc7, $6a4e, $58d5, $495c, $3de3, $2c6a, $1ef1, $0f78
Crc16Tab: array[0..255] of Word = (
$0000, $1189, $2312, $329B, $4624, $57AD, $6536, $74BF,
$8C48, $9DC1, $AF5A, $BED3, $CA6C, $DBE5, $E97E, $F8F7,
$1081, $0108, $3393, $221A, $56A5, $472C, $75B7, $643E,
$9CC9, $8D40, $BFDB, $AE52, $DAED, $CB64, $F9FF, $E876,
$2102, $308B, $0210, $1399, $6726, $76AF, $4434, $55BD,
$AD4A, $BCC3, $8E58, $9FD1, $EB6E, $FAE7, $C87C, $D9F5,
$3183, $200A, $1291, $0318, $77A7, $662E, $54B5, $453C,
$BDCB, $AC42, $9ED9, $8F50, $FBEF, $EA66, $D8FD, $C974,
$4204, $538D, $6116, $709F, $0420, $15A9, $2732, $36BB,
$CE4C, $DFC5, $ED5E, $FCD7, $8868, $99E1, $AB7A, $BAF3,
$5285, $430C, $7197, $601E, $14A1, $0528, $37B3, $263A,
$DECD, $CF44, $FDDF, $EC56, $98E9, $8960, $BBFB, $AA72,
$6306, $728F, $4014, $519D, $2522, $34AB, $0630, $17B9,
$EF4E, $FEC7, $CC5C, $DDD5, $A96A, $B8E3, $8A78, $9BF1,
$7387, $620E, $5095, $411C, $35A3, $242A, $16B1, $0738,
$FFCF, $EE46, $DCDD, $CD54, $B9EB, $A862, $9AF9, $8B70,
$8408, $9581, $A71A, $B693, $C22C, $D3A5, $E13E, $F0B7,
$0840, $19C9, $2B52, $3ADB, $4E64, $5FED, $6D76, $7CFF,
$9489, $8500, $B79B, $A612, $D2AD, $C324, $F1BF, $E036,
$18C1, $0948, $3BD3, $2A5A, $5EE5, $4F6C, $7DF7, $6C7E,
$A50A, $B483, $8618, $9791, $E32E, $F2A7, $C03C, $D1B5,
$2942, $38CB, $0A50, $1BD9, $6F66, $7EEF, $4C74, $5DFD,
$B58B, $A402, $9699, $8710, $F3AF, $E226, $D0BD, $C134,
$39C3, $284A, $1AD1, $0B58, $7FE7, $6E6E, $5CF5, $4D7C,
$C60C, $D785, $E51E, $F497, $8028, $91A1, $A33A, $B2B3,
$4A44, $5BCD, $6956, $78DF, $0C60, $1DE9, $2F72, $3EFB,
$D68D, $C704, $F59F, $E416, $90A9, $8120, $B3BB, $A232,
$5AC5, $4B4C, $79D7, $685E, $1CE1, $0D68, $3FF3, $2E7A,
$E70E, $F687, $C41C, $D595, $A12A, $B0A3, $8238, $93B1,
$6B46, $7ACF, $4854, $59DD, $2D62, $3CEB, $0E70, $1FF9,
$F78F, $E606, $D49D, $C514, $B1AB, $A022, $92B9, $8330,
$7BC7, $6A4E, $58D5, $495C, $3DE3, $2C6A, $1EF1, $0F78
);
type
TMD5Ctx = record
State: array[0..3] of integer;
Count: array[0..1] of integer;
State: array[0..3] of Integer;
Count: array[0..1] of Integer;
case Integer of
0: (BufChar: array[0..63] of Byte);
1: (BufLong: array[0..15] of integer);
1: (BufLong: array[0..15] of Integer);
end;
function DecodeTriplet(Value:string;limiter:char):string;
function DecodeQuotedPrintable(value:string):string;
function DecodeURL(value:string):string;
function EncodeTriplet(value:string;limiter:char;specials:TSpecials):string;
function EncodeQuotedPrintable(value:string):string;
function EncodeURLElement(value:string):string;
function EncodeURL(value:string):string;
function Decode4to3(value,table:string):string;
function DecodeBase64(value:string):string;
function EncodeBase64(value:string):string;
function DecodeUU(value:string):string;
function DecodeXX(value:string):string;
function UpdateCrc32(value:byte;crc32:integer):integer;
function Crc32(value:string):integer;
function UpdateCrc16(value:byte;crc16:word):word;
function Crc16(value:string):word;
function MD5(value:string):string;
function HMAC_MD5(text,key:string):string;
implementation
{==============================================================================}
{DecodeTriplet}
function DecodeTriplet(Value:string;limiter:char):string;
function DecodeTriplet(const Value: string; Delimiter: Char): string;
var
x:integer;
c:char;
x: Integer;
c: Char;
s: string;
begin
result:='';
Result := '';
x := 1;
while x<=length(value) do
while x <= Length(Value) do
begin
c:=value[x];
inc(x);
if c<>limiter
then result:=result+c
c := Value[x];
Inc(x);
if c <> Delimiter then
Result := Result + c
else
if x<length(value)
then
if x < Length(Value) then
begin
s:=copy(value,x,2);
inc(x,2);
result:=result+char(strtointdef('$'+s,32));
s := Copy(Value, x, 2);
Inc(x, 2);
if pos(#13, s) + pos(#10, s) = 0 then
Result := Result + Char(StrToIntDef('$' + s, 32));
end;
end;
end;
{==============================================================================}
{DecodeQuotedPrintable}
function DecodeQuotedPrintable(value:string):string;
function DecodeQuotedPrintable(const Value: string): string;
begin
Result := DecodeTriplet(Value, '=');
end;
{==============================================================================}
{DecodeURL}
function DecodeURL(value:string):string;
function DecodeURL(const Value: string): string;
begin
Result := DecodeTriplet(Value, '%');
end;
{==============================================================================}
{EncodeTriplet}
function EncodeTriplet(value:string;limiter:char;specials:TSpecials):string;
function EncodeTriplet(const Value: string; Delimiter: Char;
Specials: TSpecials): string;
var
n:integer;
n: Integer;
s: string;
begin
result:='';
for n:=1 to length(value) do
Result := '';
for n := 1 to Length(Value) do
begin
s:=value[n];
if s[1] in Specials
then s:=limiter+inttohex(ord(s[1]),2);
result:=result+s;
s := Value[n];
if s[1] in Specials then
s := Delimiter + IntToHex(Ord(s[1]), 2);
Result := Result + s;
end;
end;
{==============================================================================}
{EncodeQuotedPrintable}
function EncodeQuotedPrintable(value:string):string;
function EncodeQuotedPrintable(const Value: string): string;
begin
Result:=EncodeTriplet(Value,'=',SpecialChar+[char(1)..char(31),char(128)..char(255)]);
Result := EncodeTriplet(Value, '=', SpecialChar +
[Char(1)..Char(31), Char(128)..Char(255)]);
end;
{==============================================================================}
{EncodeURLElement}
function EncodeURLElement(value:string):string;
function EncodeURLElement(const Value: string): string;
begin
Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar);
end;
{==============================================================================}
{EncodeURL}
function EncodeURL(value:string):string;
function EncodeURL(const Value: string): string;
begin
Result := EncodeTriplet(Value, '%', URLSpecialChar);
end;
{==============================================================================}
{Decode4to3}
function Decode4to3(value,table:string):string;
function Decode4to3(const Value, Table: string): string;
var
x,y,n:integer;
d: array[0..3] of byte;
x, y, n: Integer;
d: array[0..3] of Byte;
begin
result:='';
Result := '';
x := 1;
while x<length(value) do
while x < Length(Value) do
begin
for n := 0 to 3 do
begin
if x>length(value)
then d[n]:=64
if x > Length(Value) then
d[n] := 64
else
begin
y:=pos(value[x],table);
if y<1 then y:=65;
y := Pos(Value[x], Table);
if y < 1 then
y := 65;
d[n] := y - 1;
end;
inc(x);
Inc(x);
end;
result:=result+char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4);
Result := Result + Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4);
if d[2] <> 64 then
begin
result:=result+char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2);
Result := Result + Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2);
if d[3] <> 64 then
result:=result+char((D[2] and $03) shl 6 + (D[3] and $3F));
Result := Result + Char((D[2] and $03) shl 6 + (D[3] and $3F));
end;
end;
end;
{==============================================================================}
{DecodeBase64}
function DecodeBase64(value:string):string;
function DecodeBase64(const Value: string): string;
begin
result:=Decode4to3(value,TableBase64);
Result := Decode4to3(Value, TableBase64);
end;
{==============================================================================}
{EncodeBase64}
function EncodeBase64(value:string):string;
function EncodeBase64(const Value: string): string;
var
c:byte;
n:integer;
Count:integer;
DOut:array [0..3] of byte;
c: Byte;
n: Integer;
Count: Integer;
DOut: array[0..3] of Byte;
begin
result:='';
Result := '';
Count := 1;
while count<=length(value) do
while Count <= Length(Value) do
begin
c:=ord(value[count]);
inc(count);
c := Ord(Value[Count]);
Inc(Count);
DOut[0] := (c and $FC) shr 2;
DOut[1] := (c and $03) shl 4;
if count<=length(value)
then
if Count <= Length(Value) then
begin
c:=ord(value[count]);
inc(count);
c := Ord(Value[Count]);
Inc(Count);
DOut[1] := DOut[1] + (c and $F0) shr 4;
DOut[2] := (c and $0F) shl 2;
if count<=length(value)
then
if Count <= Length(Value) then
begin
c:=ord(value[count]);
inc(count);
c := Ord(Value[Count]);
Inc(Count);
DOut[2] := DOut[2] + (c and $C0) shr 6;
DOut[3] := (c and $3F);
end
@ -346,103 +353,113 @@ begin
DOut[3] := $40;
end;
for n := 0 to 3 do
result:=result+TableBase64[DOut[n]+1];
Result := Result + TableBase64[DOut[n] + 1];
end;
end;
{==============================================================================}
{DecodeUU}
function DecodeUU(value:string):string;
function DecodeUU(const Value: string): string;
var
s: string;
uut: string;
x:integer;
x: Integer;
begin
result:='';
Result := '';
uut := TableUU;
s:=trim(uppercase(value));
if s='' then exit;
if pos('BEGIN',s)=1 then exit;
if pos('END',s)=1 then exit;
if pos('TABLE',s)=1 then exit; //ignore table yet (set custom UUT)
s := trim(UpperCase(Value));
if s = '' then Exit;
if Pos('BEGIN', s) = 1 then
Exit;
if Pos('END', s) = 1 then
Exit;
if Pos('TABLE', s) = 1 then
Exit; //ignore Table yet (set custom UUT)
//begin decoding
x:=pos(value[1],uut)-1;
x:=round((x/3)*4);
x := Pos(Value[1], uut) - 1;
x := Round((x / 3) * 4);
//x - lenght UU line
s:=copy(value,2,x);
if s='' then exit;
result:=Decode4to3(s,uut);
s := Copy(Value, 2, x);
if s = '' then
Exit;
Result := Decode4to3(s, uut);
end;
{==============================================================================}
{DecodeXX}
function DecodeXX(value:string):string;
function DecodeXX(const Value: string): string;
var
s: string;
x:integer;
x: Integer;
begin
result:='';
s:=trim(uppercase(value));
if s='' then exit;
if pos('BEGIN',s)=1 then exit;
if pos('END',s)=1 then exit;
Result := '';
s := trim(UpperCase(Value));
if s = '' then
Exit;
if Pos('BEGIN', s) = 1 then
Exit;
if Pos('END', s) = 1 then
Exit;
//begin decoding
x:=pos(value[1],TableXX)-1;
x:=round((x/3)*4);
x := Pos(Value[1], TableXX) - 1;
x := Round((x / 3) * 4);
//x - lenght XX line
s:=copy(value,2,x);
if s='' then exit;
result:=Decode4to3(s,TableXX);
s := Copy(Value, 2, x);
if s = '' then
Exit;
Result := Decode4to3(s, TableXX);
end;
{==============================================================================}
{UpdateCrc32}
function UpdateCrc32(value:byte;crc32:integer):integer;
function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
begin
result:=((crc32 shr 8) and Integer($00FFFFFF))
xor crc32tab[byte(crc32 XOR integer(value)) and Integer($000000FF)];
Result := ((Crc32 shr 8) and Integer($00FFFFFF)) xor
crc32tab[Byte(Crc32 xor Integer(Value)) and Integer($000000FF)];
end;
{==============================================================================}
{Crc32}
function Crc32(value:string):integer;
function Crc32(const Value: string): Integer;
var
n:integer;
n: Integer;
begin
result:=Integer($FFFFFFFF);
for n:=1 to length(value) do
result:=UpdateCrc32(ord(value[n]), result);
Result := Integer($FFFFFFFF);
for n := 1 to Length(Value) do
Result := UpdateCrc32(Ord(Value[n]), Result);
end;
{==============================================================================}
{UpdateCrc16}
function UpdateCrc16(value:byte;crc16:word):word;
function UpdateCrc16(Value: Byte; Crc16: Word): Word;
begin
result:=((crc16 shr 8) and $00FF)
xor crc16tab[byte(crc16 XOR (word(value)) and $00FF)];
Result := ((Crc16 shr 8) and $00FF) xor
crc16tab[Byte(Crc16 xor (Word(Value)) and $00FF)];
end;
{==============================================================================}
{Crc16}
function Crc16(value:string):word;
function Crc16(const Value: string): Word;
var
n:integer;
n: Integer;
begin
result:=$FFFF;
for n:=1 to length(value) do
result:=UpdateCrc16(ord(value[n]), result);
Result := $FFFF;
for n := 1 to Length(Value) do
Result := UpdateCrc16(Ord(Value[n]), Result);
end;
{==============================================================================}
procedure MD5Init(var MD5Context: TMD5Ctx);
begin
FillChar(MD5Context, SizeOf(TMD5Ctx), #0);
with MD5Context do begin
with MD5Context do
begin
State[0] := Integer($67452301);
State[1] := Integer($EFCDAB89);
State[2] := Integer($98BADCFE);
State[3] := Integer($10325476);
end
end;
end;
procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt);
@ -453,28 +470,28 @@ var
begin
Inc(W, (Z xor (X and (Y xor Z))) + Data);
W := (W shl S) or (W shr (32 - S));
Inc(W, X)
Inc(W, X);
end;
procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
begin
Inc(W, (Y xor (Z and (X xor Y))) + Data);
W := (W shl S) or (W shr (32 - S));
Inc(W, X)
Inc(W, X);
end;
procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
begin
Inc(W, (X xor Y xor Z) + Data);
W := (W shl S) or (W shr (32 - S));
Inc(W, X)
Inc(W, X);
end;
procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
begin
Inc(W, (Y xor (X or not Z)) + Data);
W := (W shl S) or (W shr (32 - S));
Inc(W, X)
Inc(W, X);
end;
begin
A := Buf[0];
@ -482,73 +499,73 @@ begin
C := Buf[2];
D := Buf[3];
Round1(A,B,C,D, Data[ 0] + longint($d76aa478), 7);
Round1(D,A,B,C, Data[ 1] + longint($e8c7b756), 12);
Round1(C,D,A,B, Data[ 2] + longint($242070db), 17);
Round1(B,C,D,A, Data[ 3] + longint($c1bdceee), 22);
Round1(A,B,C,D, Data[ 4] + longint($f57c0faf), 7);
Round1(D,A,B,C, Data[ 5] + longint($4787c62a), 12);
Round1(C,D,A,B, Data[ 6] + longint($a8304613), 17);
Round1(B,C,D,A, Data[ 7] + longint($fd469501), 22);
Round1(A,B,C,D, Data[ 8] + longint($698098d8), 7);
Round1(D,A,B,C, Data[ 9] + longint($8b44f7af), 12);
Round1(C,D,A,B, Data[10] + longint($ffff5bb1), 17);
Round1(B,C,D,A, Data[11] + longint($895cd7be), 22);
Round1(A,B,C,D, Data[12] + longint($6b901122), 7);
Round1(D,A,B,C, Data[13] + longint($fd987193), 12);
Round1(C,D,A,B, Data[14] + longint($a679438e), 17);
Round1(B,C,D,A, Data[15] + longint($49b40821), 22);
Round1(A, B, C, D, Data[0] + Longint($D76AA478), 7);
Round1(D, A, B, C, Data[1] + Longint($E8C7B756), 12);
Round1(C, D, A, B, Data[2] + Longint($242070DB), 17);
Round1(B, C, D, A, Data[3] + Longint($C1BDCEEE), 22);
Round1(A, B, C, D, Data[4] + Longint($F57C0FAF), 7);
Round1(D, A, B, C, Data[5] + Longint($4787C62A), 12);
Round1(C, D, A, B, Data[6] + Longint($A8304613), 17);
Round1(B, C, D, A, Data[7] + Longint($FD469501), 22);
Round1(A, B, C, D, Data[8] + Longint($698098D8), 7);
Round1(D, A, B, C, Data[9] + Longint($8B44F7AF), 12);
Round1(C, D, A, B, Data[10] + Longint($FFFF5BB1), 17);
Round1(B, C, D, A, Data[11] + Longint($895CD7BE), 22);
Round1(A, B, C, D, Data[12] + Longint($6B901122), 7);
Round1(D, A, B, C, Data[13] + Longint($FD987193), 12);
Round1(C, D, A, B, Data[14] + Longint($A679438E), 17);
Round1(B, C, D, A, Data[15] + Longint($49B40821), 22);
Round2(A,B,C,D, Data[ 1] + longint($f61e2562), 5);
Round2(D,A,B,C, Data[ 6] + longint($c040b340), 9);
Round2(C,D,A,B, Data[11] + longint($265e5a51), 14);
Round2(B,C,D,A, Data[ 0] + longint($e9b6c7aa), 20);
Round2(A,B,C,D, Data[ 5] + longint($d62f105d), 5);
Round2(D,A,B,C, Data[10] + longint($02441453), 9);
Round2(C,D,A,B, Data[15] + longint($d8a1e681), 14);
Round2(B,C,D,A, Data[ 4] + longint($e7d3fbc8), 20);
Round2(A,B,C,D, Data[ 9] + longint($21e1cde6), 5);
Round2(D,A,B,C, Data[14] + longint($c33707d6), 9);
Round2(C,D,A,B, Data[ 3] + longint($f4d50d87), 14);
Round2(B,C,D,A, Data[ 8] + longint($455a14ed), 20);
Round2(A,B,C,D, Data[13] + longint($a9e3e905), 5);
Round2(D,A,B,C, Data[ 2] + longint($fcefa3f8), 9);
Round2(C,D,A,B, Data[ 7] + longint($676f02d9), 14);
Round2(B,C,D,A, Data[12] + longint($8d2a4c8a), 20);
Round2(A, B, C, D, Data[1] + Longint($F61E2562), 5);
Round2(D, A, B, C, Data[6] + Longint($C040B340), 9);
Round2(C, D, A, B, Data[11] + Longint($265E5A51), 14);
Round2(B, C, D, A, Data[0] + Longint($E9B6C7AA), 20);
Round2(A, B, C, D, Data[5] + Longint($D62F105D), 5);
Round2(D, A, B, C, Data[10] + Longint($02441453), 9);
Round2(C, D, A, B, Data[15] + Longint($D8A1E681), 14);
Round2(B, C, D, A, Data[4] + Longint($E7D3FBC8), 20);
Round2(A, B, C, D, Data[9] + Longint($21E1CDE6), 5);
Round2(D, A, B, C, Data[14] + Longint($C33707D6), 9);
Round2(C, D, A, B, Data[3] + Longint($F4D50D87), 14);
Round2(B, C, D, A, Data[8] + Longint($455A14ED), 20);
Round2(A, B, C, D, Data[13] + Longint($A9E3E905), 5);
Round2(D, A, B, C, Data[2] + Longint($FCEFA3F8), 9);
Round2(C, D, A, B, Data[7] + Longint($676F02D9), 14);
Round2(B, C, D, A, Data[12] + Longint($8D2A4C8A), 20);
Round3(A,B,C,D, Data[ 5] + longint($fffa3942), 4);
Round3(D,A,B,C, Data[ 8] + longint($8771f681), 11);
Round3(C,D,A,B, Data[11] + longint($6d9d6122), 16);
Round3(B,C,D,A, Data[14] + longint($fde5380c), 23);
Round3(A,B,C,D, Data[ 1] + longint($a4beea44), 4);
Round3(D,A,B,C, Data[ 4] + longint($4bdecfa9), 11);
Round3(C,D,A,B, Data[ 7] + longint($f6bb4b60), 16);
Round3(B,C,D,A, Data[10] + longint($bebfbc70), 23);
Round3(A,B,C,D, Data[13] + longint($289b7ec6), 4);
Round3(D,A,B,C, Data[ 0] + longint($eaa127fa), 11);
Round3(C,D,A,B, Data[ 3] + longint($d4ef3085), 16);
Round3(B,C,D,A, Data[ 6] + longint($04881d05), 23);
Round3(A,B,C,D, Data[ 9] + longint($d9d4d039), 4);
Round3(D,A,B,C, Data[12] + longint($e6db99e5), 11);
Round3(C,D,A,B, Data[15] + longint($1fa27cf8), 16);
Round3(B,C,D,A, Data[ 2] + longint($c4ac5665), 23);
Round3(A, B, C, D, Data[5] + Longint($FFFA3942), 4);
Round3(D, A, B, C, Data[8] + Longint($8771F681), 11);
Round3(C, D, A, B, Data[11] + Longint($6D9D6122), 16);
Round3(B, C, D, A, Data[14] + Longint($FDE5380C), 23);
Round3(A, B, C, D, Data[1] + Longint($A4BEEA44), 4);
Round3(D, A, B, C, Data[4] + Longint($4BDECFA9), 11);
Round3(C, D, A, B, Data[7] + Longint($F6BB4B60), 16);
Round3(B, C, D, A, Data[10] + Longint($BEBFBC70), 23);
Round3(A, B, C, D, Data[13] + Longint($289B7EC6), 4);
Round3(D, A, B, C, Data[0] + Longint($EAA127FA), 11);
Round3(C, D, A, B, Data[3] + Longint($D4EF3085), 16);
Round3(B, C, D, A, Data[6] + Longint($04881D05), 23);
Round3(A, B, C, D, Data[9] + Longint($D9D4D039), 4);
Round3(D, A, B, C, Data[12] + Longint($E6DB99E5), 11);
Round3(C, D, A, B, Data[15] + Longint($1FA27CF8), 16);
Round3(B, C, D, A, Data[2] + Longint($C4AC5665), 23);
Round4(A,B,C,D, Data[ 0] + longint($f4292244), 6);
Round4(D,A,B,C, Data[ 7] + longint($432aff97), 10);
Round4(C,D,A,B, Data[14] + longint($ab9423a7), 15);
Round4(B,C,D,A, Data[ 5] + longint($fc93a039), 21);
Round4(A,B,C,D, Data[12] + longint($655b59c3), 6);
Round4(D,A,B,C, Data[ 3] + longint($8f0ccc92), 10);
Round4(C,D,A,B, Data[10] + longint($ffeff47d), 15);
Round4(B,C,D,A, Data[ 1] + longint($85845dd1), 21);
Round4(A,B,C,D, Data[ 8] + longint($6fa87e4f), 6);
Round4(D,A,B,C, Data[15] + longint($fe2ce6e0), 10);
Round4(C,D,A,B, Data[ 6] + longint($a3014314), 15);
Round4(B,C,D,A, Data[13] + longint($4e0811a1), 21);
Round4(A,B,C,D, Data[ 4] + longint($f7537e82), 6);
Round4(D,A,B,C, Data[11] + longint($bd3af235), 10);
Round4(C,D,A,B, Data[ 2] + longint($2ad7d2bb), 15);
Round4(B,C,D,A, Data[ 9] + longint($eb86d391), 21);
Round4(A, B, C, D, Data[0] + Longint($F4292244), 6);
Round4(D, A, B, C, Data[7] + Longint($432AFF97), 10);
Round4(C, D, A, B, Data[14] + Longint($AB9423A7), 15);
Round4(B, C, D, A, Data[5] + Longint($FC93A039), 21);
Round4(A, B, C, D, Data[12] + Longint($655B59C3), 6);
Round4(D, A, B, C, Data[3] + Longint($8F0CCC92), 10);
Round4(C, D, A, B, Data[10] + Longint($FFEFF47D), 15);
Round4(B, C, D, A, Data[1] + Longint($85845DD1), 21);
Round4(A, B, C, D, Data[8] + Longint($6FA87E4F), 6);
Round4(D, A, B, C, Data[15] + Longint($FE2CE6E0), 10);
Round4(C, D, A, B, Data[6] + Longint($A3014314), 15);
Round4(B, C, D, A, Data[13] + Longint($4E0811A1), 21);
Round4(A, B, C, D, Data[4] + Longint($F7537E82), 6);
Round4(D, A, B, C, Data[11] + Longint($BD3AF235), 10);
Round4(C, D, A, B, Data[2] + Longint($2AD7D2BB), 15);
Round4(B, C, D, A, Data[9] + Longint($EB86D391), 21);
Inc(Buf[0], A);
Inc(Buf[1], B);
@ -558,9 +575,9 @@ end;
procedure MD5Update(var MD5Context: TMD5Ctx; const Data: string);
var
Index,t,len:integer;
Index, t, len: Integer;
begin
len:=length(data);
len := Length(Data);
with MD5Context do
begin
T := Count[0];
@ -600,7 +617,7 @@ var
Cnt: Word;
P: Byte;
digest: array[0..15] of Char;
i:integer;
i: Integer;
begin
for I := 0 to 15 do
Byte(Digest[I]) := I + 1;
@ -617,67 +634,59 @@ begin
MD5Transform(State, BufLong);
FillChar(BufChar, 56, #0);
end
else fillChar(BufChar[P], Cnt-8, #0);
else
FillChar(BufChar[P], Cnt - 8, #0);
BufLong[14] := Count[0];
BufLong[15] := Count[1];
MD5Transform(State, BufLong);
Move(State, Digest, 16);
result:='';
Result := '';
for i := 0 to 15 do
result:=result+char(digest[i]);
Result := Result + Char(digest[i]);
end;
FillChar(MD5Context, SizeOf(TMD5Ctx), #0)
end;
{==============================================================================}
{MD5}
function MD5(value:string): string;
function MD5(const Value: string): string;
var
MD5Context: TMD5Ctx;
begin
MD5Init(MD5Context);
MD5Update(MD5Context,value);
result:=MD5Final(MD5Context);
MD5Update(MD5Context, Value);
Result := MD5Final(MD5Context);
end;
{==============================================================================}
{HMAC_MD5}
function HMAC_MD5(text,key:string):string;
function HMAC_MD5(Text, Key: string): string;
var
ipad, opad, s: string;
n:integer;
n: Integer;
MD5Context: TMD5Ctx;
begin
if length(key)>64 then
key:=md5(key);
if Length(Key) > 64 then
Key := md5(Key);
ipad := '';
for n := 1 to 64 do
ipad := ipad + #$36;
opad := '';
for n := 1 to 64 do
opad:=opad+#$5c;
for n:=1 to length(key) do
opad := opad + #$5C;
for n := 1 to Length(Key) do
begin
ipad[n]:=char(byte(ipad[n]) xor byte(key[n]));
opad[n]:=char(byte(opad[n]) xor byte(key[n]));
ipad[n] := Char(Byte(ipad[n]) xor Byte(Key[n]));
opad[n] := Char(Byte(opad[n]) xor Byte(Key[n]));
end;
MD5Init(MD5Context);
MD5Update(MD5Context, ipad);
MD5Update(MD5Context,text);
MD5Update(MD5Context, Text);
s := MD5Final(MD5Context);
MD5Init(MD5Context);
MD5Update(MD5Context, opad);
MD5Update(MD5Context, s);
result:=MD5Final(MD5Context);
Result := MD5Final(MD5Context);
end;
{==============================================================================}
begin
exit;
asm
db 'Synapse coding and decoding support library by Lukas Gebauer',0
end;
end.

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.

417
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,73 +32,79 @@ 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 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 (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;
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;
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:='-';
if bias >= 0 then
Result := '+'
else
Result := '-';
{$ELSE}
var
zoneinfo: TTimeZoneInformation;
bias:integer;
h,m:integer;
bias: Integer;
h, m: Integer;
begin
case GetTimeZoneInformation(Zoneinfo) of
2: bias:=zoneinfo.bias+zoneinfo.DaylightBias;
1: bias:=zoneinfo.bias+zoneinfo.StandardBias;
2:
bias := zoneinfo.Bias + zoneinfo.DaylightBias;
1:
bias := zoneinfo.Bias + zoneinfo.StandardBias;
else
bias:=zoneinfo.bias;
bias := zoneinfo.Bias;
end;
if bias<=0 then result:='+'
else result:='-';
if bias <= 0 then
Result := '+'
else
Result := '-';
{$ENDIF}
bias:=abs(bias);
bias := Abs(bias);
h := bias div 60;
m := bias mod 60;
result:=result+format('%.2d%.2d',[h,m]);
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;
@ -111,8 +117,8 @@ const
'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
@ -136,53 +142,56 @@ end;
{==============================================================================}
{CodeInt}
function CodeInt(Value:word):string;
function CodeInt(Value: Word): string;
begin
Result := Chr(Hi(Value)) + Chr(Lo(Value))
end;
{==============================================================================}
{DeCodeInt}
function DeCodeInt(Value:string;Index:integer):word;
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;
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;
function IsIP(const Value: string): Boolean;
var
n,x:integer;
n, x: Integer;
begin
Result := true;
x := 0;
for n := 1 to Length(Value) do
if not (Value[n] in ['0'..'9','.'])
then begin
if not (Value[n] in ['0'..'9', '.']) then
begin
Result := False;
break;
Break;
end
else begin
if Value[n]='.' then Inc(x);
else
begin
if Value[n] = '.' then
Inc(x);
end;
if x<>3 then Result:=False;
if x <> 3 then
Result := False;
end;
{==============================================================================}
{ReverseIP}
function ReverseIP(Value: string): string;
var
x:integer;
x: Integer;
begin
Result := '';
repeat
@ -197,263 +206,273 @@ end;
{==============================================================================}
{dump}
procedure dump (Buffer:string;DumpFile:string);
procedure Dump(const Buffer, DumpFile: string);
var
n:integer;
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);
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;
x, x1: Integer;
s: string;
begin
x:=pos(uppercase(parameter),uppercase(value));
result:='';
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
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
if s[1] = '"' then
begin
s:=copy(s,2,length(s)-1);
x:=pos('"',s);
if x>0 then x1:=x-1;
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;
x := Pos(' ', s);
if x > 0 then
x1 := x - 1;
end;
end;
result:=copy(s,1,x1);
Result := Copy(s, 1, x1);
end;
end;
{==============================================================================}
{GetEmailAddr}
function GetEmailAddr(value:string):string;
function GetEmailAddr(const Value: string): string;
var
s: string;
begin
s:=separateright(value,'<');
s:=separateleft(s,'>');
result:=trim(s);
s := SeparateRight(Value, '<');
s := SeparateLeft(s, '>');
Result := Trim(s);
end;
{==============================================================================}
{GetEmailDesc}
function GetEmailDesc(value:string):string;
function GetEmailDesc(Value: string): string;
var
s: string;
begin
value:=trim(value);
s:=separateright(value,'"');
if s<>value
then s:=separateleft(s,'"')
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,')')
s := SeparateRight(Value, '(');
if s <> Value then
s := SeparateLeft(s, ')')
else
begin
s:=separateleft(value,'<');
if s=value
then s:='';
s := SeparateLeft(Value, '<');
if s = Value then
s := '';
end;
end;
result:=trim(s);
Result := Trim(s);
end;
{==============================================================================}
{StrToHex}
function StrToHex(value:string):string;
function StrToHex(const Value: string): string;
var
n:integer;
n: Integer;
begin
result:='';
for n:=1 to length(value) do
Result:=Result+IntToHex(Byte(value[n]),2);
result:=lowercase(result);
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;
function IntToBin(Value: Integer; Digits: Byte): string;
var
x,y,n:integer;
x, y, n: Integer;
begin
result:='';
x:=value;
Result := '';
x := Value;
repeat
y := x mod 2;
x := x div 2;
if y>0
then result:='1'+result
else result:='0'+result;
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;
x := Length(Result);
for n := x to Digits - 1 do
Result := '0' + Result;
end;
{==============================================================================}
{BinToInt}
function BinToInt(value:string):integer;
function BinToInt(const Value: string): Integer;
var
x,n:integer;
n: Integer;
begin
result:=0;
for n:=1 to length(value) do
Result := 0;
for n := 1 to Length(Value) do
begin
if value[n]='0'
then x:=0
else x:=1;
result:=result*2+x;
if Value[n] = '0' then
Result := Result * 2
else
if Value[n] = '1' then
Result := Result * 2 + 1
else
Break;
end;
end;
{==============================================================================}
{ParseURL}
function ParseURL(URL:string; var Prot,User,Pass,Host,Port,Path,Para:string):string;
function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
Para: string): string;
var
x:integer;
x: Integer;
sURL: string;
s: string;
s1, s2: string;
begin
prot:='http';
user:='';
pass:='';
port:='80';
para:='';
Prot := 'http';
User := '';
Pass := '';
Port := '80';
Para := '';
x:=pos('://',URL);
x := Pos('://', URL);
if x > 0 then
begin
prot:=separateleft(URL,'://');
sURL:=separateright(URL,'://');
Prot := SeparateLeft(URL, '://');
sURL := SeparateRight(URL, '://');
end
else sURL:=URL;
x:=pos('@',sURL);
else
sURL := URL;
x := Pos('@', sURL);
if x > 0 then
begin
s:=separateleft(sURL,'@');
sURL:=separateright(sURL,'@');
x:=pos(':',s);
s := SeparateLeft(sURL, '@');
sURL := SeparateRight(sURL, '@');
x := Pos(':', s);
if x > 0 then
begin
user:=separateleft(s,':');
pass:=separateright(s,':');
User := SeparateLeft(s, ':');
Pass := SeparateRight(s, ':');
end
else user:=s;
else
User := s;
end;
x:=pos('/',sURL);
x := Pos('/', sURL);
if x > 0 then
begin
s1:=separateleft(sURL,'/');
s2:=separateright(sURL,'/');
s1 := SeparateLeft(sURL, '/');
s2 := SeparateRight(sURL, '/');
end
else
begin
s1 := sURL;
s2 := '';
end;
x:=pos(':',s1);
x := Pos(':', s1);
if x > 0 then
begin
host:=separateleft(s1,':');
port:=separateright(s1,':');
Host := SeparateLeft(s1, ':');
Port := SeparateRight(s1, ':');
end
else host:=s1;
result:='/'+s2;
x:=pos('?',s2);
else
Host := s1;
Result := '/' + s2;
x := Pos('?', s2);
if x > 0 then
begin
path:='/'+separateleft(s2,'?');
para:=separateright(s2,'?');
Path := '/' + SeparateLeft(s2, '?');
Para := SeparateRight(s2, '?');
end
else path:='/'+s2;
if host=''
then host:='localhost';
else
Path := '/' + s2;
if Host = '' then
Host := 'localhost';
end;
{==============================================================================}
{StringReplace}
function StringReplace(value,search,replace:string):string;
function StringReplace(Value, Search, Replace: string): string;
var
x,l,ls,lr:integer;
x, l, ls, lr: Integer;
begin
if (value='') or (Search='') then
if (Value = '') or (Search = '') then
begin
result:=value;
Result := Value;
Exit;
end;
ls:=length(search);
lr:=length(replace);
result:='';
x:=pos(search,value);
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);
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 := Result + Value;
end;
{==============================================================================}
end.

175
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,15 +23,17 @@
| (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}
@ -90,6 +92,7 @@ const
WSANO_DATA = -6;
{$ELSE}
const
DLLStackName = 'wsock32.dll';
var
@ -111,13 +114,12 @@ type
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;
DWORD=integer;
DWORD = Integer;
TLinger = Linger;
{$ENDIF}
type
TWSAStartup = function (wVersionRequired: word;
TWSAStartup = function(wVersionRequired: Word;
var WSData: TWSAData): Integer; stdcall;
TWSACleanup = function: Integer; stdcall;
TWSAGetLastError = function: Integer; stdcall;
@ -126,32 +128,26 @@ type
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;
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;
optval: PChar; optlen: Integer): Integer; stdcall;
TGetSockOpt = function(s: TSocket; level, optname: Integer;
optval: PChar;
var optlen: Integer): Integer; stdcall;
optval: PChar; var optlen: Integer): Integer; stdcall;
TSendTo = function(s: TSocket; var Buf;
len, flags: Integer;
var addrto: TSockAddr;
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;
var Buf; len, flags: Integer): Integer; stdcall;
TRecvFrom = function(s: TSocket;
var Buf; len, flags: Integer;
var from: TSockAddr;
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;
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;
@ -169,7 +165,7 @@ type
namelen: Integer): Integer; stdcall;
TAccept = function(s: TSocket; addr: PSockAddr;
addrlen: PInteger): TSocket; stdcall;
TSocketProc = function (af, Struct, protocol: Integer): TSocket; stdcall;
TSocketProc = function(af, Struc, Protocol: Integer): TSocket; stdcall;
TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint; stdcall;
@ -220,15 +216,19 @@ 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 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 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 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;
@ -237,29 +237,35 @@ 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 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 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;
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;
@ -269,37 +275,37 @@ end;
function LSWSAGetLastError: Integer;
begin
result:=System.GetLastError;
Result := System.GetLastError;
end;
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;
begin
result:=libc.GetServByPort(port,proto);
Result := libc.GetServByPort(port, proto);
end;
function LSGetProtoByName(name: PChar): PProtoEnt;
begin
result:=libc.getprotobyname(Name);
Result := libc.GetProtoByName(Name);
end;
function LSGetProtoByNumber(proto: Integer): PProtoEnt;
begin
result:=libc.getprotobynumber(proto);
Result := libc.GetProtoByNumber(proto);
end;
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;
@ -309,37 +315,41 @@ end;
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;
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;
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;
@ -354,27 +364,27 @@ end;
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;
begin
result:=libc.ioctl(s,cmd,@arg);
Result := libc.ioctl(s, cmd, @arg);
end;
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;
begin
result:=libc.inet_addr(cp);
Result := libc.inet_addr(cp);
end;
function LShtons(hostshort: u_short): u_short;
begin
result:=libc.HToNs(HostShort);
Result := libc.HToNs(HostShort);
end;
function LShtonl(hostlong: u_long): u_long;
@ -394,37 +404,37 @@ end;
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;
begin
result:=libc.__close(s);
Result := libc.__close(s);
end;
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;
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);
end;
{$ENDIF}
function InitSocketInterface(stack: string): Boolean;
begin
{$IFDEF LINUX}
@ -451,23 +461,24 @@ 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;
{$ELSE}
Result := False;
if stack=''
then stack:=DLLStackName;
if stack = '' then
stack := DLLStackName;
LibHandle := Windows.LoadLibrary(PChar(Stack));
if LibHandle <> 0 then begin
if LibHandle <> 0 then
begin
Accept := Windows.GetProcAddress(LibHandle, PChar('accept'));
Bind := Windows.GetProcAddress(LibHandle, PChar('bind'));
CloseSocket := Windows.GetProcAddress(LibHandle, PChar('closesocket'));
@ -510,13 +521,11 @@ 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;
end;
end.