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 | | 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 | | (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/ |
| | | |
@ -26,6 +26,7 @@
|==============================================================================} |==============================================================================}
{$Q-} {$Q-}
{$WEAKPACKAGEUNIT ON}
unit ASN1Util; unit ASN1Util;
@ -46,204 +47,202 @@ const
ASN1_TIMETICKS = $43; ASN1_TIMETICKS = $43;
ASN1_OPAQUE = $44; ASN1_OPAQUE = $44;
function ASNEncOIDitem(Value: integer): string; function ASNEncOIDItem(Value: Integer): string;
function ASNDecOIDitem(var Start: integer; Buffer: string): integer; function ASNDecOIDItem(var Start: Integer; const Buffer: string): Integer;
function ASNEncLen(Len: integer): string; function ASNEncLen(Len: Integer): string;
function ASNDecLen(var Start: integer; Buffer: string): integer; function ASNDecLen(var Start: Integer; const Buffer: string): Integer;
function ASNEncInt(Value: integer): string; function ASNEncInt(Value: Integer): string;
function ASNEncUInt(Value: integer): string; function ASNEncUInt(Value: Integer): string;
function ASNObject(Data: string; ASNType: integer): string; function ASNObject(const Data: string; ASNType: Integer): string;
function ASNItem(var Start: integer; Buffer: string; var ValueType:integer): string; function ASNItem(var Start: Integer; const Buffer: string;
Function MibToId(mib:string):string; var ValueType: Integer): string;
Function IdToMib(id:string):string; function MibToId(Mib: string): string;
Function IntMibToStr(int:string):string; function IdToMib(const Id: string): string;
function IntMibToStr(const Value: string): string;
function IPToID(Host: string): string; function IPToID(Host: string): string;
implementation implementation
{==============================================================================} {==============================================================================}
{ASNEncOIDitem}
function ASNEncOIDitem(Value: integer): string; function ASNEncOIDItem(Value: Integer): string;
var var
x,xm:integer; x, xm: Integer;
b:boolean; b: Boolean;
begin begin
x:=value; x := Value;
b:=false; b := False;
result:=''; Result := '';
repeat repeat
xm := x mod 128; xm := x mod 128;
x := x div 128; x := x div 128;
if b then if b then
xm := xm or $80; xm := xm or $80;
if x>0 if x > 0 then
then b:=true; b := True;
result:=char(xm)+result; Result := Char(xm) + Result;
until x = 0; until x = 0;
end; end;
{==============================================================================} {==============================================================================}
{ASNDecOIDitem}
function ASNDecOIDitem(var Start: integer; Buffer: string): integer; function ASNDecOIDItem(var Start: Integer; const Buffer: string): Integer;
var var
x:integer; x: Integer;
b:boolean; b: Boolean;
begin begin
result:=0; Result := 0;
repeat repeat
result:=result*128; Result := Result * 128;
x := Ord(Buffer[Start]); x := Ord(Buffer[Start]);
inc(start); Inc(Start);
b:=x>$7f; b := x > $7F;
x:=x and $7f; x := x and $7F;
result:=result+x; Result := Result + x;
if not b until not b;
then break;
until false
end; end;
{==============================================================================} {==============================================================================}
{ASNEncLen}
function ASNEncLen(Len: integer): string; function ASNEncLen(Len: Integer): string;
var var
x, y: integer; x, y: Integer;
begin begin
if (len<$80) if Len < $80 then
then result:=char(len) Result := Char(Len)
else else
begin begin
x:=len; x := Len;
result:=''; Result := '';
repeat repeat
y := x mod 256; y := x mod 256;
x := x div 256; x := x div 256;
result:=char(y)+result; Result := Char(y) + Result;
until x = 0; until x = 0;
y:=length(result); y := Length(Result);
y := y or $80; y := y or $80;
result:=char(y)+result; Result := Char(y) + Result;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{ASNDecLen}
function ASNDecLen(var Start: integer; Buffer: string): integer; function ASNDecLen(var Start: Integer; const Buffer: string): Integer;
var var
x,n: integer; x, n: Integer;
begin begin
x := Ord(Buffer[Start]); x := Ord(Buffer[Start]);
Inc(Start); Inc(Start);
if (x<$80) if x < $80 then
then Result:=x Result := x
else else
begin begin
result:=0; Result := 0;
x:=x and $7f; x := x and $7F;
for n := 1 to x do for n := 1 to x do
begin begin
result:=result*256; Result := Result * 256;
x := Ord(Buffer[Start]); x := Ord(Buffer[Start]);
Inc(Start); Inc(Start);
result:=result+x; Result := Result + x;
end; end;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{ASNEncInt}
function ASNEncInt(Value: integer): string; function ASNEncInt(Value: Integer): string;
var var
x,y:cardinal; x, y: Cardinal;
neg:boolean; neg: Boolean;
begin begin
neg:=value<0; neg := Value < 0;
x:=abs(Value); x := Abs(Value);
if neg then if neg then
x := not (x - 1); x := not (x - 1);
result:=''; Result := '';
repeat repeat
y := x mod 256; y := x mod 256;
x := x div 256; x := x div 256;
result:=char(y)+result; Result := Char(y) + Result;
until x = 0; until x = 0;
if (not neg) and (result[1]>#$7F) if (not neg) and (Result[1] > #$7F) then
then result:=#0+result; Result := #0 + Result;
end; end;
{==============================================================================} {==============================================================================}
{ASNEncUInt}
function ASNEncUInt(Value: integer): string; function ASNEncUInt(Value: Integer): string;
var var
x,y:integer; x, y: Integer;
neg:boolean; neg: Boolean;
begin begin
neg:=value<0; neg := Value < 0;
x := Value; x := Value;
if neg if neg then
then x:=x and $7FFFFFFF; x := x and $7FFFFFFF;
result:=''; Result := '';
repeat repeat
y := x mod 256; y := x mod 256;
x := x div 256; x := x div 256;
result:=char(y)+result; Result := Char(y) + Result;
until x = 0; until x = 0;
if neg if neg then
then result[1]:=char(ord(result[1]) or $80); Result[1] := Char(Ord(Result[1]) or $80);
end; end;
{==============================================================================} {==============================================================================}
{ASNObject}
function ASNObject(Data: string; ASNType: integer): string; function ASNObject(const Data: string; ASNType: Integer): string;
begin begin
Result := Char(ASNType) + ASNEncLen(Length(Data)) + Data; Result := Char(ASNType) + ASNEncLen(Length(Data)) + Data;
end; 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 var
ASNType: integer; ASNType: Integer;
ASNSize: integer; ASNSize: Integer;
y,n: integer; y, n: Integer;
x: byte; x: byte;
s: string; s: string;
c: char; c: char;
neg: boolean; neg: Boolean;
l:integer; l: Integer;
begin begin
Result := ''; Result := '';
ValueType := ASN1_NULL; ValueType := ASN1_NULL;
l:=length(buffer); l := Length(Buffer);
if l<(start+1) if l < (Start + 1) then
then exit; Exit;
ASNType := Ord(Buffer[Start]); ASNType := Ord(Buffer[Start]);
Valuetype:=ASNType; ValueType := ASNType;
Inc(start); Inc(Start);
ASNSize := ASNDecLen(Start, Buffer); ASNSize := ASNDecLen(Start, Buffer);
if (Start+ASNSize-1)>l if (Start + ASNSize - 1) > l then
then exit; Exit;
if ((ASNType and $20) > 0) then if (ASNType and $20) > 0 then
begin Result := '$' + IntToHex(ASNType, 2)
Result := '$' + IntToHex(ASNType, 2);
end
else else
case ASNType of case ASNType of
ASN1_INT: ASN1_INT:
begin begin
y := 0; y := 0;
neg:=false; neg := False;
for n := 1 to ASNSize do for n := 1 to ASNSize do
begin begin
x := Ord(Buffer[Start]); x := Ord(Buffer[Start]);
if (n=1) and (x>$7F) if (n = 1) and (x > $7F) then
then neg:=true; neg := True;
if neg if neg then
then x:=not x; x := not x;
y := y * 256 + x; y := y * 256 + x;
Inc(Start); Inc(Start);
end; end;
if neg if neg then
then y:=-(y+1); y := -(y + 1);
Result := IntToStr(y); Result := IntToStr(y);
end; end;
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS: ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
@ -299,17 +298,17 @@ begin
end; end;
{==============================================================================} {==============================================================================}
{MibToId}
function MibToId(mib:string):string;
var
x:integer;
Function walkInt(var s:string):integer; function MibToId(Mib: string): string;
var var
x:integer; x: Integer;
function WalkInt(var s: string): Integer;
var
x: Integer;
t: string; t: string;
begin begin
x:=pos('.',s); x := Pos('.', s);
if x < 1 then if x < 1 then
begin begin
t := s; t := s;
@ -317,62 +316,64 @@ var
end end
else else
begin begin
t:=copy(s,1,x-1); t := Copy(s, 1, x - 1);
s:=copy(s,x+1,length(s)-x); s := Copy(s, x + 1, Length(s) - x);
end; end;
result:=StrToIntDef(t,0); Result := StrToIntDef(t, 0);
end; end;
begin begin
result:=''; Result := '';
x:=walkint(mib); x := WalkInt(Mib);
x:=x*40+walkint(mib); x := x * 40 + WalkInt(Mib);
result:=ASNEncOIDItem(x); Result := ASNEncOIDItem(x);
while mib<>'' do while Mib <> '' do
begin begin
x:=walkint(mib); x := WalkInt(Mib);
result:=result+ASNEncOIDItem(x); Result := Result + ASNEncOIDItem(x);
end; end;
end; end;
{==============================================================================} {==============================================================================}
{IdToMib}
Function IdToMib(id:string):string; function IdToMib(const Id: string): string;
var var
x,y,n:integer; x, y, n: Integer;
begin begin
result:=''; Result := '';
n := 1; n := 1;
while length(id)+1>n do while Length(Id) + 1 > n do
begin begin
x:=ASNDecOIDItem(n,id); x := ASNDecOIDItem(n, Id);
if (n - 1) = 1 then if (n - 1) = 1 then
begin begin
y := x div 40; y := x div 40;
x := x mod 40; x := x mod 40;
result:=IntTostr(y); Result := IntToStr(y);
end; end;
result:=result+'.'+IntToStr(x); Result := Result + '.' + IntToStr(x);
end; end;
end; end;
{==============================================================================} {==============================================================================}
{IntMibToStr}
Function IntMibToStr(int:string):string; function IntMibToStr(const Value: string): string;
Var var
n,y:integer; n, y: Integer;
begin begin
y := 0; y := 0;
for n:=1 to length(int)-1 do for n := 1 to Length(Value) - 1 do
y:=y*256+ord(int[n]); y := y * 256 + Ord(Value[n]);
result:=IntToStr(y); Result := IntToStr(y);
end; end;
{==============================================================================} {==============================================================================}
{IPToID} //Hernan Sanchez //Hernan Sanchez
function IPToID(Host: string): string; function IPToID(Host: string): string;
var var
s, t: string; s, t: string;
i, x: integer; i, x: Integer;
begin begin
Result := ''; Result := '';
for x := 1 to 3 do for x := 1 to 3 do
@ -381,19 +382,11 @@ begin
s := StrScan(PChar(Host), '.'); s := StrScan(PChar(Host), '.');
t := Copy(Host, 1, (Length(Host) - Length(s))); t := Copy(Host, 1, (Length(Host) - Length(s)));
Delete(Host, 1, (Length(Host) - Length(s) + 1)); Delete(Host, 1, (Length(Host) - Length(s) + 1));
i := StrTointDef(t, 0); i := StrToIntDef(t, 0);
Result := Result + Chr(i); Result := Result + Chr(i);
end; end;
i := StrTointDef(Host, 0); i := StrToIntDef(Host, 0);
Result := Result + Chr(i); Result := Result + Chr(i);
end; end;
{==============================================================================}
begin
exit;
asm
db 'Synapse ASN.1 library by Lukas Gebauer',0
end;
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 | | 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 | | (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/ |
| | | |
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | 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. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -26,306 +26,296 @@
// RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230 // RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
{$Q-} {$Q-}
{$WEAKPACKAGEUNIT ON}
unit DNSsend; unit DNSsend;
interface interface
uses uses
Blcksock, sysutils, classes, SynaUtil; SysUtils, Classes,
blcksock, SynaUtil;
const const
Qtype_A =1; cDnsProtocol = 'Domain';
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_RP =17; QTYPE_A = 1;
Qtype_AFSDB =18; QTYPE_NS = 2;
Qtype_X25 =19; QTYPE_MD = 3;
Qtype_ISDN =20; QTYPE_MF = 4;
Qtype_RT =21; QTYPE_CNAME = 5;
Qtype_NSAP =22; QTYPE_SOA = 6;
Qtype_NSAPPTR=23; QTYPE_MB = 7;
Qtype_SIG =24; //RFC-2065 QTYPE_MG = 8;
Qtype_KEY =25; //RFC-2065 QTYPE_MR = 9;
Qtype_PX =26; QTYPE_NULL = 10;
Qtype_GPOS =27; QTYPE_WKS = 11; //
Qtype_AAAA =28; //IP6 Address [Susan Thomson] QTYPE_PTR = 12;
Qtype_LOC =29; //RFC-1876 QTYPE_HINFO = 13;
Qtype_NXT =30; //RFC-2065 QTYPE_MINFO = 14;
QTYPE_MX = 15;
QTYPE_TXT = 16;
Qtype_SRV =33; //RFC-2052 QTYPE_RP = 17;
Qtype_NAPTR =35; //RFC-2168 QTYPE_AFSDB = 18;
Qtype_KX =36; 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_SRV = 33; // RFC-2052
Qtype_MAILB =253; // QTYPE_NAPTR = 35; // RFC-2168
Qtype_MAILA =254; // QTYPE_KX = 36;
Qtype_ALL =255; //
QTYPE_AXFR = 252; //
QTYPE_MAILB = 253; //
QTYPE_MAILA = 254; //
QTYPE_ALL = 255; //
type type
TDNSSend = class TDNSSend = class(TObject)
private private
Buffer:string; FTimeout: Integer;
Sock:TUDPBlockSocket; FDNSHost: string;
function CompressName(Value:string):string; FRCode: Integer;
FBuffer: string;
FSock: TUDPBlockSocket;
function CompressName(const Value: string): string;
function CodeHeader: string; function CodeHeader: string;
function CodeQuery(Name:string; Qtype:integer):string; function CodeQuery(const Name: string; QType: Integer): string;
function DecodeLabels(var From:integer):string; function DecodeLabels(var From: Integer): string;
function DecodeResource(var i:integer; Name:string; Qtype:integer):string; function DecodeResource(var i: Integer; const Name: string;
QType: Integer): string;
public public
timeout:integer; constructor Create;
DNSHost:string; destructor Destroy; override;
RCode:integer; function DNSQuery(Name: string; QType: Integer;
Constructor Create; const Reply: TStrings): Boolean;
Destructor Destroy; override; published
Function DNSQuery(Name:string;Qtype:integer;Reply:TStrings):Boolean; property Timeout: Integer read FTimeout Write FTimeout;
property DNSHost: string read FDNSHost Write FDNSHost;
property RCode: Integer read FRCode;
end; end;
function GetMailServers (DNSHost, domain:string; servers:TStringList):Boolean; function GetMailServers(const DNSHost, Domain: string;
const Servers: TStrings): Boolean;
implementation implementation
{TDNSSend.Create} constructor TDNSSend.Create;
Constructor TDNSSend.Create;
begin begin
inherited Create; inherited Create;
sock:=TUDPBlockSocket.create; FSock := TUDPBlockSocket.Create;
sock.CreateSocket; FSock.CreateSocket;
timeout:=5000; FTimeout := 5000;
DNShost:='localhost'; FDNSHost := cLocalhost;
end; end;
{TDNSSend.Destroy} destructor TDNSSend.Destroy;
Destructor TDNSSend.Destroy;
begin begin
Sock.free; FSock.Free;
inherited destroy; inherited Destroy;
end; end;
{TDNSSend.ComressName} function TDNSSend.CompressName(const Value: string): string;
function TDNSSend.CompressName(Value:string):string;
var var
n:integer; n: Integer;
s:String; s: string;
begin begin
Result := ''; Result := '';
if Value='' then Result:=char(0) if Value = '' then
Result := #0
else else
begin begin
s := ''; s := '';
for n := 1 to Length(Value) do for n := 1 to Length(Value) do
if Value[n] = '.' then if Value[n] = '.' then
begin begin
Result:=Result+char(Length(s))+s; Result := Result + Char(Length(s)) + s;
s := ''; s := '';
end end
else s:=s+Value[n]; else
if s<>'' then Result:=Result+char(Length(s))+s; s := s + Value[n];
Result:=Result+char(0); if s <> '' then
Result := Result + Char(Length(s)) + s;
Result := Result + #0;
end; end;
end; end;
{TDNSSend.CodeHeader}
function TDNSSend.CodeHeader: string; function TDNSSend.CodeHeader: string;
begin begin
Randomize; Randomize;
Result:=Codeint(Random(32767)); //ID Result := CodeInt(Random(32767)); // ID
Result:=Result+Codeint($0100); //flags Result := Result + CodeInt($0100); // flags
Result:=Result+Codeint(1); //QDCount Result := Result + CodeInt(1); // QDCount
Result:=Result+Codeint(0); //ANCount Result := Result + CodeInt(0); // ANCount
Result:=Result+Codeint(0); //NSCount Result := Result + CodeInt(0); // NSCount
Result:=Result+Codeint(0); //ARCount Result := Result + CodeInt(0); // ARCount
end; end;
{TDNSSend.CodeQuery} function TDNSSend.CodeQuery(const Name: string; QType: Integer): string;
function TDNSSend.CodeQuery(Name:string; Qtype:integer):string;
begin begin
Result:=Compressname(Name); Result := CompressName(Name);
Result:=Result+Codeint(Qtype); Result := Result + CodeInt(QType);
Result:=Result+Codeint(1); //Type INTERNET Result := Result + CodeInt(1); // Type INTERNET
end; end;
{TDNSSend.DecodeLabels} function TDNSSend.DecodeLabels(var From: Integer): string;
function TDNSSend.DecodeLabels(var From:integer):string;
var var
l,f:integer; l, f: Integer;
begin begin
Result := ''; Result := '';
while True do while True do
begin begin
l:=Ord(Buffer[From]); l := Ord(FBuffer[From]);
Inc(From); Inc(From);
if l=0 then break; if l = 0 then
if Result<>'' then Result:=Result+'.'; Break;
if (l and $C0)=$C0 if Result <> '' then
then Result := Result + '.';
if (l and $C0) = $C0 then
begin begin
f := l and $3F; f := l and $3F;
f:=f*256+Ord(Buffer[From])+1; f := f * 256 + Ord(FBuffer[From]) + 1;
Inc(From); Inc(From);
Result:=Result+Self.decodelabels(f); Result := Result + DecodeLabels(f);
break; Break;
end end
else else
begin begin
Result:=Result+Copy(Buffer,From,l); Result := Result + Copy(FBuffer, From, l);
Inc(From, l); Inc(From, l);
end; end;
end; end;
end; end;
{TDNSSend.DecodeResource} function TDNSSend.DecodeResource(var i: Integer; const Name: string;
function TDNSSend.DecodeResource(var i:integer; Name:string; QType: Integer): string;
Qtype:integer):string;
var var
Rname: string; Rname: string;
RType,Len,j,x,n:integer; RType, Len, j, x, n: Integer;
begin begin
Result := ''; Result := '';
Rname:=decodelabels(i); Rname := DecodeLabels(i);
Rtype:=DeCodeint(Buffer,i); RType := DecodeInt(FBuffer, i);
Inc(i, 8); Inc(i, 8);
Len:=DeCodeint(Buffer,i); Len := DecodeInt(FBuffer, i);
Inc(i, 2); // i point to begin of data Inc(i, 2); // i point to begin of data
j := i; j := i;
i := i + len; // i point to next record i := i + len; // i point to next record
if (Name=Rname) and (Qtype=RType) then if (Name = Rname) and (QType = RType) then
begin begin
case Rtype of case RType of
Qtype_A : QTYPE_A:
begin begin
Result:=IntToStr(Ord(Buffer[j])); Result := IntToStr(Ord(FBuffer[j]));
Inc(j); Inc(j);
Result:=Result+'.'+IntToStr(Ord(Buffer[j])); Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j); Inc(j);
Result:=Result+'.'+IntToStr(Ord(Buffer[j])); Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j); Inc(j);
Result:=Result+'.'+IntToStr(Ord(Buffer[j])); Result := Result + '.' + IntToStr(Ord(FBuffer[j]));
end; end;
Qtype_NS, QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
Qtype_MD, QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP,
Qtype_MF, QTYPE_NSAPPTR:
Qtype_CNAME, Result := DecodeLabels(j);
Qtype_MB, QTYPE_SOA:
Qtype_MG,
Qtype_MR,
Qtype_PTR,
Qtype_X25,
Qtype_NSAP,
Qtype_NSAPPTR:
begin begin
Result:=Decodelabels(j); Result := DecodeLabels(j);
end; Result := Result + ',' + DecodeLabels(j);
Qtype_SOA :
begin
Result:=Decodelabels(j);
Result:=Result+','+Decodelabels(j);
for n := 1 to 5 do for n := 1 to 5 do
begin begin
x:=DecodeInt(Buffer,j)*65536+DecodeInt(Buffer,j+2); x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
Inc(j, 4); Inc(j, 4);
Result := Result + ',' + IntToStr(x); Result := Result + ',' + IntToStr(x);
end; end;
end; end;
Qtype_NULL : QTYPE_NULL:
begin begin
end; end;
Qtype_WKS : QTYPE_WKS:
begin begin
end; end;
Qtype_HINFO, QTYPE_HINFO, QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
Qtype_MINFO,
Qtype_RP,
Qtype_ISDN :
begin begin
Result:=Decodelabels(j); Result := DecodeLabels(j);
Result:=Result+','+Decodelabels(j); Result := Result + ',' + DecodeLabels(j);
end; end;
Qtype_MX, QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
Qtype_AFSDB,
Qtype_RT,
Qtype_KX :
begin begin
x:=DecodeInt(Buffer,j); x := DecodeInt(FBuffer, j);
Inc(j, 2); Inc(j, 2);
Result := IntToStr(x); Result := IntToStr(x);
Result:=Result+','+Decodelabels(j); Result := Result + ',' + DecodeLabels(j);
end; end;
Qtype_TXT : QTYPE_TXT:
Result := DecodeLabels(j);
QTYPE_GPOS:
begin begin
Result:=Decodelabels(j); Result := DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
Result := Result + ',' + DecodeLabels(j);
end; end;
Qtype_GPOS : QTYPE_PX:
begin begin
Result:=Decodelabels(j); x := DecodeInt(FBuffer, j);
Result:=Result+','+Decodelabels(j);
Result:=Result+','+Decodelabels(j);
end;
Qtype_PX :
begin
x:=DecodeInt(Buffer,j);
Inc(j, 2); Inc(j, 2);
Result := IntToStr(x); Result := IntToStr(x);
Result:=Result+','+Decodelabels(j); Result := Result + ',' + DecodeLabels(j);
Result:=Result+','+Decodelabels(j); Result := Result + ',' + DecodeLabels(j);
end; end;
end; end;
end; end;
end; end;
{TDNSSend.DNSQuery} function TDNSSend.DNSQuery(Name: string; QType: Integer;
Function TDNSSend.DNSQuery(Name:string;Qtype:integer;Reply:TStrings):Boolean; const Reply: TStrings): Boolean;
var var
x,n,i:integer; x, n, i: Integer;
flag,qdcount, ancount, nscount, arcount:integer; flag, qdcount, ancount, nscount, arcount: Integer;
s: string; s: string;
begin begin
Result := False; Result := False;
Reply.Clear; Reply.Clear;
if IsIP(Name) then Name:=ReverseIP(Name)+'.in-addr.arpa'; if IsIP(Name) then
Buffer:=Codeheader+CodeQuery(Name,QType); Name := ReverseIP(Name) + '.in-addr.arpa';
sock.connect(DNSHost,'domain'); FBuffer := CodeHeader + CodeQuery(Name, QType);
// dump(Buffer,'c:\dnslog.Txt'); FSock.Connect(FDNSHost, cDnsProtocol);
sock.sendstring(Buffer); FSock.SendString(FBuffer);
if sock.canread(timeout) if FSock.CanRead(FTimeout) then
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
begin begin
qdcount:=DeCodeint(Buffer,5); x := FSock.WaitingData;
ancount:=DeCodeint(Buffer,7); SetLength(FBuffer, x);
nscount:=DeCodeint(Buffer,9); FSock.RecvBuffer(Pointer(FBuffer), x);
arcount:=DeCodeint(Buffer,11); 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 i := 13; //begin of body
if qdcount > 0 then //skip questions if qdcount > 0 then //skip questions
for n := 1 to qdcount do for n := 1 to qdcount do
begin 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);
Inc(i, 5); Inc(i, 5);
end; end;
if ancount > 0 then if ancount > 0 then
for n := 1 to ancount do for n := 1 to ancount do
begin begin
s:=DecodeResource(i, Name, Qtype); s := DecodeResource(i, Name, QType);
if s <> '' then if s <> '' then
Reply.Add(s); Reply.Add(s);
end; 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 var
DNS: TDNSSend; DNS: TDNSSend;
t: TStringList; t: TStringList;
n,m,x:integer; n, m, x: Integer;
begin begin
Result := False; Result := False;
servers.Clear; Servers.Clear;
t := TStringList.Create; t := TStringList.Create;
DNS := TDNSSend.Create; DNS := TDNSSend.Create;
try try
DNS.DNSHost := DNSHost; DNS.DNSHost := DNSHost;
if DNS.DNSQuery(domain,QType_MX,t) then if DNS.DNSQuery(Domain, QType_MX, t) then
begin begin
{ normalize preference number to 5 digits } { normalize preference number to 5 digits }
for n := 0 to t.Count - 1 do for n := 0 to t.Count - 1 do
@ -364,7 +355,7 @@ begin
for n := 0 to t.Count - 1 do for n := 0 to t.Count - 1 do
begin begin
x := Pos(',', t[n]); 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; end;
Result := True; Result := True;
end; end;
@ -375,5 +366,3 @@ begin
end; end;
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 | | 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 | | (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/ |
| | | |
@ -23,423 +23,432 @@
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit HTTPSend; unit HTTPSend;
interface interface
uses uses
Blcksock, sysutils, classes, SynaUtil, SynaCode; SysUtils, Classes,
blcksock, SynaUtil, SynaCode;
const const
CRLF=#13+#10; cHttpProtocol = '80';
type type
TTransferEncoding=(TE_UNKNOWN, TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
TE_IDENTITY,
TE_CHUNKED);
THTTPSend = class THTTPSend = class(TObject)
private private
Sock:TTCPBlockSocket; FSock: TTCPBlockSocket;
TransferEncoding:TTransferEncoding; FTransferEncoding: TTransferEncoding;
AliveHost:string; FAliveHost: string;
AlivePort:string; FAlivePort: string;
function ReadUnknown:boolean; FHeaders: TStringList;
function ReadIdentity(size:integer):boolean; FDocument: TMemoryStream;
function ReadChunked:boolean; 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 public
headers:TStringlist; constructor Create;
Document:TMemoryStream; destructor Destroy; override;
MimeType:string; procedure Clear;
Protocol:string; procedure DecodeStatus(const Value: string);
KeepAlive:boolean; function HTTPMethod(const Method, URL: string): Boolean;
Timeout:integer; published
HTTPHost:string; property Headers: TStringList read FHeaders Write FHeaders;
HTTPPort:string; property Document: TMemoryStream read FDocument Write FDocument;
ProxyHost:string; property MimeType: string read FMimeType Write FMimeType;
ProxyPort:string; property Protocol: string read FProtocol Write FProtocol;
ProxyUser:string; property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
ProxyPass:string; property Timeout: Integer read FTimeout Write FTimeout;
ResultCode:integer; property HTTPHost: string read FHTTPHost;
ResultString:string; property HTTPPort: string read FHTTPPort;
Constructor Create; property ProxyHost: string read FProxyHost Write FProxyHost;
Destructor Destroy; override; property ProxyPort: string read FProxyPort Write FProxyPort;
procedure clear; property ProxyUser: string read FProxyUser Write FProxyUser;
procedure DecodeStatus(value:string); property ProxyPass: string read FProxyPass Write FProxyPass;
function HTTPmethod(method,URL:string):boolean; property ResultCode: Integer read FResultCode;
property ResultString: string read FResultString;
end; end;
function HttpGetText(URL:string;Response:TStrings):Boolean; function HttpGetText(const URL: string; const Response: TStrings): Boolean;
function HttpGetBinary(URL:string;Response:TStream):Boolean; function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
function HttpPostBinary(URL:string;Data:TStream):Boolean; function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
function HttpPostURL(URL:string;URLData:string;Data:TStream):Boolean; function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
implementation implementation
{THTTPSend.Create} const
Constructor THTTPSend.Create; CRLF = #13#10;
constructor THTTPSend.Create;
begin begin
inherited Create; inherited Create;
Headers:=TStringList.create; FHeaders := TStringList.Create;
Document:=TMemoryStream.Create; FDocument := TMemoryStream.Create;
sock:=TTCPBlockSocket.create; FSock := TTCPBlockSocket.Create;
sock.SizeRecvBuffer:=65536; FSock.SizeRecvBuffer := 65536;
sock.SizeSendBuffer:=65536; FSock.SizeSendBuffer := 65536;
timeout:=300000; FTimeout := 300000;
HTTPhost:='localhost'; FHTTPHost := cLocalhost;
HTTPPort:='80'; FHTTPPort := cHttpProtocol;
ProxyHost:=''; FProxyHost := '';
ProxyPort:='8080'; FProxyPort := '8080';
ProxyUser:=''; FProxyUser := '';
ProxyPass:=''; FProxyPass := '';
AliveHost:=''; FAliveHost := '';
AlivePort:=''; FAlivePort := '';
Protocol:='1.1'; FProtocol := '1.1';
KeepAlive:=true; FKeepAlive := True;
Clear; Clear;
end; end;
{THTTPSend.Destroy} destructor THTTPSend.Destroy;
Destructor THTTPSend.Destroy;
begin begin
Sock.free; FSock.Free;
Document.free; FDocument.Free;
headers.free; FHeaders.Free;
inherited destroy; inherited Destroy;
end; end;
{THTTPSend.Clear}
procedure THTTPSend.Clear; procedure THTTPSend.Clear;
begin begin
Document.Clear; FDocument.Clear;
Headers.Clear; FHeaders.Clear;
MimeType:='text/html'; FMimeType := 'text/html';
end; end;
{THTTPSend.DecodeStatus} procedure THTTPSend.DecodeStatus(const Value: string);
procedure THTTPSend.DecodeStatus(value:string);
var var
s, su: string; s, su: string;
begin begin
s:=separateright(value,' '); s := SeparateRight(Value, ' ');
su:=separateleft(s,' '); su := SeparateLeft(s, ' ');
ResultCode:=StrToIntDef(su,0); FResultCode := StrToIntDef(su, 0);
ResultString:=separateright(s,' '); FResultString := SeparateRight(s, ' ');
if ResultString=s if FResultString = s then
then ResultString:=''; FResultString := '';
end; end;
{THTTPSend.HTTPmethod} function THTTPSend.HTTPMethod(const Method, URL: string): Boolean;
function THTTPSend.HTTPmethod(method,URL:string):boolean;
var var
sending,receiving:boolean; Sending, Receiving: Boolean;
status100:boolean; status100: Boolean;
status100error: string; status100error: string;
ToClose:boolean; ToClose: Boolean;
size:integer; Size: Integer;
Prot, User, Pass, Host, Port, Path, Para, URI: string; Prot, User, Pass, Host, Port, Path, Para, URI: string;
n:integer; n: Integer;
s, su: string; s, su: string;
begin begin
{initial values} {initial values}
result:=false; Result := False;
ResultCode:=500; FResultCode := 500;
ResultString:=''; FResultString := '';
URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para); URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
sending:=Document.Size>0; Sending := Document.Size > 0;
{headers for sending data} {Headers for Sending data}
status100:=sending and (protocol='1.1'); status100 := Sending and (FProtocol = '1.1');
if status100 if status100 then
then Headers.insert(0,'Expect: 100-continue'); FHeaders.Insert(0, 'Expect: 100-continue');
if sending then if Sending then
begin begin
Headers.insert(0,'Content-Length: '+inttostr(Document.size)); FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
if MimeType<>'' if FMimeType <> '' then
then Headers.insert(0,'Content-Type: '+MimeType); FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
end; end;
{seting KeepAlives} { setting KeepAlives }
if not KeepAlive if not FKeepAlive then
then Headers.insert(0,'Connection: close'); FHeaders.Insert(0, 'Connection: close');
{ set target servers/proxy, authorisations, etc... } { set target servers/proxy, authorisations, etc... }
if User<>'' if User <> '' then
then Headers.insert(0,'Authorization: Basic '+EncodeBase64(user+':'+pass)); FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(user + ':' + pass));
if (proxyhost<>'') and (proxyUser<>'') if (FProxyHost <> '') and (FProxyUser <> '') then
then Headers.insert(0,'Proxy-Authorization: Basic '+EncodeBase64(Proxyuser+':'+Proxypass)); FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
Headers.insert(0,'Host: '+host+':'+port); EncodeBase64(FProxyUser + ':' + FProxyPass));
if proxyHost<>'' FHeaders.Insert(0, 'Host: ' + Host + ':' + Port);
then URI:=prot+'://'+host+':'+port+URI; if FProxyHost <> '' then
if URI='/*' URI := Prot + '://' + Host + ':' + Port + URI;
then URI:='*'; if URI = '/*' then
if protocol='0.9' URI := '*';
then Headers.insert(0,uppercase(method)+' '+URI) if FProtocol = '0.9' then
else Headers.insert(0,uppercase(method)+' '+URI+' HTTP/'+protocol); FHeaders.Insert(0, UpperCase(Method) + ' ' + URI)
if proxyhost='' else
then FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
if FProxyHost = '' then
begin begin
HttpHost:=host; FHTTPHost := Host;
HttpPort:=port; FHTTPPort := Port;
end end
else else
begin begin
HttpHost:=Proxyhost; FHTTPHost := FProxyHost;
HttpPort:=Proxyport; FHTTPPort := FProxyPort;
end; end;
if headers[headers.count-1]<>'' if FHeaders[FHeaders.Count - 1] <> '' then
then headers.add(''); FHeaders.Add('');
{ connect } { connect }
if (Alivehost<>HTTPhost) or (AlivePort<>HTTPport) if (FAliveHost <> FHTTPHost) or (FAlivePort <> FHTTPPort) then
then
begin begin
sock.CloseSocket; FSock.CloseSocket;
sock.CreateSocket; FSock.CreateSocket;
sock.Connect(HTTPHost,HTTPPort); FSock.Connect(FHTTPHost, FHTTPPort);
if sock.lasterror<>0 then Exit; if FSock.LastError <> 0 then
Alivehost:=HTTPhost; Exit;
AlivePort:=HTTPport; FAliveHost := FHTTPHost;
FAlivePort := FHTTPPort;
end end
else else
begin begin
if sock.canread(0) then if FSock.CanRead(0) then
begin begin
sock.CloseSocket; FSock.CloseSocket;
sock.createsocket; FSock.CreateSocket;
sock.Connect(HTTPHost,HTTPPort); FSock.Connect(FHTTPHost, FHTTPPort);
if sock.lasterror<>0 then Exit; if FSock.LastError <> 0 then
Exit;
end; end;
end; end;
{send headers} { send Headers }
Sock.SendString(Headers[0]+CRLF); FSock.SendString(Headers[0] + CRLF);
if protocol<>'0.9' then if FProtocol <> '0.9' then
for n:=1 to Headers.Count-1 do for n := 1 to FHeaders.Count - 1 do
Sock.SendString(Headers[n]+CRLF); FSock.SendString(FHeaders[n] + CRLF);
if sock.lasterror<>0 then Exit; if FSock.LastError <> 0 then
Exit;
{ reading Status } { reading Status }
Status100Error := ''; Status100Error := '';
if status100 then if status100 then
begin begin
repeat repeat
s:=sock.recvstring(timeout); s := FSock.RecvString(FTimeout);
if s<>'' then break; if s <> '' then
until sock.lasterror<>0; Break;
until FSock.LastError <> 0;
DecodeStatus(s); DecodeStatus(s);
if (ResultCode>=100) and (ResultCode<200) if (FResultCode >= 100) and (FResultCode < 200) then
then
begin
repeat repeat
s:=sock.recvstring(timeout); s := FSock.recvstring(FTimeout);
if s='' then break; if s = '' then
until sock.lasterror<>0; Break;
end until FSock.LastError <> 0
else else
begin begin
sending:=false; Sending := False;
Status100Error := s; Status100Error := s;
end; end;
end; end;
{ send document } { send document }
if sending then if Sending then
begin begin
Sock.SendBuffer(Document.memory,Document.size); FSock.SendBuffer(FDocument.Memory, FDocument.Size);
if sock.lasterror<>0 then Exit; if FSock.LastError <> 0 then
Exit;
end; end;
clear; Clear;
size:=-1; Size := -1;
TransferEncoding:=TE_UNKNOWN; FTransferEncoding := TE_UNKNOWN;
{ read status } { read status }
If Status100Error='' if Status100Error = '' then
then
begin begin
repeat repeat
s:=sock.recvstring(timeout); s := FSock.RecvString(FTimeout);
if s<>'' then break; if s <> '' then
until sock.lasterror<>0; Break;
if pos('HTTP/',uppercase(s))=1 until FSock.LastError <> 0;
then if Pos('HTTP/', UpperCase(s)) = 1 then
begin begin
Headers.add(s); FHeaders.Add(s);
decodeStatus(s); DecodeStatus(s);
end end
else else
begin begin
{ old HTTP 0.9 and some buggy servers not send result } { old HTTP 0.9 and some buggy servers not send result }
s := s + CRLF; s := s + CRLF;
document.Write(pointer(s)^,length(s)); FDocument.Write(Pointer(s)^, Length(s));
ResultCode:=0; FResultCode := 0;
end; end;
end end
else Headers.add(Status100Error); else
FHeaders.Add(Status100Error);
{ if need receive hedaers, receive and parse it } { if need receive hedaers, receive and parse it }
ToClose:=protocol<>'1.1'; ToClose := FProtocol <> '1.1';
if Headers.count>0 then if FHeaders.Count > 0 then
repeat repeat
s:=sock.recvstring(timeout); s := FSock.RecvString(FTimeout);
Headers.Add(s); FHeaders.Add(s);
if s='' if s = '' then
then break; Break;
su:=uppercase(s); su := UpperCase(s);
if pos('CONTENT-LENGTH:',su)=1 then if Pos('CONTENT-LENGTH:', su) = 1 then
begin begin
size:=strtointdef(separateright(s,' '),-1); Size := StrToIntDef(SeparateRight(s, ' '), -1);
TransferEncoding:=TE_IDENTITY; FTransferEncoding := TE_IDENTITY;
end; end;
if pos('CONTENT-TYPE:',su)=1 then if Pos('CONTENT-TYPE:', su) = 1 then
MimeType:=separateright(s,' '); FMimeType := SeparateRight(s, ' ');
if pos('TRANSFER-ENCODING:',su)=1 then if Pos('TRANSFER-ENCODING:', su) = 1 then
begin begin
s:=separateright(su,' '); s := SeparateRight(su, ' ');
if pos('CHUNKED',s)>0 then if Pos('CHUNKED', s) > 0 then
TransferEncoding:=TE_CHUNKED; FTransferEncoding := TE_CHUNKED;
end; end;
if pos('CONNECTION: CLOSE',su)=1 then if Pos('CONNECTION: CLOSE', su) = 1 then
ToClose:=true; ToClose := True;
until sock.lasterror<>0; until FSock.LastError <> 0;
{if need receive response body, read it} {if need receive response body, read it}
Receiving := Method <> 'HEAD'; Receiving := Method <> 'HEAD';
Receiving:=Receiving and (ResultCode<>204); Receiving := Receiving and (FResultCode <> 204);
Receiving:=Receiving and (ResultCode<>304); Receiving := Receiving and (FResultCode <> 304);
if Receiving then if Receiving then
case TransferEncoding of case FTransferEncoding of
TE_UNKNOWN : readunknown; TE_UNKNOWN:
TE_IDENTITY: readidentity(size); ReadUnknown;
TE_CHUNKED : readChunked; TE_IDENTITY:
ReadIdentity(Size);
TE_CHUNKED:
ReadChunked;
end; end;
Document.Seek(0,soFromBeginning); FDocument.Seek(0, soFromBeginning);
result:=true; Result := True;
if ToClose then if ToClose then
begin begin
sock.closesocket; FSock.CloseSocket;
Alivehost:=''; FAliveHost := '';
AlivePort:=''; FAlivePort := '';
end; end;
end; end;
{THTTPSend.ReadUnknown} function THTTPSend.ReadUnknown: Boolean;
function THTTPSend.ReadUnknown:boolean;
var var
s: string; s: string;
begin begin
result:=false;
repeat repeat
s:=sock.recvstring(timeout); s := FSock.RecvString(FTimeout);
s := s + CRLF; s := s + CRLF;
document.Write(pointer(s)^,length(s)); FDocument.Write(Pointer(s)^, Length(s));
until sock.lasterror<>0; until FSock.LastError <> 0;
result:=true; Result := True;
end; end;
{THTTPSend.ReadIdentity} function THTTPSend.ReadIdentity(Size: Integer): Boolean;
function THTTPSend.ReadIdentity(size:integer):boolean;
var var
mem: TMemoryStream; mem: TMemoryStream;
begin begin
mem:=TMemoryStream.create; mem := TMemoryStream.Create;
try try
mem.SetSize(size); mem.SetSize(Size);
sock.RecvBufferEx(mem.memory,size,timeout); FSock.RecvBufferEx(mem.Memory, Size, FTimeout);
result:=sock.lasterror=0; Result := FSock.LastError = 0;
document.CopyFrom(mem,0); FDocument.CopyFrom(mem, 0);
finally finally
mem.free; mem.Free;
end; end;
end; end;
{THTTPSend.ReadChunked} function THTTPSend.ReadChunked: Boolean;
function THTTPSend.ReadChunked:boolean;
var var
s: string; s: string;
size:integer; Size: Integer;
begin begin
repeat repeat
repeat repeat
s:=sock.recvstring(timeout); s := FSock.RecvString(FTimeout);
until s <> ''; until s <> '';
if sock.lasterror<>0 if FSock.LastError <> 0 then
then break; Break;
s:=separateleft(s,' '); s := SeparateLeft(s, ' ');
size:=strtointdef('$'+s,0); Size := StrToIntDef('$' + s, 0);
if size=0 then break; if Size = 0 then
ReadIdentity(size); Break;
until false; ReadIdentity(Size);
result:=sock.lasterror=0; until False;
Result := FSock.LastError = 0;
end; end;
{==============================================================================} {==============================================================================}
{HttpGetText} function HttpGetText(const URL: string; const Response: TStrings): Boolean;
function HttpGetText(URL:string;Response:TStrings):Boolean;
var var
HTTP: THTTPSend; HTTP: THTTPSend;
begin begin
Result:=False;
HTTP := THTTPSend.Create; HTTP := THTTPSend.Create;
try try
Result:=HTTP.HTTPmethod('GET',URL); Result := HTTP.HTTPMethod('GET', URL);
response.LoadFromStream(HTTP.document); Response.LoadFromStream(HTTP.Document);
finally finally
HTTP.Free; HTTP.Free;
end; end;
end; end;
{HttpGetBinary} function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
function HttpGetBinary(URL:string;Response:TStream):Boolean;
var var
HTTP: THTTPSend; HTTP: THTTPSend;
begin begin
Result:=False;
HTTP := THTTPSend.Create; HTTP := THTTPSend.Create;
try try
Result:=HTTP.HTTPmethod('GET',URL); Result := HTTP.HTTPMethod('GET', URL);
Response.Seek(0, soFromBeginning); Response.Seek(0, soFromBeginning);
Response.CopyFrom(HTTP.document,0); Response.CopyFrom(HTTP.Document, 0);
finally finally
HTTP.Free; HTTP.Free;
end; end;
end; end;
{HttpPostBinary} function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
function HttpPostBinary(URL:string;Data:TStream):Boolean;
var var
HTTP: THTTPSend; HTTP: THTTPSend;
begin begin
Result:=False;
HTTP := THTTPSend.Create; HTTP := THTTPSend.Create;
try try
HTTP.Document.CopyFrom(data,0); HTTP.Document.CopyFrom(Data, 0);
HTTP.MimeType := 'Application/octet-stream'; HTTP.MimeType := 'Application/octet-stream';
Result:=HTTP.HTTPmethod('POST',URL); Result := HTTP.HTTPMethod('POST', URL);
data.Seek(0,soFromBeginning); Data.Seek(0, soFromBeginning);
data.CopyFrom(HTTP.document,0); Data.CopyFrom(HTTP.Document, 0);
finally finally
HTTP.Free; HTTP.Free;
end; end;
end; end;
{HttpPostURL} function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
function HttpPostURL(URL:string;URLData:string;Data:TStream):Boolean;
var var
HTTP: THTTPSend; HTTP: THTTPSend;
begin begin
Result:=False;
HTTP := THTTPSend.Create; HTTP := THTTPSend.Create;
try try
HTTP.Document.Write(pointer(URLData)^,Length(URLData)); HTTP.Document.Write(Pointer(URLData)^, Length(URLData));
HTTP.MimeType := 'application/x-url-encoded'; HTTP.MimeType := 'application/x-url-encoded';
Result:=HTTP.HTTPmethod('POST',URL); Result := HTTP.HTTPMethod('POST', URL);
data.Seek(0,soFromBeginning); Data.Seek(0, soFromBeginning);
data.CopyFrom(HTTP.document,0); Data.CopyFrom(HTTP.Document, 0);
finally finally
HTTP.Free; HTTP.Free;
end; end;
end; 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 | | 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 | | (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, | | 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 | | 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 Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | 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. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -23,151 +23,151 @@
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit MIMEinLn; unit MIMEinLn;
interface interface
uses uses
sysutils, classes, MIMEchar, SynaCode, SynaUtil; SysUtils, Classes,
SynaChar, SynaCode, SynaUtil;
function InlineDecode(value:string;CP:TMimeChar):string; function InlineDecode(const Value: string; CP: TMimeChar): string;
function InlineEncode(value:string;CP,MimeP:TMimeChar):string; function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
Function NeedInline(value:string):boolean; function NeedInline(const Value: string): boolean;
function InlineCode(value:string):string; function InlineCode(const Value: string): string;
function InlineEmail(value:string):string; function InlineEmail(const Value: string): string;
implementation implementation
{==============================================================================} {==============================================================================}
{InlineDecode}
function InlineDecode(value:string;CP:TMimeChar):string; function InlineDecode(const Value: string; CP: TMimeChar): string;
var var
s, su: string; s, su: string;
x,y,z,n:integer; x, y, z, n: Integer;
ichar: TMimeChar; ichar: TMimeChar;
c:char; c: Char;
function SearchEndInline(value:string;be:integer):integer; function SearchEndInline(const Value: string; be: Integer): Integer;
var var
n,q:integer; n, q: Integer;
begin begin
q := 0; q := 0;
result:=0; Result := 0;
for n:=be+2 to length(value)-1 do for n := be + 2 to Length(Value) - 1 do
if value[n]='?' then if Value[n] = '?' then
begin begin
inc(q); Inc(q);
if (q>2) and (value[n+1]='=') then if (q > 2) and (Value[n + 1] = '=') then
begin begin
result:=n; Result := n;
break; Break;
end; end;
end; end;
end; end;
begin begin
result:=value; Result := Value;
x:=pos('=?',result); x := Pos('=?', Result);
y:=SearchEndInline(result,x); y := SearchEndInline(Result, x);
while y > x do while y > x do
begin begin
s:=copy(result,x,y-x+2); s := Copy(Result, x, y - x + 2);
su:=copy(s,3,length(s)-4); su := Copy(s, 3, Length(s) - 4);
ichar:=GetCPfromID(su); ichar := GetCPFromID(su);
z:=pos('?',su); z := Pos('?', su);
if (length(su)>=(z+2)) and (su[z+2]='?') then if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
begin begin
c:=uppercase(su)[z+1]; c := UpperCase(su)[z + 1];
su:=copy(su,z+3,length(su)-z-2); su := Copy(su, z + 3, Length(su) - z - 2);
if c = 'B' then if c = 'B' then
begin begin
s := DecodeBase64(su); s := DecodeBase64(su);
s:=DecodeChar(s,ichar,CP); s := CharsetConversion(s, ichar, CP);
end; end;
if c = 'Q' then if c = 'Q' then
begin begin
s := ''; s := '';
for n:=1 to length(su) do for n := 1 to Length(su) do
if su[n]='_' if su[n] = '_' then
then s:=s+' ' s := s + ' '
else s:=s+su[n]; else
s:=DecodeQuotedprintable(s); s := s + su[n];
s:=DecodeChar(s,ichar,CP); s := DecodeQuotedPrintable(s);
s := CharsetConversion(s, ichar, CP);
end; end;
end; end;
result:=copy(result,1,x-1)+s+copy(result,y+2,length(result)-y-1); Result := Copy(Result, 1, x - 1) + s +
x:=pos('=?',result); Copy(Result, y + 2, Length(Result) - y - 1);
y:=SearchEndInline(result,x); x := Pos('=?', Result);
y := SearchEndInline(Result, x);
end; end;
end; end;
{==============================================================================} {==============================================================================}
{InlineEncode}
function InlineEncode(value:string;CP,MimeP:TMimeChar):string; function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
var var
s, s1: string; s, s1: string;
n:integer; n: Integer;
begin begin
s:=DecodeChar(value,CP,MimeP); s := CharsetConversion(Value, CP, MimeP);
s := EncodeQuotedPrintable(s); s := EncodeQuotedPrintable(s);
s1 := ''; s1 := '';
for n:=1 to length(s) do for n := 1 to Length(s) do
if s[n]=' ' if s[n] = ' ' then
then s1:=s1+'=20' s1 := s1 + '=20'
else s1:=s1+s[n]; else
result:='=?'+GetIdFromCP(MimeP)+'?Q?'+s1+'?='; s1 := s1 + s[n];
Result := '=?' + GetIdFromCP(MimeP) + '?Q?' + s1 + '?=';
end; end;
{==============================================================================} {==============================================================================}
{NeedInline}
Function NeedInline(value:string):boolean; function NeedInline(const Value: string): boolean;
var var
n:integer; n: Integer;
begin begin
result:=false; Result := False;
for n:=1 to length(value) do for n := 1 to Length(Value) do
if value[n] in (SpecialChar+[char(1)..char(31),char(128)..char(255)]) then if Value[n] in (SpecialChar + [Char(1)..Char(31), Char(128)..Char(255)]) then
begin begin
result:=true; Result := True;
break; Break;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{InlineCode}
function InlineCode(value:string):string; function InlineCode(const Value: string): string;
var var
c: TMimeChar; c: TMimeChar;
begin begin
if NeedInline(value) if NeedInline(Value) then
then
begin 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_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]); 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 end
else result:=value; else
Result := Value;
end; end;
{==============================================================================} {==============================================================================}
{InlineEmail}
function InlineEmail(value:string):string; function InlineEmail(const Value: string): string;
var var
sd, se: string; sd, se: string;
begin begin
sd:=getEmaildesc(value); sd := GetEmailDesc(Value);
se:=getEmailAddr(value); se := GetEmailAddr(Value);
if sd='' if sd = '' then
then result:=se Result := se
else result:='"'+InlineCode(sd)+'"<'+se+'>'; else
Result := '"' + InlineCode(sd) + '"<' + se + '>';
end; end;
{==============================================================================}
begin
exit;
asm
db 'Synapse Inline MIME encoding and decoding library by Lukas Gebauer',0
end;
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 | | 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 | | (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/ |
| | | |
@ -19,112 +19,144 @@
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM From distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit MIMEmess; unit MIMEmess;
interface interface
uses uses
classes, Sysutils, MIMEpart, MimeChar, SynaUtil, MIMEInLn; Classes, SysUtils,
MIMEpart, SynaChar, SynaUtil, MIMEinLn;
type type
TMessHeader = class(TObject)
TMessHeader=record private
from:string; FFrom: string;
ToList:tstringlist; FToList: TStringList;
subject:string; FSubject: string;
organization: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; end;
TMimeMess = class(TObject) TMimeMess = class(TObject)
private private
FPartList: TList;
FLines: TStringList;
FHeader: TMessHeader;
public public
PartList:TList;
Lines:TStringList;
header:TMessHeader;
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
procedure Clear; procedure Clear;
function AddPart:integer; function AddPart: Integer;
procedure AddPartText(value:tstringList); procedure AddPartText(Value: TStringList);
procedure AddPartHTML(value:tstringList); procedure AddPartHTML(Value: TStringList);
procedure AddPartHTMLBinary(Value, Cid: string); procedure AddPartHTMLBinary(Value, Cid: string);
procedure AddPartBinary(value:string); procedure AddPartBinary(Value: string);
procedure EncodeMessage; procedure EncodeMessage;
procedure FinalizeHeaders; procedure FinalizeHeaders;
procedure ParseHeaders; procedure ParseHeaders;
procedure DecodeMessage; 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; end;
implementation implementation
{==============================================================================} {==============================================================================}
{TMimeMess.Create}
Constructor TMimeMess.Create; constructor TMessHeader.Create;
begin begin
inherited Create; inherited Create;
PartList:=TList.create; FToList := TStringList.Create;
Lines:=TStringList.create;
Header.ToList:=TStringList.create;
end; end;
{TMimeMess.Destroy} destructor TMessHeader.Destroy;
Destructor TMimeMess.Destroy;
begin begin
Header.ToList.free; FToList.Free;
Lines.free; inherited Destroy;
PartList.free;
inherited destroy;
end; 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; procedure TMimeMess.Clear;
var var
n:integer; n: Integer;
begin begin
Lines.clear; Lines.Clear;
for n:=0 to PartList.count-1 do for n := 0 to PartList.Count - 1 do
TMimePart(PartList[n]).Free; TMimePart(PartList[n]).Free;
PartList.Clear; PartList.Clear;
with header do FHeader.Clear;
begin
from:='';
ToList.clear;
subject:='';
organization:='';
end;
end; end;
{==============================================================================} {==============================================================================}
{TMimeMess.AddPart}
function TMimeMess.AddPart:integer; function TMimeMess.AddPart: Integer;
var var
mp: TMimePart; mp: TMimePart;
begin begin
mp:=TMimePart.create; mp := TMimePart.Create;
result:=PartList.Add(mp); Result := PartList.Add(mp);
end; end;
{==============================================================================} {==============================================================================}
{TMimeMess.AddPartText}
procedure TMimeMess.AddPartText(value:tstringList); procedure TMimeMess.AddPartText(Value: TStringList);
var var
x:integer; x: Integer;
begin begin
x:=Addpart; x := AddPart;
with TMimePart(PartList[x]) do with TMimePart(PartList[x]) do
begin begin
value.SaveToStream(decodedlines); Value.SaveToStream(DecodedLines);
primary:='text'; Primary := 'text';
secondary:='plain'; Secondary := 'plain';
description:='Message text'; Description := 'Message text';
disposition:='inline'; Disposition := 'inline';
CharsetCode:=IdealCoding(value.text,targetCharset, CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset,
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5, [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]); ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
EncodingCode := ME_QUOTED_PRINTABLE; EncodingCode := ME_QUOTED_PRINTABLE;
@ -133,19 +165,19 @@ begin
end; end;
{==============================================================================} {==============================================================================}
{TMimeMess.AddPartHTML}
procedure TMimeMess.AddPartHTML(value:tstringList); procedure TMimeMess.AddPartHTML(Value: TStringList);
var var
x:integer; x: Integer;
begin begin
x:=Addpart; x := AddPart;
with TMimePart(PartList[x]) do with TMimePart(PartList[x]) do
begin begin
value.SaveToStream(decodedlines); Value.SaveToStream(DecodedLines);
primary:='text'; Primary := 'text';
secondary:='html'; Secondary := 'html';
description:='HTML text'; Description := 'HTML text';
disposition:='inline'; Disposition := 'inline';
CharsetCode := UTF_8; CharsetCode := UTF_8;
EncodingCode := ME_QUOTED_PRINTABLE; EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart; EncodePart;
@ -153,164 +185,154 @@ begin
end; end;
{==============================================================================} {==============================================================================}
{TMimeMess.AddPartBinary}
procedure TMimeMess.AddPartBinary(value:string); procedure TMimeMess.AddPartBinary(Value: string);
var var
x:integer; x: Integer;
s: string; s: string;
begin begin
x:=Addpart; x := AddPart;
with TMimePart(PartList[x]) do with TMimePart(PartList[x]) do
begin begin
DecodedLines.LoadFromFile(Value); DecodedLines.LoadFromFile(Value);
s:=ExtractFileName(value); s := ExtractFileName(Value);
MimeTypeFromExt(s); MimeTypeFromExt(s);
description:='Attached file: '+s; Description := 'Attached file: ' + s;
disposition:='attachment'; Disposition := 'attachment';
filename:=s; FileName := s;
EncodingCode := ME_BASE64; EncodingCode := ME_BASE64;
EncodePart; EncodePart;
end; end;
end; end;
{TMimeMess.AddPartHTMLBinary}
procedure TMimeMess.AddPartHTMLBinary(Value, Cid: string); procedure TMimeMess.AddPartHTMLBinary(Value, Cid: string);
var var
x:integer; x: Integer;
s: string; s: string;
begin begin
x:=Addpart; x := AddPart;
with TMimePart(PartList[x]) do with TMimePart(PartList[x]) do
begin begin
DecodedLines.LoadFromFile(Value); DecodedLines.LoadFromFile(Value);
s:=ExtractFileName(value); s := ExtractFileName(Value);
MimeTypeFromExt(s); MimeTypeFromExt(s);
description:='Included file: '+s; Description := 'Included file: ' + s;
disposition:='inline'; Disposition := 'inline';
contentID:=cid; ContentID := cid;
filename:=s; FileName := s;
EncodingCode := ME_BASE64; EncodingCode := ME_BASE64;
EncodePart; EncodePart;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{TMimeMess.Encodemessage}
procedure TMimeMess.Encodemessage; procedure TMimeMess.EncodeMessage;
var var
bound: string; bound: string;
n:integer; n: Integer;
m:TMimepart;
begin begin
lines.clear; Lines.Clear;
If PartList.Count=1 if PartList.Count = 1 then
then Lines.Assign(TMimePart(PartList[0]).Lines)
Lines.assign(TMimePart(PartList[0]).lines)
else else
begin begin
bound:=generateboundary; bound := GenerateBoundary;
for n:=0 to PartList.count-1 do for n := 0 to PartList.Count - 1 do
begin begin
Lines.add('--'+bound); Lines.Add('--' + bound);
lines.AddStrings(TMimePart(PartList[n]).lines); Lines.AddStrings(TMimePart(PartList[n]).Lines);
end; end;
Lines.add('--'+bound); Lines.Add('--' + bound);
m:=TMimePart.Create; with TMimePart.Create do
try try
Lines.SaveToStream(m.DecodedLines); Self.Lines.SaveToStream(DecodedLines);
m.Primary:='Multipart'; Primary := 'Multipart';
m.secondary:='mixed'; Secondary := 'mixed';
m.description:='Multipart message'; Description := 'Multipart message';
m.boundary:=bound; Boundary := bound;
m.EncodePart; EncodePart;
Lines.assign(m.lines); Self.Lines.Assign(Lines);
finally finally
m.free; Free;
end; end;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{TMimeMess.FinalizeHeaders}
procedure TMimeMess.FinalizeHeaders; procedure TMimeMess.FinalizeHeaders;
var var
n:integer; n: Integer;
begin begin
Lines.Insert(0, 'x-mailer: Synapse - Delphi TCP/IP library by Lukas Gebauer'); 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, 'MIME-Version: 1.0 (produced by Synapse)');
Lines.Insert(0,'date: '+Rfc822DateTime(now)); Lines.Insert(0, 'date: ' + Rfc822DateTime(Now));
if header.organization<>'' if FHeader.Organization <> '' then
then Lines.Insert(0,'Organization: '+InlineCode(header.organization)); Lines.Insert(0, 'Organization: ' + InlineCode(Header.Organization));
if header.subject<>'' if Header.Subject <> '' then
then Lines.Insert(0,'Subject: '+InlineCode(header.subject)); FLines.Insert(0, 'Subject: ' + InlineCode(Header.Subject));
for n:=0 to Header.ToList.count-1 do for n := 0 to FHeader.ToList.Count - 1 do
Lines.Insert(0,'To: '+InlineEmail(header.ToList[n])); Lines.Insert(0, 'To: ' + InlineEmail(FHeader.ToList[n]));
Lines.Insert(0,'From: '+InlineEmail(header.from)); Lines.Insert(0, 'From: ' + InlineEmail(FHeader.From));
end; end;
{==============================================================================} {==============================================================================}
{TMimeMess.ParseHeaders}
procedure TMimeMess.ParseHeaders; procedure TMimeMess.ParseHeaders;
var var
s: string; s: string;
x:integer; x: Integer;
cp: TMimeChar; cp: TMimeChar;
begin begin
cp:=getCurCP; cp := GetCurCP;
header.ToList.clear; FHeader.Clear;
x := 0; x := 0;
while lines.count>x do while Lines.Count > x do
begin begin
s:=normalizeheader(lines,x); s := NormalizeHeader(Lines, x);
if s='' if s = '' then
then break; Break;
If pos('FROM:',uppercase(s))=1 if Pos('FROM:', UpperCase(s)) = 1 then
then header.from:=InlineDecode(separateright(s,':'),cp); FHeader.From := InlineDecode(SeparateRight(s, ':'), cp);
If pos('SUBJECT:',uppercase(s))=1 if Pos('SUBJECT:', UpperCase(s)) = 1 then
then header.subject:=InlineDecode(separateright(s,':'),cp); FHeader.Subject := InlineDecode(SeparateRight(s, ':'), cp);
If pos('ORGANIZATION:',uppercase(s))=1 if Pos('ORGANIZATION:', UpperCase(s)) = 1 then
then header.organization:=InlineDecode(separateright(s,':'),cp); FHeader.Organization := InlineDecode(SeparateRight(s, ':'), cp);
If pos('TO:',uppercase(s))=1 if Pos('TO:', UpperCase(s)) = 1 then
then header.ToList.add(InlineDecode(separateright(s,':'),cp)); FHeader.ToList.Add(InlineDecode(SeparateRight(s, ':'), cp));
end; end;
end; end;
{==============================================================================} {==============================================================================}
{TMimeMess.DecodeMessage}
procedure TMimeMess.DecodeMessage; procedure TMimeMess.DecodeMessage;
var var
l:tstringlist; l: TStringList;
m:tmimepart; m: TMimePart;
x,i:integer; x, i: Integer;
bound: string; bound: string;
begin begin
l:=tstringlist.create; l := TStringList.Create;
m:=tmimepart.create; m := TMimePart.Create;
try try
l.assign(lines); l.Assign(Lines);
with header do FHeader.Clear;
begin
from:='';
ToList.clear;
subject:='';
organization:='';
end;
ParseHeaders; ParseHeaders;
m.ExtractPart(l, 0); m.ExtractPart(l, 0);
if m.primarycode=MP_MULTIPART if m.PrimaryCode = MP_MULTIPART then
then
begin begin
bound:=m.boundary; bound := m.Boundary;
i := 0; i := 0;
repeat repeat
x := AddPart; x := AddPart;
with TMimePart(PartList[x]) do with TMimePart(PartList[x]) do
begin begin
boundary:=bound; Boundary := bound;
i := ExtractPart(l, i); i := ExtractPart(l, i);
DecodePart; DecodePart;
end; end;
until i>=l.count-2; until i >= l.Count - 2;
end end
else else
begin begin
@ -322,11 +344,9 @@ begin
end; end;
end; end;
finally finally
m.free; m.Free;
l.free; l.Free;
end; end;
end; 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 | | 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 | | (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/ |
| | | |
@ -28,57 +28,61 @@ unit MIMEpart;
interface interface
uses uses
sysutils, classes, MIMEchar, SynaCode, SynaUtil, MIMEinLn; SysUtils, Classes,
SynaChar, SynaCode, SynaUtil, MIMEinLn;
type type
TMimePrimary=(MP_TEXT, TMimePrimary = (MP_TEXT, MP_MULTIPART,
MP_MULTIPART, MP_MESSAGE, MP_BINARY);
MP_MESSAGE,
MP_BINARY);
TMimeEncoding=(ME_7BIT, TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE,
ME_8BIT, ME_BASE64, ME_UU, ME_XX);
ME_QUOTED_PRINTABLE,
ME_BASE64,
ME_UU,
ME_XX);
TMimePart=class TMimePart = class(TObject)
private private
FPrimary: string; FPrimary: string;
FEncoding: string; FEncoding: string;
FCharset: 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 SetEncoding(Value: string);
procedure SetCharset(Value: string); procedure SetCharset(Value: string);
protected
public 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; constructor Create;
destructor Destroy; override; destructor Destroy; override;
procedure clear; procedure Clear;
function ExtractPart(value:TStringList; BeginLine:integer):integer; function ExtractPart(Value: TStringList; BeginLine: Integer): Integer;
procedure DecodePart; procedure DecodePart;
procedure EncodePart; procedure EncodePart;
procedure MimeTypeFromExt(value:string); procedure MimeTypeFromExt(Value: string);
property published
Primary:string read FPrimary Write SetPrimary; property Primary: string read FPrimary write SetPrimary;
property property Encoding: string read FEncoding write SetEncoding;
encoding:string read FEncoding write SetEncoding; property Charset: string read FCharset write SetCharset;
property property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode;
Charset:string read FCharset write SetCharset; 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; end;
const const
@ -113,468 +117,443 @@ const
('ZIP', 'application', 'ZIP') ('ZIP', 'application', 'ZIP')
); );
function NormalizeHeader(value:TStringList;var index:integer):string; function NormalizeHeader(Value: TStringList; var Index: Integer): string;
function GenerateBoundary: string; function GenerateBoundary: string;
implementation implementation
function NormalizeHeader(value:TStringList;var index:integer):string; function NormalizeHeader(Value: TStringList; var Index: Integer): string;
var var
s, t: string; s, t: string;
n:integer; n: Integer;
begin begin
s:=value[index]; s := Value[Index];
inc(index); Inc(Index);
if s<>'' if s <> '' then
then while (Value.Count - 1) > Index do
while (value.Count-1) > index do
begin begin
t:=value[index]; t := Value[Index];
if t='' if t = '' then
then break; Break;
for n:=1 to length(t) do for n := 1 to Length(t) do
if t[n]=#9 if t[n] = #9 then
then t[n]:=' '; t[n] := ' ';
if t[1]<>' ' if t[1] <> ' ' then
then break Break
else else
begin begin
s:=s+' '+trim(t); s := s + ' ' + Trim(t);
inc(index); Inc(Index);
end; end;
end; end;
result:=s; Result := s;
end; end;
{==============================================================================} {==============================================================================}
{TMIMEPart.Create}
Constructor TMIMEPart.Create; constructor TMIMEPart.Create;
begin begin
inherited Create; inherited Create;
Lines:=TStringList.Create; FLines := TStringList.Create;
DecodedLines:=TmemoryStream.create; FDecodedLines := TMemoryStream.Create;
TargetCharset:=GetCurCP; FTargetCharset := GetCurCP;
end; end;
{TMIMEPart.Destroy} destructor TMIMEPart.Destroy;
Destructor TMIMEPart.Destroy;
begin begin
DecodedLines.free; FDecodedLines.Free;
Lines.free; FLines.Free;
inherited destroy; inherited Destroy;
end; end;
{==============================================================================} {==============================================================================}
{TMIMEPart.Clear}
procedure TMIMEPart.Clear; procedure TMIMEPart.Clear;
begin begin
FPrimary := ''; FPrimary := '';
FEncoding := ''; FEncoding := '';
FCharset := ''; FCharset := '';
PrimaryCode:=MP_TEXT; FPrimaryCode := MP_TEXT;
EncodingCode:=ME_7BIT; FEncodingCode := ME_7BIT;
CharsetCode:=ISO_8859_1; FCharsetCode := ISO_8859_1;
TargetCharset:=GetCurCP; FTargetCharset := GetCurCP;
secondary:=''; FSecondary := '';
disposition:=''; FDisposition := '';
contentID:=''; FContentID := '';
description:=''; FDescription := '';
boundary:=''; FBoundary := '';
FileName:=''; FFileName := '';
Lines.clear; FLines.Clear;
DecodedLines.clear; FDecodedLines.Clear;
end; end;
{==============================================================================} {==============================================================================}
{TMIMEPart.ExtractPart}
function TMIMEPart.ExtractPart(value:TStringList; BeginLine:integer):integer; function TMIMEPart.ExtractPart(Value: TStringList; BeginLine: Integer): Integer;
var var
n,x,x1,x2:integer; n, x, x1, x2: Integer;
t:tstringlist; t: TStringList;
s, su, b: string; s, su, b: string;
st, st2: string; st, st2: string;
e:boolean; e: Boolean;
fn: string; fn: string;
begin begin
t:=tstringlist.create; t := TStringlist.Create;
try try
{ defaults } { defaults }
lines.clear; FLines.Clear;
primary:='text'; Primary := 'text';
secondary:='plain'; FSecondary := 'plain';
description:=''; FDescription := '';
charset:='US-ASCII'; Charset := 'US-ASCII';
FileName:=''; FFileName := '';
encoding:='7BIT'; Encoding := '7BIT';
fn := ''; fn := '';
x:=beginline; x := BeginLine;
b:=boundary; b := FBoundary;
if b <> '' then if b <> '' then
while value.count>x do while Value.Count > x do
begin begin
s:=value[x]; s := Value[x];
inc(x); Inc(x);
if pos('--'+b,s)>0 if Pos('--' + b, s) > 0 then
then break; Break;
end; end;
{ parse header } { parse header }
while value.count>x do while Value.Count > x do
begin begin
s:=normalizeheader(value,x); s := NormalizeHeader(Value, x);
if s='' if s = '' then
then break; Break;
su:=uppercase(s); su := UpperCase(s);
if pos('CONTENT-TYPE:',su)=1 then if Pos('CONTENT-TYPE:', su) = 1 then
begin begin
st:=separateright(su,':'); st := SeparateRight(su, ':');
st2:=separateleft(st,';'); st2 := SeparateLeft(st, ';');
primary:=separateleft(st2,'/'); Primary := SeparateLeft(st2, '/');
secondary:=separateright(st2,'/'); FSecondary := SeparateRight(st2, '/');
if (secondary=primary) and (pos('/',st2)<1) if (FSecondary = Primary) and (Pos('/', st2) < 1) then FSecondary := '';
then secondary:=''; case FPrimaryCode of
case primarycode of
MP_TEXT: MP_TEXT:
begin Charset := UpperCase(GetParameter(s, 'charset='));
charset:=uppercase(getparameter(s,'charset='));
end;
MP_MULTIPART: MP_MULTIPART:
begin FBoundary := GetParameter(s, 'Boundary=');
boundary:=getparameter(s,'boundary=');
end;
MP_MESSAGE: MP_MESSAGE:
begin begin
end; end;
MP_BINARY: 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 begin
filename:=getparameter(s,'name='); FDisposition := SeparateRight(su, ':');
end; FDisposition := Trim(SeparateLeft(FDisposition, ';'));
end; fn := GetParameter(s, 'FileName=');
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,':');
end; end;
if Pos('CONTENT-ID:', su) = 1 then
FContentID := SeparateRight(s, ':');
end; end;
if (primarycode=MP_BINARY) and (filename='') if (PrimaryCode = MP_BINARY) and (FFileName = '') then
then filename:=fn; FFileName := fn;
filename:=InlineDecode(filename,getCurCP); FFileName := InlineDecode(FFileName, getCurCP);
filename:=extractfilename(filename); FFileName := ExtractFileName(FFileName);
x1 := x; x1 := x;
x2:=value.count-1; x2 := Value.Count - 1;
if b <> '' then if b <> '' then
begin begin
for n:=x to value.count-1 do for n := x to Value.Count - 1 do
begin begin
x2 := n; x2 := n;
s:=value[n]; s := Value[n];
if pos('--'+b,s)>0 if Pos('--' + b, s) > 0 then
then begin
dec(x2);
break;
end;
end;
end;
if primarycode=MP_MULTIPART then
begin begin
for n:=x to value.count-1 do Dec(x2);
Break;
end;
end;
end;
if FPrimaryCode = MP_MULTIPART then
begin begin
s:=value[n]; for n := x to Value.Count - 1 do
if pos('--'+boundary,s)>0 then begin
s := Value[n];
if Pos('--' + Boundary, s) > 0 then
begin begin
x1 := n; x1 := n;
break; Break;
end; end;
end; end;
for n:=value.count-1 downto x do for n := Value.Count - 1 downto x do
begin begin
s:=value[n]; s := Value[n];
if pos('--'+boundary,s)>0 then if Pos('--' + Boundary, s) > 0 then
begin begin
x2 := n; x2 := n;
break; Break;
end; end;
end; end;
end; end;
for n := x1 to x2 do for n := x1 to x2 do
lines.add(value[n]); FLines.Add(Value[n]);
result:=x2; Result := x2;
if primarycode=MP_MULTIPART then if FPrimaryCode = MP_MULTIPART then
begin begin
e:=false; e := False;
for n:=x2+1 to value.count-1 do for n := x2 + 1 to Value.Count - 1 do
if pos('--'+boundary,value[n])>0 then if Pos('--' + Boundary, Value[n]) > 0 then
begin begin
e:=true; e := True;
break; Break;
end; end;
if not e if not e then
then result:=value.count-1; Result := Value.Count - 1;
end; end;
finally finally
t.free; t.Free;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{TMIMEPart.DecodePart}
procedure TMIMEPart.DecodePart; procedure TMIMEPart.DecodePart;
const const
CRLF=#$0D+#$0A; CRLF = #13#10;
var var
n:integer; n: Integer;
s: string; s: string;
begin begin
decodedLines.Clear; FDecodedLines.Clear;
for n:=0 to lines.count-1 do for n := 0 to FLines.Count - 1 do
begin begin
s:=lines[n]; s := FLines[n];
case EncodingCode of case FEncodingCode of
ME_7BIT: ME_7BIT:
begin
s := s + CRLF; s := s + CRLF;
end;
ME_8BIT: ME_8BIT:
begin begin
s:=decodeChar(s,CharsetCode,TargetCharset); s := CharsetConversion(s, FCharsetCode, FTargetCharset);
s := s + CRLF; s := s + CRLF;
end; end;
ME_QUOTED_PRINTABLE: ME_QUOTED_PRINTABLE:
begin begin
if s='' if s = '' then
then s:=CRLF s := CRLF
else else
if s[length(s)]<>'=' if s[Length(s)] <> '=' then
then s:=s+CRLF; s := s + CRLF;
s := DecodeQuotedPrintable(s); s := DecodeQuotedPrintable(s);
if PrimaryCode=MP_TEXT if FPrimaryCode = MP_TEXT then
then s:=decodeChar(s,CharsetCode,TargetCharset); s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end; end;
ME_BASE64: ME_BASE64:
begin begin
if s<>'' if s <> '' then
then s:=DecodeBase64(s); s := DecodeBase64(s);
if PrimaryCode=MP_TEXT if FPrimaryCode = MP_TEXT then
then s:=decodeChar(s,CharsetCode,TargetCharset); s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end; end;
ME_UU: ME_UU:
begin if s <> '' then
if s<>'' s := DecodeUU(s);
then s:=DecodeUU(s);
end;
ME_XX: ME_XX:
begin if s <> '' then
if s<>'' s := DecodeXX(s);
then s:=DecodeXX(s);
end; end;
FDecodedLines.Write(Pointer(s)^, Length(s));
end; end;
Decodedlines.Write(pointer(s)^,length(s)); FDecodedLines.Seek(0, soFromBeginning);
end;
decodedlines.Seek(0,soFromBeginning);
end; end;
{==============================================================================} {==============================================================================}
{TMIMEPart.EncodePart}
procedure TMIMEPart.EncodePart; procedure TMIMEPart.EncodePart;
var var
l: TStringList; l: TStringList;
s, buff: string; s, buff: string;
n,x:integer; n, x: Integer;
begin begin
if EncodingCode=ME_UU if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
then encoding:='base64'; Encoding := 'base64';
if EncodingCode=ME_XX l := TStringList.Create;
then encoding:='base64'; FLines.Clear;
l:=tstringlist.create; FDecodedLines.Seek(0, soFromBeginning);
Lines.clear;
decodedlines.Seek(0,soFromBeginning);
try try
case primarycode of case FPrimaryCode of
MP_MULTIPART, MP_MULTIPART, MP_MESSAGE:
MP_MESSAGE: FLines.LoadFromStream(FDecodedLines);
MP_TEXT, MP_BINARY:
if FEncodingCode = ME_BASE64 then
begin begin
lines.LoadFromStream(DecodedLines); while FDecodedLines.Position < FDecodedLines.Size do
end;
MP_TEXT,
MP_BINARY:
if EncodingCode=ME_BASE64
then
begin
while decodedlines.Position<decodedlines.Size do
begin begin
Setlength(Buff, 54); Setlength(Buff, 54);
s := ''; s := '';
x:=Decodedlines.Read(pointer(Buff)^,54); x := FDecodedLines.Read(pointer(Buff)^, 54);
for n := 1 to x do for n := 1 to x do
s := s + Buff[n]; s := s + Buff[n];
if PrimaryCode=MP_TEXT if FPrimaryCode = MP_TEXT then
then s:=decodeChar(s,TargetCharset,CharsetCode); s := CharsetConversion(s, FTargetCharset, FCharsetCode);
s := EncodeBase64(s); s := EncodeBase64(s);
if x<>54 if x <> 54 then
then s:=s+'='; s := s + '=';
Lines.add(s); FLines.Add(s);
end; end;
end end
else else
begin begin
l.LoadFromStream(DecodedLines); l.LoadFromStream(FDecodedLines);
for n:=0 to l.count-1 do for n := 0 to l.Count - 1 do
begin begin
s := l[n]; s := l[n];
if PrimaryCode=MP_TEXT if FPrimaryCode = MP_TEXT then
then s:=decodeChar(s,TargetCharset,CharsetCode); s := CharsetConversion(s, FTargetCharset, FCharsetCode);
s := EncodeQuotedPrintable(s); s := EncodeQuotedPrintable(s);
Lines.add(s); FLines.Add(s);
end; end;
end; end;
end; end;
Lines.add(''); FLines.Add('');
lines.insert(0,''); FLines.Insert(0, '');
if secondary='' then if FSecondary = '' then
case PrimaryCode of case FPrimaryCode of
MP_TEXT: secondary:='plain'; MP_TEXT:
MP_MULTIPART: secondary:='mixed'; FSecondary := 'plain';
MP_MESSAGE: secondary:='rfc822'; MP_MULTIPART:
MP_BINARY: secondary:='octet-stream'; FSecondary := 'mixed';
MP_MESSAGE:
FSecondary := 'rfc822';
MP_BINARY:
FSecondary := 'octet-stream';
end; end;
if description<>'' if FDescription <> '' then
then lines.insert(0,'Content-Description: '+Description); FLines.Insert(0, 'Content-Description: ' + FDescription);
if disposition<>'' then if FDisposition <> '' then
begin begin
s := ''; s := '';
if filename<>'' if FFileName <> '' then
then s:='; filename="'+filename+'"'; s := '; FileName="' + FFileName + '"';
lines.insert(0,'Content-Disposition: '+lowercase(disposition)+s); FLines.Insert(0, 'Content-Disposition: ' + LowerCase(FDisposition) + s);
end; end;
if contentID<>'' if FContentID <> '' then
then lines.insert(0,'Content-ID: '+contentID); FLines.Insert(0, 'Content-ID: ' + FContentID);
case EncodingCode of case FEncodingCode of
ME_7BIT: s:='7bit'; ME_7BIT:
ME_8BIT: s:='8bit'; s := '7bit';
ME_QUOTED_PRINTABLE: s:='Quoted-printable'; ME_8BIT:
ME_BASE64: s:='Base64'; s := '8bit';
ME_QUOTED_PRINTABLE:
s := 'Quoted-printable';
ME_BASE64:
s := 'Base64';
end; end;
case PrimaryCode of case FPrimaryCode of
MP_TEXT, MP_TEXT,
MP_BINARY: lines.insert(0,'Content-Transfer-Encoding: '+s); MP_BINARY: FLines.Insert(0, 'Content-Transfer-Encoding: ' + s);
end; end;
case PrimaryCode of case FPrimaryCode of
MP_TEXT: s:=primary+'/'+secondary+'; charset='+GetIDfromCP(charsetcode); MP_TEXT:
MP_MULTIPART: s:=primary+'/'+secondary+'; boundary="'+boundary+'"'; s := FPrimary + '/' + FSecondary + '; charset=' + GetIDfromCP(FCharsetCode);
MP_MESSAGE: s:=primary+'/'+secondary+''; MP_MULTIPART:
MP_BINARY: s:=primary+'/'+secondary+'; name="'+FileName+'"'; s := FPrimary + '/' + FSecondary + '; boundary="' + Boundary + '"';
MP_MESSAGE:
s := FPrimary + '/' + FSecondary + '';
MP_BINARY:
s := FPrimary + '/' + FSecondary + '; name="' + FFileName + '"';
end; end;
lines.insert(0,'Content-type: '+s); FLines.Insert(0, 'Content-type: ' + s);
finally finally
l.free; l.Free;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{TMIMEPart.MimeTypeFromExt}
procedure TMIMEPart.MimeTypeFromExt(value:string); procedure TMIMEPart.MimeTypeFromExt(Value: string);
var var
s: string; s: string;
n:integer; n: Integer;
begin begin
primary:=''; Primary := '';
secondary:=''; FSecondary := '';
s:=uppercase(extractfileext(value)); s := UpperCase(ExtractFileExt(Value));
if s='' if s = '' then
then s:=uppercase(value); s := UpperCase(Value);
s:=separateright(s,'.'); s := SeparateRight(s, '.');
for n := 0 to MaxMimeType do for n := 0 to MaxMimeType do
if MimeType[n, 0] = s then if MimeType[n, 0] = s then
begin begin
primary:=MimeType[n,1]; Primary := MimeType[n, 1];
secondary:=MimeType[n,2]; FSecondary := MimeType[n, 2];
break; Break;
end; end;
if primary='' if Primary = '' then
then primary:='application'; Primary := 'application';
if secondary='' if FSecondary = '' then
then secondary:='mixed'; FSecondary := 'mixed';
end; end;
{==============================================================================} {==============================================================================}
{TMIMEPart.Setprimary}
procedure TMIMEPart.Setprimary(Value:string); procedure TMIMEPart.SetPrimary(Value: string);
var var
s: string; s: string;
begin begin
Fprimary:=Value; FPrimary := Value;
s:=uppercase(Value); s := UpperCase(Value);
PrimaryCode:=MP_BINARY; FPrimaryCode := MP_BINARY;
if Pos('TEXT',s)=1 if Pos('TEXT', s) = 1 then
then PrimaryCode:=MP_TEXT; FPrimaryCode := MP_TEXT;
if Pos('MULTIPART',s)=1 if Pos('MULTIPART', s) = 1 then
then PrimaryCode:=MP_MULTIPART; FPrimaryCode := MP_MULTIPART;
if Pos('MESSAGE',s)=1 if Pos('MESSAGE', s) = 1 then
then PrimaryCode:=MP_MESSAGE; FPrimaryCode := MP_MESSAGE;
end; end;
{TMIMEPart.SetEncoding}
procedure TMIMEPart.SetEncoding(Value: string); procedure TMIMEPart.SetEncoding(Value: string);
var var
s: string; s: string;
begin begin
FEncoding := Value; FEncoding := Value;
s:=uppercase(Value); s := UpperCase(Value);
EncodingCode:=ME_7BIT; FEncodingCode := ME_7BIT;
if Pos('8BIT',s)=1 if Pos('8BIT', s) = 1 then
then EncodingCode:=ME_8BIT; FEncodingCode := ME_8BIT;
if Pos('QUOTED-PRINTABLE',s)=1 if Pos('QUOTED-PRINTABLE', s) = 1 then
then EncodingCode:=ME_QUOTED_PRINTABLE; FEncodingCode := ME_QUOTED_PRINTABLE;
if Pos('BASE64',s)=1 if Pos('BASE64', s) = 1 then
then EncodingCode:=ME_BASE64; FEncodingCode := ME_BASE64;
if Pos('X-UU',s)=1 if Pos('X-UU', s) = 1 then
then EncodingCode:=ME_UU; FEncodingCode := ME_UU;
if Pos('X-XX',s)=1 if Pos('X-XX', s) = 1 then
then EncodingCode:=ME_XX; FEncodingCode := ME_XX;
end; end;
{TMIMEPart.SetCharset}
procedure TMIMEPart.SetCharset(Value: string); procedure TMIMEPart.SetCharset(Value: string);
begin begin
FCharset := Value; FCharset := Value;
CharsetCode:=GetCPfromID(value); FCharsetCode := GetCPFromID(Value);
end; end;
{==============================================================================} {==============================================================================}
{GenerateBoundary}
function GenerateBoundary: string; function GenerateBoundary: string;
var var
x:integer; x: Integer;
begin begin
randomize; Randomize;
x:=random(maxint); x := Random(MaxInt);
result:='----'+Inttohex(x,8)+'_Synapse_message_boundary'; Result := '----' + IntToHex(x, 8) + '_Synapse_message_boundary';
end; end;
{==============================================================================}
begin
exit;
asm
db 'Synapse MIME messages encoding and decoding library by Lukas Gebauer',0
end;
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 | | 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 | | (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/ |
| | | |
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | 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. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -25,27 +25,12 @@
{ {
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
See 'winsock2.txt' file in distribute package!
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!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
} }
{$Q-} {$Q-}
{$WEAKPACKAGEUNIT ON}
unit PINGsend; unit PINGsend;
@ -53,159 +38,183 @@ interface
uses uses
{$IFDEF LINUX} {$IFDEF LINUX}
libc, Libc,
{$ELSE} {$ELSE}
windows, Windows,
{$ENDIF} {$ENDIF}
synsock, SysUtils, blcksck2, Synautil; SysUtils,
synsock, blcksock, SynaUtil;
const const
ICMP_ECHO = 8; ICMP_ECHO = 8;
ICMP_ECHOREPLY = 0; ICMP_ECHOREPLY = 0;
type type
TIcmpEchoHeader = record
TIcmpEchoHeader = Record
i_type: Byte; i_type: Byte;
i_code: Byte; i_code: Byte;
i_checkSum: Word; i_checkSum: Word;
i_Id: Word; i_Id: Word;
i_seq: Word; i_seq: Word;
TimeStamp : ULong; TimeStamp: ULONG;
End; end;
TPINGSend = class(TObject) TPINGSend = class(TObject)
private private
Sock:TICMPBlockSocket; FSock: TICMPBlockSocket;
Buffer:string; FBuffer: string;
seq:integer; FSeq: Integer;
id:integer; FId: Integer;
function checksum:integer; FTimeout: Integer;
function GetTick:cardinal; FPacketSize: Integer;
FPingTime: Integer;
function Checksum: Integer;
function GetTick: Cardinal;
function ReadPacket: Boolean;
public public
timeout:integer; function Ping(const Host: string): Boolean;
PacketSize:integer;
PingTime:integer;
function ping(host:string):Boolean;
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
published
property Timeout: Integer read FTimeout Write FTimeout;
property PacketSize: Integer read FPacketSize Write FPacketSize;
property PingTime: Integer read FPingTime;
end; end;
function PingHost(host:string):integer; function PingHost(const Host: string): Integer;
implementation implementation
{==============================================================================} {==============================================================================}
{TPINGSend.Create} constructor TPINGSend.Create;
Constructor TPINGSend.Create;
begin begin
inherited Create; inherited Create;
sock:=TICMPBlockSocket.create; FSock := TICMPBlockSocket.Create;
sock.CreateSocket; FSock.CreateSocket;
timeout:=5000; FTimeout := 5000;
packetsize:=32; FPacketSize := 32;
seq:=0; FSeq := 0;
Randomize;
end; end;
{TPINGSend.Destroy} destructor TPINGSend.Destroy;
Destructor TPINGSend.Destroy;
begin begin
Sock.free; FSock.Free;
inherited destroy; inherited Destroy;
end; end;
{TPINGSend.ping} function TPINGSend.ReadPacket: Boolean;
function TPINGSend.ping(host:string):Boolean;
var 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; IpHdrLen: Integer;
PIcmpEchoHeader:^TICMPEchoHeader; IcmpEchoHeaderPtr: ^TICMPEchoHeader;
n,x:integer; n: Integer;
t: Boolean;
begin begin
Result := False; Result := False;
sock.connect(host,'0'); FSock.Connect(Host, '0');
Buffer:=StringOfChar(#0,SizeOf(TICMPEchoHeader)+packetSize); FBuffer := StringOfChar(#0, SizeOf(TICMPEchoHeader) + FPacketSize);
PIcmpEchoHeader := Pointer(Buffer); IcmpEchoHeaderPtr := Pointer(FBuffer);
With PIcmpEchoHeader^ Do Begin with IcmpEchoHeaderPtr^ do
begin
i_type := ICMP_ECHO; i_type := ICMP_ECHO;
i_code := 0; i_code := 0;
i_CheckSum := 0; i_CheckSum := 0;
id:=Random(32767); FId := Random(32767);
i_Id:=id; i_Id := FId;
TimeStamp := GetTick; TimeStamp := GetTick;
Inc(Seq); Inc(FSeq);
i_Seq:=Seq; i_Seq := FSeq;
for n:=Succ(SizeOf(TicmpEchoHeader)) to Length(Buffer) do for n := Succ(SizeOf(TIcmpEchoHeader)) to Length(FBuffer) do
Buffer[n]:=#$55; FBuffer[n] := #$55;
i_CheckSum := CheckSum; i_CheckSum := CheckSum;
end; end;
sock.sendString(Buffer); FSock.SendString(FBuffer);
if sock.canread(timeout) repeat
then begin t := ReadPacket;
x:=sock.waitingdata; if not t then
setlength(Buffer,x); break;
sock.recvbuffer(Pointer(Buffer),x); IPHeadPtr := Pointer(FBuffer);
PIpHeader:=Pointer(Buffer); IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
IpHdrLen:=(PIpHeader^.VerLen and $0F)*4; IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
PIcmpEchoHeader:=@Buffer[IpHdrLen+1]; until IcmpEchoHeaderPtr^.i_type <> ICMP_ECHO;
if (PIcmpEchoHeader^.i_type=ICMP_ECHOREPLY) //it discard sometimes possible 'echoes' of previosly sended packet...
// Linux return from localhost ECHO instead ECHOREPLY??? if t then
or (PIcmpEchoHeader^.i_type=ICMP_ECHO) then if (IcmpEchoHeaderPtr^.i_type = ICMP_ECHOREPLY) then
if (PIcmpEchoHeader^.i_id=id) then if (IcmpEchoHeaderPtr^.i_id = FId) then
begin begin
PingTime:=GetTick-PIcmpEchoHeader^.TimeStamp; FPingTime := GetTick - IcmpEchoHeaderPtr^.TimeStamp;
Result := True; Result := True;
end; end;
end; end;
end;
{TPINGSend.checksum} function TPINGSend.Checksum: Integer;
function TPINGSend.checksum:integer;
type type
tWordArray=Array[0..0] Of Word; TWordArray = array[0..0] of Word;
var var
PWordArray:^TWordArray; WordArr: ^TWordArray;
CkSum:Dword; CkSum: DWORD;
Num, Remain: Integer; Num, Remain: Integer;
n: Integer; n: Integer;
begin begin
Num:=length(Buffer) div 2; Num := Length(FBuffer) div 2;
Remain:=length(Buffer) mod 2; Remain := Length(FBuffer) mod 2;
PWordArray:=Pointer(Buffer); WordArr := Pointer(FBuffer);
CkSum := 0; CkSum := 0;
for n := 0 to Num - 1 do for n := 0 to Num - 1 do
CkSum:=CkSum+PWordArray^[n]; CkSum := CkSum + WordArr^[n];
if Remain <> 0 then 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 shr 16) + (CkSum and $FFFF);
CkSum := CkSum + (CkSum shr 16); CkSum := CkSum + (CkSum shr 16);
Result := Word(not CkSum); Result := Word(not CkSum);
end; end;
{TPINGSend.GetTick}
function TPINGSend.GetTick:cardinal;
begin
{$IFDEF LINUX} {$IFDEF LINUX}
result:=clock div (CLOCKS_PER_SEC div 1000);
{$ELSE} function TPINGSend.GetTick: Cardinal;
result:=windows.GetTickCount; var
{$ENDIF} Stamp: TTimeStamp;
begin
Stamp := DateTimeToTimeStamp(Now);
Result := Stamp.Time;
end; end;
{$ELSE}
function TPINGSend.GetTick: Cardinal;
begin
Result := Windows.GetTickCount;
end;
{$ENDIF}
{==============================================================================} {==============================================================================}
function PingHost(host:string):integer; function PingHost(const Host: string): Integer;
var
ping:TPINGSend;
begin begin
ping:=TPINGSend.Create; with TPINGSend.Create do
try try
if ping.ping(host) if Ping(Host) then
then Result:=ping.pingtime Result := PingTime
else Result:=-1; else
Result := -1;
finally finally
ping.Free; Free;
end; end;
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 | | 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 | | (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/ |
| | | |
@ -23,252 +23,239 @@
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit POP3send; unit POP3send;
interface interface
uses uses
Blcksock, sysutils, classes, SynaUtil, SynaCode; SysUtils, Classes,
blcksock, SynaUtil, SynaCode;
const const
CRLF=#13+#10; cPop3Protocol = 'pop3';
type type
TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP); TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
TPOP3Send = class TPOP3Send = class(TObject)
private private
Sock:TTCPBlockSocket; FSock: TTCPBlockSocket;
function ReadResult(full:boolean):integer; FTimeout: Integer;
FPOP3Host: string;
FPOP3Port: string;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
FUsername: string;
FPassword: string;
FStatCount: Integer;
FStatSize: Integer;
FTimeStamp: string;
FAuthType: TPOP3AuthType;
function ReadResult(Full: Boolean): Integer;
function Connect: Boolean; function 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 AuthLogin: Boolean;
function AuthApop: Boolean; function AuthApop: Boolean;
function login:Boolean; public
procedure logout; constructor Create;
function reset:Boolean; destructor Destroy; override;
function noop:Boolean; function Login: Boolean;
function stat:Boolean; procedure Logout;
function list(value:integer):Boolean; function Reset: Boolean;
function retr(value:integer):Boolean; function NoOp: Boolean;
function dele(value:integer):Boolean; function Stat: Boolean;
function top(value,maxlines:integer):Boolean; function List(Value: Integer): Boolean;
function uidl(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; end;
implementation implementation
{TPOP3Send.Create} const
Constructor TPOP3Send.Create; CRLF = #13#10;
constructor TPOP3Send.Create;
begin begin
inherited Create; inherited Create;
FullResult:=TStringList.create; FFullResult := TStringList.Create;
sock:=TTCPBlockSocket.create; FSock := TTCPBlockSocket.Create;
sock.CreateSocket; FSock.CreateSocket;
timeout:=300000; FTimeout := 300000;
POP3host:='localhost'; FPOP3host := cLocalhost;
POP3Port:='pop3'; FPOP3Port := cPop3Protocol;
Username:=''; FUsername := '';
Password:=''; FPassword := '';
StatCount:=0; FStatCount := 0;
StatSize:=0; FStatSize := 0;
AuthType:=POP3AuthAll; FAuthType := POP3AuthAll;
end; end;
{TPOP3Send.Destroy} destructor TPOP3Send.Destroy;
Destructor TPOP3Send.Destroy;
begin begin
Sock.free; FSock.Free;
FullResult.free; FullResult.Free;
inherited destroy; inherited Destroy;
end; end;
{TPOP3Send.ReadResult} function TPOP3Send.ReadResult(Full: Boolean): Integer;
function TPOP3Send.ReadResult(full:boolean):integer;
var var
s: string; s: string;
begin begin
Result := 0; Result := 0;
FullResult.Clear; FFullResult.Clear;
s:=sock.recvstring(timeout); s := FSock.RecvString(FTimeout);
if pos('+OK',s)=1 if Pos('+OK', s) = 1 then
then result:=1; Result := 1;
ResultString:=s; FResultString := s;
if full and (result=1)then if Full and (Result = 1) then
repeat repeat
s:=sock.recvstring(timeout); s := FSock.RecvString(FTimeout);
if s='.' if s = '.' then
then break; Break;
FullResult.add(s); FFullResult.Add(s);
until sock.LastError<>0; until FSock.LastError <> 0;
ResultCode:=Result; FResultCode := Result;
end; end;
{TPOP3Send.AuthLogin}
function TPOP3Send.AuthLogin: Boolean; function TPOP3Send.AuthLogin: Boolean;
begin begin
Result:=false; Result := False;
Sock.SendString('USER '+username+CRLF); FSock.SendString('USER ' + FUserName + CRLF);
if readresult(false)<>1 then Exit; if ReadResult(False) <> 1 then
Sock.SendString('PASS '+password+CRLF); Exit;
if readresult(false)<>1 then Exit; FSock.SendString('PASS ' + FPassword + CRLF);
Result:=True; Result := ReadResult(False) = 1;
end; end;
{TPOP3Send.AuthAPop}
function TPOP3Send.AuthAPOP: Boolean; function TPOP3Send.AuthAPOP: Boolean;
var var
s: string; s: string;
begin begin
Result:=false; s := StrToHex(MD5(FTimeStamp + FPassWord));
s:=StrToHex(MD5(TimeStamp+PassWord)); FSock.SendString('APOP ' + FUserName + ' ' + s + CRLF);
Sock.SendString('APOP '+username+' '+s+CRLF); Result := ReadResult(False) = 1;
if readresult(false)<>1 then Exit;
Result:=True;
end; end;
{TPOP3Send.Connect}
function TPOP3Send.Connect: Boolean; function TPOP3Send.Connect: Boolean;
begin begin
// Do not call this function! It is calling by LOGIN method! // Do not call this function! It is calling by LOGIN method!
Result:=false; FStatCount := 0;
StatCount:=0; FStatSize := 0;
StatSize:=0; FSock.CloseSocket;
sock.CloseSocket; FSock.LineBuffer := '';
sock.LineBuffer:=''; FSock.CreateSocket;
sock.CreateSocket; FSock.Connect(POP3Host, POP3Port);
sock.Connect(POP3Host,POP3Port); Result := FSock.LastError = 0;
if sock.lasterror<>0 then Exit;
Result:=True;
end; end;
{TPOP3Send.login} function TPOP3Send.Login: Boolean;
function TPOP3Send.login:Boolean;
var var
s, s1: string; s, s1: string;
begin begin
Result := False; Result := False;
TimeStamp:=''; FTimeStamp := '';
if not Connect then Exit; if not Connect then
if readresult(false)<>1 then Exit; Exit;
s:=separateright(Resultstring,'<'); if ReadResult(False) <> 1 then
if s<>Resultstring then Exit;
s := SeparateRight(FResultString, '<');
if s <> FResultString then
begin begin
s1:=separateleft(s,'>'); s1 := SeparateLeft(s, '>');
if s1<>s if s1 <> s then
then TimeStamp:='<'+s1+'>'; FTimeStamp := '<' + s1 + '>';
end; end;
result:=false; Result := False;
if (TimeStamp<>'') and not(AuthType=POP3AuthLogin) if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
then result:=AuthApop; Result := AuthApop;
if not(Result) and not(AuthType=POP3AuthAPOP) if not Result and not (FAuthType = POP3AuthAPOP) then
then result:=AuthLogin; Result := AuthLogin;
end; end;
{TPOP3Send.logout} procedure TPOP3Send.Logout;
procedure TPOP3Send.logout;
begin begin
Sock.SendString('QUIT'+CRLF); FSock.SendString('QUIT' + CRLF);
readresult(false); ReadResult(False);
Sock.CloseSocket; FSock.CloseSocket;
end; end;
{TPOP3Send.reset} function TPOP3Send.Reset: Boolean;
function TPOP3Send.reset:Boolean;
begin begin
Result:=false; FSock.SendString('RSET' + CRLF);
Sock.SendString('RSET'+CRLF); Result := ReadResult(False) = 1;
if readresult(false)<>1 then Exit;
Result:=True;
end; end;
{TPOP3Send.noop} function TPOP3Send.NoOp: Boolean;
function TPOP3Send.noop:Boolean;
begin begin
Result:=false; FSock.SendString('NOOP' + CRLF);
Sock.SendString('NOOP'+CRLF); Result := ReadResult(False) = 1;
if readresult(false)<>1 then Exit;
Result:=True;
end; end;
{TPOP3Send.stat} function TPOP3Send.Stat: Boolean;
function TPOP3Send.stat:Boolean;
var var
s: string; s: string;
begin begin
Result:=false; Result := False;
Sock.SendString('STAT'+CRLF); FSock.SendString('STAT' + CRLF);
if readresult(false)<>1 then Exit; if ReadResult(False) <> 1 then
s:=separateright(ResultString,'+OK '); Exit;
StatCount:=StrToIntDef(separateleft(s,' '),0); s := SeparateRight(ResultString, '+OK ');
StatSize:=StrToIntDef(separateright(s,' '),0); FStatCount := StrToIntDef(SeparateLeft(s, ' '), 0);
FStatSize := StrToIntDef(SeparateRight(s, ' '), 0);
Result := True; Result := True;
end; end;
{TPOP3Send.list} function TPOP3Send.List(Value: Integer): Boolean;
function TPOP3Send.list(value:integer):Boolean;
begin begin
Result:=false; if Value = 0 then
if value=0 FSock.SendString('LIST' + CRLF)
then Sock.SendString('LIST'+CRLF) else
else Sock.SendString('LIST '+IntToStr(value)+CRLF); FSock.SendString('LIST ' + IntToStr(Value) + CRLF);
if readresult(value=0)<>1 then Exit; Result := ReadResult(Value = 0) = 1;
Result:=True;
end; end;
{TPOP3Send.retr} function TPOP3Send.Retr(Value: Integer): Boolean;
function TPOP3Send.retr(value:integer):Boolean;
begin begin
Result:=false; FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
Sock.SendString('RETR '+IntToStr(value)+CRLF); Result := ReadResult(True) = 1;
if readresult(true)<>1 then Exit;
Result:=True;
end; end;
{TPOP3Send.dele} function TPOP3Send.Dele(Value: Integer): Boolean;
function TPOP3Send.dele(value:integer):Boolean;
begin begin
Result:=false; FSock.SendString('DELE ' + IntToStr(Value) + CRLF);
Sock.SendString('DELE '+IntToStr(value)+CRLF); Result := ReadResult(False) = 1;
if readresult(false)<>1 then Exit;
Result:=True;
end; end;
{TPOP3Send.top} function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
function TPOP3Send.top(value,maxlines:integer):Boolean;
begin begin
Result:=false; FSock.SendString('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines) + CRLF);
Sock.SendString('TOP '+IntToStr(value)+' '+IntToStr(maxlines)+CRLF); Result := ReadResult(True) = 1;
if readresult(true)<>1 then Exit;
Result:=True;
end; end;
{TPOP3Send.uidl} function TPOP3Send.Uidl(Value: Integer): Boolean;
function TPOP3Send.uidl(value:integer):Boolean;
begin begin
Result:=false; if Value = 0 then
if value=0 FSock.SendString('UIDL' + CRLF)
then Sock.SendString('UIDL'+CRLF) else
else Sock.SendString('UIDL '+IntToStr(value)+CRLF); FSock.SendString('UIDL ' + IntToStr(Value) + CRLF);
if readresult(value=0)<>1 then Exit; Result := ReadResult(Value = 0) = 1;
Result:=True;
end; end;
{==============================================================================}
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 | | 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 | | (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, | | 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 | | 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/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit SMTPsend; unit SMTPsend;
interface interface
uses uses
Blcksock, sysutils, classes, SynaUtil, SynaCode; SysUtils, Classes,
blcksock, SynaUtil, SynaCode;
const const
CRLF=#13+#10; cSmtpProtocol = 'smtp';
type type
TSMTPSend = class TSMTPSend = class(TObject)
private private
Sock:TTCPBlockSocket; FSock: TTCPBlockSocket;
procedure EnhancedCode(value:string); FTimeout: Integer;
function ReadResult:integer; FSMTPHost: string;
public FSMTPPort: string;
timeout:integer; FResultCode: Integer;
SMTPHost:string; FResultString: string;
SMTPPort:string; FFullResult: TStringList;
ResultCode:integer; FESMTPcap: TStringList;
ResultString:string; FESMTP: Boolean;
FullResult:TStringList; FUsername: string;
ESMTPcap:TStringList; FPassword: string;
ESMTP:boolean; FAuthDone: Boolean;
Username:string; FESMTPSize: Boolean;
Password:string; FMaxSize: Integer;
AuthDone:boolean; FEnhCode1: Integer;
ESMTPSize:boolean; FEnhCode2: Integer;
MaxSize:integer; FEnhCode3: Integer;
EnhCode1:integer; FSystemName: string;
EnhCode2:integer; procedure EnhancedCode(const Value: string);
EnhCode3:integer; function ReadResult: Integer;
SystemName:string;
Constructor Create;
Destructor Destroy; override;
function AuthLogin: Boolean; function AuthLogin: Boolean;
function AuthCram: Boolean; function AuthCram: Boolean;
function Connect:Boolean;
function Helo: Boolean; function Helo: Boolean;
function Ehlo: Boolean; function Ehlo: Boolean;
function login:Boolean; function Connect: Boolean;
procedure logout; public
function reset:Boolean; constructor Create;
function noop:Boolean; destructor Destroy; override;
function mailfrom(Value:string; size:integer):Boolean; function Login: Boolean;
function mailto(Value:string):Boolean; procedure Logout;
function maildata(Value:Tstrings):Boolean; function Reset: Boolean;
function etrn(Value:string):Boolean; function NoOp: Boolean;
function verify(Value:string):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 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; end;
function SendtoRaw function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
(mailfrom,mailto,SMTPHost:string;maildata:TStrings;Username,Password:string):Boolean; const MailData: TStrings; const Username, Password: string): Boolean;
function Sendto function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
(mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings):Boolean; const MailData: TStrings): Boolean;
function SendtoEx function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
(mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings;Username,Password:string):Boolean; const MailData: TStrings; const Username, Password: string): Boolean;
implementation implementation
{TSMTPSend.Create} const
Constructor TSMTPSend.Create; CRLF = #13#10;
constructor TSMTPSend.Create;
begin begin
inherited Create; inherited Create;
FullResult:=TStringList.create; FFullResult := TStringList.Create;
ESMTPcap:=TStringList.create; FESMTPcap := TStringList.Create;
sock:=TTCPBlockSocket.create; FSock := TTCPBlockSocket.Create;
sock.CreateSocket; FSock.CreateSocket;
timeout:=300000; FTimeout := 300000;
SMTPhost:='localhost'; FSMTPhost := cLocalhost;
SMTPPort:='smtp'; FSMTPPort := cSmtpProtocol;
Username:=''; FUsername := '';
Password:=''; FPassword := '';
SystemName:=sock.localname; FSystemName := FSock.LocalName;
end; end;
{TSMTPSend.Destroy} destructor TSMTPSend.Destroy;
Destructor TSMTPSend.Destroy;
begin begin
Sock.free; FSock.Free;
ESMTPcap.free; FESMTPcap.Free;
FullResult.free; FFullResult.Free;
inherited destroy; inherited Destroy;
end; end;
{TSMTPSend.EnhancedCode} procedure TSMTPSend.EnhancedCode(const Value: string);
procedure TSMTPSend.EnhancedCode (value:string);
var var
s, t: string; s, t: string;
e1,e2,e3:integer; e1, e2, e3: Integer;
begin begin
EnhCode1:=0; FEnhCode1 := 0;
EnhCode2:=0; FEnhCode2 := 0;
EnhCode3:=0; FEnhCode3 := 0;
s:=copy(value,5,length(value)-4); s := Copy(Value, 5, Length(Value) - 4);
t:=separateleft(s,'.'); t := SeparateLeft(s, '.');
s:=separateright(s,'.'); s := SeparateRight(s, '.');
if t='' then exit; if t = '' then
if length(t)>1 then exit; Exit;
e1:=strtointdef(t,0); if Length(t) > 1 then
if e1=0 then exit; Exit;
t:=separateleft(s,'.'); e1 := StrToIntDef(t, 0);
s:=separateright(s,'.'); if e1 = 0 then
if t='' then exit; Exit;
if length(t)>3 then exit; t := SeparateLeft(s, '.');
e2:=strtointdef(t,0); s := SeparateRight(s, '.');
t:=separateleft(s,' '); if t = '' then
if t='' then exit; Exit;
if length(t)>3 then exit; if Length(t) > 3 then
e3:=strtointdef(t,0); Exit;
EnhCode1:=e1; e2 := StrToIntDef(t, 0);
EnhCode2:=e2; t := SeparateLeft(s, ' ');
EnhCode3:=e3; if t = '' then
Exit;
if Length(t) > 3 then
Exit;
e3 := StrToIntDef(t, 0);
FEnhCode1 := e1;
FEnhCode2 := e2;
FEnhCode3 := e3;
end; end;
{TSMTPSend.ReadResult} function TSMTPSend.ReadResult: Integer;
function TSMTPSend.ReadResult:integer;
var var
s: string; s: string;
begin begin
Result := 0; Result := 0;
FullResult.Clear; FFullResult.Clear;
repeat repeat
s:=sock.recvstring(timeout); s := FSock.RecvString(FTimeout);
ResultString:=s; FResultString := s;
FullResult.add(s); FFullResult.Add(s);
if sock.LastError<>0 then if FSock.LastError <> 0 then
break; Break;
until pos('-',s)<>4; until Pos('-', s) <> 4;
s:=FullResult[0]; s := FFullResult[0];
if Length(s)>=3 then Result:=Strtointdef(Copy(s,1,3),0); if Length(s) >= 3 then
ResultCode:=Result; Result := StrToIntDef(Copy(s, 1, 3), 0);
FResultCode := Result;
EnhancedCode(s); EnhancedCode(s);
end; end;
{TSMTPSend.AuthLogin}
function TSMTPSend.AuthLogin: Boolean; function TSMTPSend.AuthLogin: Boolean;
begin begin
Result:=false; Result := False;
Sock.SendString('AUTH LOGIN'+CRLF); FSock.SendString('AUTH LOGIN' + CRLF);
if readresult<>334 then Exit; if ReadResult <> 334 then
Sock.SendString(Encodebase64(username)+CRLF); Exit;
if readresult<>334 then Exit; FSock.SendString(EncodeBase64(FUsername) + CRLF);
Sock.SendString(Encodebase64(password)+CRLF); if ReadResult <> 334 then
if readresult<>235 then Exit; Exit;
Result:=True; FSock.SendString(EncodeBase64(FPassword) + CRLF);
Result := ReadResult = 235;
end; end;
{TSMTPSend.AuthCram}
function TSMTPSend.AuthCram: Boolean; function TSMTPSend.AuthCram: Boolean;
var var
s: string; s: string;
begin begin
Result:=false; Result := False;
Sock.SendString('AUTH CRAM-MD5'+CRLF); FSock.SendString('AUTH CRAM-MD5' + CRLF);
if readresult<>334 then Exit; if ReadResult <> 334 then
s:=copy(ResultString,5,length(ResultString)-4); Exit;
s := Copy(FResultString, 5, Length(FResultString) - 4);
s := DecodeBase64(s); s := DecodeBase64(s);
s:=HMAC_MD5(s,password); s := HMAC_MD5(s, FPassword);
s:=Username+' '+strtohex(s); s := FUsername + ' ' + StrToHex(s);
Sock.SendString(Encodebase64(s)+CRLF); FSock.SendString(EncodeBase64(s) + CRLF);
if readresult<>235 then Exit; Result := ReadResult = 235;
Result:=True;
end; end;
{TSMTPSend.Connect}
function TSMTPSend.Connect: Boolean; function TSMTPSend.Connect: Boolean;
begin begin
Result:=false; FSock.CloseSocket;
sock.CloseSocket; FSock.CreateSocket;
sock.CreateSocket; FSock.Connect(FSMTPHost, FSMTPPort);
sock.Connect(SMTPHost,SMTPPort); Result := FSock.LastError = 0;
if sock.lasterror<>0 then Exit;
Result:=True;
end; end;
{TSMTPSend.Helo}
function TSMTPSend.Helo: Boolean; function TSMTPSend.Helo: Boolean;
var var
x:integer; x: Integer;
begin begin
Result:=false; FSock.SendString('HELO ' + FSystemName + CRLF);
Sock.SendString('HELO '+SystemName+CRLF);
x := ReadResult; x := ReadResult;
if (x<250) or (x>259) then Exit; Result := (x >= 250) and (x <= 259);
Result:=True;
end; end;
{TSMTPSend.Ehlo}
function TSMTPSend.Ehlo: Boolean; function TSMTPSend.Ehlo: Boolean;
var var
x:integer; x: Integer;
begin begin
Result:=false; FSock.SendString('EHLO ' + FSystemName + CRLF);
Sock.SendString('EHLO '+SystemName+CRLF);
x := ReadResult; x := ReadResult;
if (x<250) or (x>259) then Exit; Result := (x >= 250) and (x <= 259);
Result:=True;
end; end;
{TSMTPSend.login} function TSMTPSend.Login: Boolean;
function TSMTPSend.login:Boolean;
var var
n:integer; n: Integer;
auths: string; auths: string;
s: string; s: string;
begin begin
Result := False; Result := False;
ESMTP:=true; FESMTP := True;
AuthDone:=false; FAuthDone := False;
ESMTPcap.clear; FESMTPcap.clear;
ESMTPSize:=false; FESMTPSize := False;
MaxSize:=0; FMaxSize := 0;
if not Connect then Exit; if not Connect then
if readresult<>220 then Exit; Exit;
if ReadResult <> 220 then
Exit;
if not Ehlo then if not Ehlo then
begin begin
ESMTP:=false; FESMTP := False;
if not Helo then exit; if not Helo then
Exit;
end; end;
Result := True; Result := True;
if ESMTP then if FESMTP then
begin begin
for n:=1 to FullResult.count-1 do for n := 1 to FFullResult.Count - 1 do
ESMTPcap.add(Copy(FullResult[n],5,length(Fullresult[n])-4)); FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
if not ((Username='') and (Password='')) then if not ((FUsername = '') and (FPassword = '')) then
begin begin
s := FindCap('AUTH '); s := FindCap('AUTH ');
if s='' if s = '' then
then s:=FindCap('AUTH='); s := FindCap('AUTH=');
auths:=uppercase(s); auths := UpperCase(s);
if s <> '' then if s <> '' then
begin begin
if pos('CRAM-MD5',auths)>0 if Pos('CRAM-MD5', auths) > 0 then
then AuthDone:=AuthCram; FAuthDone := AuthCram;
if (pos('LOGIN',auths)>0) and (not authDone) if (Pos('LOGIN', auths) > 0) and (not FauthDone) then
then AuthDone:=AuthLogin; FAuthDone := AuthLogin;
end; end;
if AuthDone if FAuthDone then
then Ehlo; Ehlo;
end; end;
s := FindCap('SIZE'); s := FindCap('SIZE');
if s <> '' then if s <> '' then
begin begin
ESMTPsize:=true; FESMTPsize := True;
MaxSize:=StrToIntDef(copy(s,6,length(s)-5),0); FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0);
end; end;
end; end;
end; end;
{TSMTPSend.logout} procedure TSMTPSend.Logout;
procedure TSMTPSend.logout;
begin begin
Sock.SendString('QUIT'+CRLF); FSock.SendString('QUIT' + CRLF);
readresult; ReadResult;
Sock.CloseSocket; FSock.CloseSocket;
end; end;
{TSMTPSend.reset} function TSMTPSend.Reset: Boolean;
function TSMTPSend.reset:Boolean;
begin begin
Result:=false; FSock.SendString('RSET' + CRLF);
Sock.SendString('RSET'+CRLF); Result := ReadResult = 250;
if readresult<>250 then Exit;
Result:=True;
end; end;
{TSMTPSend.noop} function TSMTPSend.NoOp: Boolean;
function TSMTPSend.noop:Boolean;
begin begin
Result:=false; FSock.SendString('NOOP' + CRLF);
Sock.SendString('NOOP'+CRLF); Result := ReadResult = 250;
if readresult<>250 then Exit;
Result:=True;
end; end;
function TSMTPSend.MailFrom(const Value: string; Size: Integer): Boolean;
{TSMTPSend.mailfrom}
function TSMTPSend.mailfrom(Value:string; size:integer):Boolean;
var var
s: string; s: string;
begin begin
Result:=false;
s := 'MAIL FROM:<' + Value + '>'; s := 'MAIL FROM:<' + Value + '>';
if ESMTPsize and (size>0) if FESMTPsize and (Size > 0) then
then s:=s+' SIZE='+IntToStr(size); s := s + ' SIZE=' + IntToStr(Size);
Sock.SendString(s+CRLF); FSock.SendString(s + CRLF);
if readresult<>250 then Exit; Result := ReadResult = 250;
Result:=True;
end; end;
{TSMTPSend.mailto} function TSMTPSend.MailTo(const Value: string): Boolean;
function TSMTPSend.mailto(Value:string):Boolean;
begin begin
Result:=false; FSock.SendString('RCPT TO:<' + Value + '>' + CRLF);
Sock.SendString('RCPT TO:<'+Value+'>'+CRLF); Result := ReadResult = 250;
if readresult<>250 then Exit;
Result:=True;
end; end;
{TSMTPSend.maildata} function TSMTPSend.MailData(const Value: TStrings): Boolean;
function TSMTPSend.maildata(Value:Tstrings):Boolean;
var var
n:integer; n: Integer;
s: string; s: string;
begin begin
Result:=false; Result := False;
Sock.SendString('DATA'+CRLF); FSock.SendString('DATA' + CRLF);
if readresult<>354 then Exit; if ReadResult <> 354 then
Exit;
for n := 0 to Value.Count - 1 do for n := 0 to Value.Count - 1 do
begin begin
s:=value[n]; s := Value[n];
if Length(s) >= 1 then if Length(s) >= 1 then
if s[1]='.' then s:='.'+s; if s[1] = '.' then
Sock.SendString(s+CRLF); s := '.' + s;
FSock.SendString(s + CRLF);
end; end;
Sock.SendString('.'+CRLF); FSock.SendString('.' + CRLF);
if readresult<>250 then Exit; Result := ReadResult = 250;
Result:=True;
end; end;
{TSMTPSend.etrn} function TSMTPSend.Etrn(const Value: string): Boolean;
function TSMTPSend.etrn(Value:string):Boolean;
var var
x:integer; x: Integer;
begin begin
Result:=false; FSock.SendString('ETRN ' + Value + CRLF);
Sock.SendString('ETRN '+Value+CRLF);
x := ReadResult; x := ReadResult;
if (x<250) or (x>259) then Exit; Result := (x >= 250) and (x <= 259);
Result:=True;
end; end;
{TSMTPSend.verify} function TSMTPSend.Verify(const Value: string): Boolean;
function TSMTPSend.verify(Value:string):Boolean;
var var
x:integer; x: Integer;
begin begin
Result:=false; FSock.SendString('VRFY ' + Value + CRLF);
Sock.SendString('VRFY '+Value+CRLF);
x := ReadResult; x := ReadResult;
if (x<250) or (x>259) then Exit; Result := (x >= 250) and (x <= 259);
Result:=True;
end; end;
{TSMTPSend.EnhCodeString}
function TSMTPSend.EnhCodeString: string; function TSMTPSend.EnhCodeString: string;
var var
s, t: string; s, t: string;
begin begin
s:=inttostr(EnhCode2)+'.'+inttostr(EnhCode3); s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3);
t := ''; t := '';
if s = '0.0' then t := 'Other undefined Status'; if s = '0.0' then t := 'Other undefined Status';
if s = '1.0' then t := 'Other address 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.0' then t := 'Other or undefined mailbox status';
if s = '2.1' then t := 'Mailbox disabled, not accepting messages'; if s = '2.1' then t := 'Mailbox disabled, not accepting messages';
if s = '2.2' then t := 'Mailbox full'; 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 = '2.4' then t := 'Mailing list expansion problem';
if s = '3.0' then t := 'Other or undefined mail system status'; if s = '3.0' then t := 'Other or undefined mail system status';
if s = '3.1' then t := 'Mail system full'; 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.6' then t := 'Cryptographic algorithm not supported';
if s = '7.7' then t := 'Message integrity failure'; if s = '7.7' then t := 'Message integrity failure';
s := '???-'; s := '???-';
if EnhCode1=2 then s:='Success-'; if FEnhCode1 = 2 then s := 'Success-';
if EnhCode1=4 then s:='Persistent Transient Failure-'; if FEnhCode1 = 4 then s := 'Persistent Transient Failure-';
if EnhCode1=5 then s:='Permanent Failure-'; if FEnhCode1 = 5 then s := 'Permanent Failure-';
result:=s+t; Result := s + t;
end; end;
{TSMTPSend.FindCap} function TSMTPSend.FindCap(const Value: string): string;
function TSMTPSend.FindCap(value:string):string;
var var
n:integer; n: Integer;
s: string; s: string;
begin begin
s:=uppercase(value); s := UpperCase(Value);
result:=''; Result := '';
for n:=0 to ESMTPcap.count-1 do for n := 0 to FESMTPcap.Count - 1 do
if pos(s,uppercase(ESMTPcap[n]))=1 then if Pos(s, UpperCase(FESMTPcap[n])) = 1 then
begin begin
result:=ESMTPcap[n]; Result := FESMTPcap[n];
break; Break;
end; end;
end; end;
{==============================================================================} {==============================================================================}
function SendtoRaw (mailfrom,mailto,SMTPHost:string;maildata:TStrings; function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
Username,Password:string):Boolean; const MailData: TStrings; const Username, Password: string): Boolean;
var var
SMTP: TSMTPSend; SMTP: TSMTPSend;
size:integer;
begin begin
Result := False; Result := False;
SMTP := TSMTPSend.Create; SMTP := TSMTPSend.Create;
@ -463,45 +461,43 @@ begin
SMTP.SMTPHost := SMTPHost; SMTP.SMTPHost := SMTPHost;
SMTP.Username := Username; SMTP.Username := Username;
SMTP.Password := Password; SMTP.Password := Password;
if not SMTP.login then Exit; if SMTP.Login then
size:=length(maildata.text); begin
if not SMTP.mailfrom(mailfrom,size) then Exit; if SMTP.MailFrom(MailFrom, Length(MailData.Text)) then
if not SMTP.mailto(mailto) then Exit; if SMTP.MailTo(MailTo) then
if not SMTP.maildata(Maildata) then Exit; if SMTP.MailData(MailData) then
SMTP.logout;
Result := True; Result := True;
SMTP.Logout;
end;
finally finally
SMTP.Free; SMTP.Free;
end; end;
end; end;
function SendtoEx (mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings; function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
Username,Password:string):Boolean; const MailData: TStrings; const Username, Password: string): Boolean;
var var
t: TStrings; t: TStrings;
begin begin
// Result:=False;
t := TStringList.Create; t := TStringList.Create;
try try
t.assign(Maildata); t.Assign(MailData);
t.Insert(0, ''); t.Insert(0, '');
t.Insert(0, 'x-mailer: Synapse - Delphi TCP/IP library by Lukas Gebauer'); 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, 'date: ' + Rfc822DateTime(now));
t.Insert(0,'to: '+mailto); t.Insert(0, 'to: ' + MailTo);
t.Insert(0,'from: '+mailfrom); t.Insert(0, 'from: ' + MailFrom);
Result:=SendToRaw(mailfrom,mailto,SMTPHost,t,Username,Password); Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password);
finally finally
t.Free; t.Free;
end; end;
end; end;
function Sendto function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
(mailfrom,mailto,subject,SMTPHost:string;maildata:TStrings):Boolean; const MailData: TStrings): Boolean;
begin begin
result:=SendToEx(mailfrom,mailto,subject,SMTPHost,maildata,'',''); Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', '');
end; end;
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 | | 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 | | (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/ |
| | | |
@ -25,22 +25,25 @@
|==============================================================================} |==============================================================================}
{$Q-} {$Q-}
{$WEAKPACKAGEUNIT ON}
unit SNMPSend; unit SNMPSend;
interface interface
uses uses
BlckSock, synautil, classes, sysutils, ASN1Util; Classes, SysUtils,
blckSock, SynaUtil, ASN1Util;
const const
cSnmpProtocol = '161';
//PDU type //PDU type
PDUGetRequest=$a0; PDUGetRequest = $A0;
PDUGetNextRequest=$a1; PDUGetNextRequest = $A1;
PDUGetResponse=$a2; PDUGetResponse = $A2;
PDUSetRequest=$a3; PDUSetRequest = $A3;
PDUTrap=$a4; PDUTrap = $A4;
//errors //errors
ENoError = 0; ENoError = 0;
@ -51,175 +54,184 @@ EReadOnly=4;
EGenErr = 5; EGenErr = 5;
type type
TSNMPMib = class(TObject)
TSNMPMib = class private
OID: string; FOID: string;
Value: string; FValue: string;
ValueType: integer; 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; end;
TSNMPRec = class(TObject) TSNMPRec = class(TObject)
private
FVersion: Integer;
FCommunity: string;
FPDUType: Integer;
FID: Integer;
FErrorStatus: Integer;
FErrorIndex: Integer;
FSNMPMibList: TList;
public public
version:integer;
community:string;
PDUType:integer;
ID:integer;
ErrorStatus:integer;
ErrorIndex:integer;
SNMPMibList: TList;
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
function DecodeBuf(Buffer:string):boolean; function DecodeBuf(const Buffer: string): Boolean;
function EncodeBuf: string; function EncodeBuf: string;
procedure Clear; procedure Clear;
procedure MIBAdd(MIB,Value:string; ValueType:integer); procedure MIBAdd(const MIB, Value: string; ValueType: Integer);
procedure MIBdelete(Index:integer); procedure MIBDelete(Index: Integer);
function MIBGet(MIB:string):string; 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; end;
TSNMPSend = class(TObject) TSNMPSend = class(TObject)
private private
Sock:TUDPBlockSocket; FSock: TUDPBlockSocket;
Buffer:string; FBuffer: string;
FTimeout: Integer;
FHost: string;
FHostIP: string;
FQuery: TSNMPRec;
FReply: TSNMPRec;
public public
Timeout:integer;
Host:string;
HostIP:string;
Query:TSNMPrec;
Reply:TSNMPrec;
constructor Create; constructor Create;
destructor Destroy; override; 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; end;
function SNMPget (Oid, Community, SNMPHost:string; var Value:string):Boolean; function SNMPGet(const Oid, Community, SNMPHost: string;
function SNMPSet (Oid, Community, SNMPHost, Value: string; ValueType: integer): boolean; var Value: string): Boolean;
function SNMPSet(const Oid, Community, SNMPHost, Value: string;
ValueType: Integer): Boolean;
implementation implementation
{==============================================================================} {==============================================================================}
{TSNMPRec.Create}
constructor TSNMPRec.Create; constructor TSNMPRec.Create;
begin begin
inherited create; inherited Create;
SNMPMibList := TList.create; FSNMPMibList := TList.Create;
id := 1; id := 1;
end; end;
{TSNMPRec.Destroy}
destructor TSNMPRec.Destroy; destructor TSNMPRec.Destroy;
var var
i:integer; i: Integer;
begin begin
for i := 0 to SNMPMibList.count - 1 do for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(SNMPMibList[i]).Free; TSNMPMib(FSNMPMibList[i]).Free;
SNMPMibList.free; FSNMPMibList.Free;
inherited destroy; inherited Destroy;
end; end;
{TSNMPRec.DecodeBuf} function TSNMPRec.DecodeBuf(const Buffer: string): Boolean;
function TSNMPRec.DecodeBuf(Buffer:string):boolean;
var var
Pos:integer; Pos: Integer;
endpos:integer; EndPos: Integer;
sm, sv: string; sm, sv: string;
svt: integer; Svt: Integer;
begin begin
result:=false; Result := False;
if length(buffer)<2 if Length(Buffer) < 2 then
then exit; Exit;
if (ord(buffer[1]) and $20)=0 if (Ord(Buffer[1]) and $20) = 0 then
then exit; Exit;
Pos := 2; Pos := 2;
Endpos:=ASNDecLen(Pos,buffer); EndPos := ASNDecLen(Pos, Buffer);
if length(buffer)<(Endpos+2) if Length(Buffer) < (EndPos + 2) then
then exit; Exit;
Self.version:=StrToIntDef(ASNItem(Pos,buffer,svt),0); Self.FVersion := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.community:=ASNItem(Pos,buffer,svt); Self.FCommunity := ASNItem(Pos, Buffer, Svt);
Self.PDUType:=StrToIntDef(ASNItem(Pos,buffer,svt),0); Self.FPDUType := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.ID:=StrToIntDef(ASNItem(Pos,buffer,svt),0); Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.ErrorStatus:=StrToIntDef(ASNItem(Pos,buffer,svt),0); Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.ErrorIndex:=StrToIntDef(ASNItem(Pos,buffer,svt),0); Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
ASNItem(Pos,buffer,svt); ASNItem(Pos, Buffer, Svt);
while Pos<Endpos do while Pos < EndPos do
begin begin
ASNItem(Pos,buffer,svt); ASNItem(Pos, Buffer, Svt);
Sm:=ASNItem(Pos,buffer,svt); Sm := ASNItem(Pos, Buffer, Svt);
Sv:=ASNItem(Pos,buffer,svt); Sv := ASNItem(Pos, Buffer, Svt);
Self.MIBadd(sm,sv, svt); Self.MIBAdd(sm, sv, Svt);
end; end;
result:=true; Result := True;
end; end;
{TSNMPRec.EncodeBuf}
function TSNMPRec.EncodeBuf: string; function TSNMPRec.EncodeBuf: string;
var var
data, s: string; data, s: string;
SNMPMib: TSNMPMib; SNMPMib: TSNMPMib;
n:integer; n: Integer;
begin begin
data := ''; data := '';
for n:=0 to SNMPMibList.Count-1 do for n := 0 to FSNMPMibList.Count - 1 do
begin begin
SNMPMib := SNMPMibList[n]; SNMPMib := FSNMPMibList[n];
case (SNMPMib.ValueType) of case SNMPMib.ValueType of
ASN1_INT: ASN1_INT:
begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
+ASNObject(ASNEncInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS: ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
+ASNObject(ASNEncUInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
ASN1_OBJID: ASN1_OBJID:
begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(MibToID(SNMPMib.Value),SNMPMib.ValueType); ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType);
end;
ASN1_IPADDR: ASN1_IPADDR:
begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(IPToID(SNMPMib.Value),SNMPMib.ValueType); ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType);
end;
ASN1_NULL: ASN1_NULL:
begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject('',ASN1_NULL); ASNObject('', ASN1_NULL);
end;
else 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; end;
data := data + ASNObject(s, ASN1_SEQ); data := data + ASNObject(s, ASN1_SEQ);
end; end;
data := ASNObject(data, ASN1_SEQ); data := ASNObject(data, ASN1_SEQ);
data:=ASNObject(ASNEncInt(Self.ID),ASN1_INT) data := ASNObject(ASNEncInt(Self.FID), ASN1_INT) +
+ASNObject(ASNEncInt(Self.ErrorStatus),ASN1_INT) ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) +
+ASNObject(ASNEncInt(Self.ErrorIndex),ASN1_INT) ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) +
+data; data;
data:=ASNObject(ASNEncInt(Self.Version),ASN1_INT) data := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) +
+ASNObject(Self.community,ASN1_OCTSTR) ASNObject(Self.FCommunity, ASN1_OCTSTR) +
+ASNObject(data,Self.PDUType); ASNObject(data, Self.FPDUType);
data := ASNObject(data, ASN1_SEQ); data := ASNObject(data, ASN1_SEQ);
Result := data; Result := data;
end; end;
{TSNMPRec.Clear}
procedure TSNMPRec.Clear; procedure TSNMPRec.Clear;
var var
i:integer; i: Integer;
begin begin
version:=0; FVersion := 0;
community:=''; FCommunity := '';
PDUType:=0; FPDUType := 0;
ErrorStatus:=0; FErrorStatus := 0;
ErrorIndex:=0; FErrorIndex := 0;
for i := 0 to SNMPMibList.count - 1 do for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(SNMPMibList[i]).Free; TSNMPMib(FSNMPMibList[i]).Free;
SNMPMibList.Clear; FSNMPMibList.Clear;
end; end;
{TSNMPRec.MIBAdd} procedure TSNMPRec.MIBAdd(const MIB, Value: string; ValueType: Integer);
procedure TSNMPRec.MIBAdd(MIB,Value:string; ValueType:integer);
var var
SNMPMib: TSNMPMib; SNMPMib: TSNMPMib;
begin begin
@ -227,122 +239,117 @@ begin
SNMPMib.OID := MIB; SNMPMib.OID := MIB;
SNMPMib.Value := Value; SNMPMib.Value := Value;
SNMPMib.ValueType := ValueType; SNMPMib.ValueType := ValueType;
SNMPMibList.Add(SNMPMib); FSNMPMibList.Add(SNMPMib);
end; end;
{TSNMPRec.MIBdelete} procedure TSNMPRec.MIBDelete(Index: Integer);
procedure TSNMPRec.MIBdelete(Index:integer);
begin begin
if (Index >= 0) and (Index < SNMPMibList.count) then if (Index >= 0) and (Index < FSNMPMibList.Count) then
begin begin
TSNMPMib(SNMPMibList[Index]).Free; TSNMPMib(FSNMPMibList[Index]).Free;
SNMPMibList.Delete(Index); FSNMPMibList.Delete(Index);
end; end;
end; end;
{TSNMPRec.MIBGet} function TSNMPRec.MIBGet(const MIB: string): string;
function TSNMPRec.MIBGet(MIB:string):string;
var var
i: integer; i: Integer;
begin begin
Result := ''; Result := '';
for i := 0 to SNMPMibList.count - 1 do for i := 0 to FSNMPMibList.Count - 1 do
begin begin
if ((TSNMPMib(SNMPMibList[i])).OID = MIB) then if ((TSNMPMib(FSNMPMibList[i])).OID = MIB) then
begin begin
Result := (TSNMPMib(SNMPMibList[i])).Value; Result := (TSNMPMib(FSNMPMibList[i])).Value;
break; Break;
end; end;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{TSNMPSend.Create}
constructor TSNMPSend.Create; constructor TSNMPSend.Create;
begin begin
inherited create; inherited Create;
Query:=TSNMPRec.Create; FQuery := TSNMPRec.Create;
Reply:=TSNMPRec.Create; FReply := TSNMPRec.Create;
Query.Clear; FQuery.Clear;
Reply.Clear; FReply.Clear;
sock:=TUDPBlockSocket.create; FSock := TUDPBlockSocket.Create;
sock.createsocket; FSock.CreateSocket;
timeout:=5000; FTimeout := 5000;
host:='localhost'; FHost := cLocalhost;
HostIP:=''; FHostIP := '';
end; end;
{TSNMPSend.Destroy}
destructor TSNMPSend.Destroy; destructor TSNMPSend.Destroy;
begin begin
Sock.Free; FSock.Free;
Reply.Free; FReply.Free;
Query.Free; FQuery.Free;
inherited destroy; inherited Destroy;
end; end;
{TSNMPSend.DoIt} function TSNMPSend.DoIt: Boolean;
function TSNMPSend.DoIt:boolean;
var var
x:integer; x: Integer;
begin begin
Result:=false; Result := False;
reply.clear; FReply.Clear;
Buffer:=Query.Encodebuf; FBuffer := Query.EncodeBuf;
sock.connect(host,'161'); FSock.Connect(FHost, cSnmpProtocol);
HostIP:=sock.GetRemoteSinIP; FHostIP := FSock.GetRemoteSinIP;
sock.SendBuffer(PChar(Buffer),Length(Buffer)); FSock.SendBuffer(PChar(FBuffer), Length(FBuffer));
if sock.canread(timeout) if FSock.CanRead(FTimeout) then
then begin begin
x:=sock.WaitingData; x := FSock.WaitingData;
if x > 0 then if x > 0 then
begin begin
setlength(Buffer,x); SetLength(FBuffer, x);
sock.RecvBuffer(PChar(Buffer),x); FSock.RecvBuffer(PChar(FBuffer), x);
result:=true; Result := True;
end; end;
end; end;
if Result if Result then
then result:=reply.DecodeBuf(Buffer); Result := FReply.DecodeBuf(FBuffer);
end; end;
{==============================================================================} {==============================================================================}
function SNMPget (Oid, Community, SNMPHost:string; var Value:string):Boolean; function SNMPGet(const Oid, Community, SNMPHost: string;
var Value: string): Boolean;
var var
SNMP: TSNMPSend; SNMP: TSNMPSend;
begin begin
SNMP := TSNMPSend.Create; SNMP := TSNMPSend.Create;
try try
Snmp.Query.community:=Community; SNMP.Query.Community := Community;
Snmp.Query.PDUType:=PDUGetRequest; SNMP.Query.PDUType := PDUGetRequest;
Snmp.Query.MIBAdd(Oid,'',ASN1_NULL); SNMP.Query.MIBAdd(Oid, '', ASN1_NULL);
Snmp.host:=SNMPHost; SNMP.Host := SNMPHost;
Result:=Snmp.DoIt; Result := SNMP.DoIt;
if Result then if Result then
Value:=Snmp.Reply.MIBGet(Oid); Value := SNMP.Reply.MIBGet(Oid);
finally finally
SNMP.Free; SNMP.Free;
end; end;
end; end;
function SNMPSet(Oid, Community, SNMPHost, Value: string; ValueType: integer): boolean; function SNMPSet(const Oid, Community, SNMPHost, Value: string;
ValueType: Integer): Boolean;
var var
SNMPSend: TSNMPSend; SNMPSend: TSNMPSend;
begin begin
SNMPSend := TSNMPSend.Create; SNMPSend := TSNMPSend.Create;
try try
SNMPSend.Query.community := Community; SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUSetRequest; SNMPSend.Query.PDUType := PDUSetRequest;
SNMPSend.Query.MIBAdd(Oid, Value, ValueType); SNMPSend.Query.MIBAdd(Oid, Value, ValueType);
SNMPSend.Host := SNMPHost; SNMPSend.Host := SNMPHost;
result:= SNMPSend.DoIt=true; Result := SNMPSend.DoIt = True;
finally finally
SNMPSend.Free; SNMPSend.Free;
end; end;
end; 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 | | 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 | | (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/ |
| | | |
@ -25,16 +25,18 @@
|==============================================================================} |==============================================================================}
{$Q-} {$Q-}
{$WEAKPACKAGEUNIT ON}
unit SNMPTrap; unit SNMPTrap;
interface interface
uses uses
Classes, SysUtils, BlckSock, SynaUtil, ASN1Util, SNMPsend; Classes, SysUtils,
blckSock, SynaUtil, ASN1Util, SNMPSend;
const const
TRAP_PORT = 162; cSnmpTrapProtocol = '162';
SNMP_VERSION = 0; SNMP_VERSION = 0;
@ -47,83 +49,99 @@ const
type type
TTrapPDU = class(TObject) TTrapPDU = class(TObject)
private private
protected FBuffer: string;
Buffer: string; FTrapPort: string;
FVersion: Integer;
FPDUType: Integer;
FCommunity: string;
FEnterprise: string;
FTrapHost: string;
FGenTrap: Integer;
FSpecTrap: Integer;
FTimeTicks: Integer;
FSNMPMibList: TList;
public public
TrapPort: integer;
Version: integer;
PDUType: integer;
Community: string;
Enterprise: string;
TrapHost: string;
GenTrap: integer;
SpecTrap: integer;
TimeTicks: integer;
SNMPMibList: TList;
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
procedure Clear; procedure Clear;
procedure MIBAdd(MIB, Value: string; ValueType:integer); procedure MIBAdd(const MIB, Value: string; ValueType: Integer);
procedure MIBDelete(Index: integer); procedure MIBDelete(Index: Integer);
function MIBGet(MIB: string): string; function MIBGet(const MIB: string): string;
function EncodeTrap: integer; function EncodeTrap: Integer;
function DecodeTrap: boolean; 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; end;
TTrapSNMP = class(TObject) TTrapSNMP = class(TObject)
private private
sock: TUDPBlockSocket; FSock: TUDPBlockSocket;
FTrap: TTrapPDU;
FSNMPHost: string;
FTimeout: Integer;
public public
Trap: TTrapPDU;
SNMPHost: string;
Timeout: integer;
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
function Send: integer; function Send: Integer;
function Recv: 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; end;
function SendTrap(Dest, Source, Enterprise, Community: string; function SendTrap(const Dest, Source, Enterprise, Community: string;
Generic, Specific, Seconds: integer; MIBName, MIBValue: string; MIBtype:integer): integer; Generic, Specific, Seconds: Integer; const MIBName, MIBValue: string;
MIBtype: Integer): Integer;
function RecvTrap(var Dest, Source, Enterprise, Community: string; 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 implementation
constructor TTrapPDU.Create; constructor TTrapPDU.Create;
begin begin
inherited Create; inherited Create;
SNMPMibList := TList.create; FSNMPMibList := TList.Create;
TrapPort := TRAP_PORT; FTrapPort := cSnmpTrapProtocol;
Version := SNMP_VERSION; FVersion := SNMP_VERSION;
PDUType := PDU_TRAP; FPDUType := PDU_TRAP;
Community := 'public'; FCommunity := 'public';
end; end;
destructor TTrapPDU.Destroy; destructor TTrapPDU.Destroy;
var var
i:integer; i: Integer;
begin begin
for i := 0 to SNMPMibList.count - 1 do for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(SNMPMibList[i]).Free; TSNMPMib(FSNMPMibList[i]).Free;
SNMPMibList.free; FSNMPMibList.Free;
inherited Destroy; inherited Destroy;
end; end;
procedure TTrapPDU.Clear; procedure TTrapPDU.Clear;
var var
i:integer; i: Integer;
begin begin
for i := 0 to SNMPMibList.count - 1 do for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(SNMPMibList[i]).Free; TSNMPMib(FSNMPMibList[i]).Free;
SNMPMibList.Clear; FSNMPMibList.Clear;
TrapPort := TRAP_PORT; FTrapPort := cSnmpTrapProtocol;
Version := SNMP_VERSION; FVersion := SNMP_VERSION;
PDUType := PDU_TRAP; FPDUType := PDU_TRAP;
Community := 'public'; FCommunity := 'public';
end; end;
procedure TTrapPDU.MIBAdd(MIB, Value: string; ValueType:integer); procedure TTrapPDU.MIBAdd(const MIB, Value: string; ValueType: Integer);
var var
SNMPMib: TSNMPMib; SNMPMib: TSNMPMib;
begin begin
@ -131,216 +149,207 @@ begin
SNMPMib.OID := MIB; SNMPMib.OID := MIB;
SNMPMib.Value := Value; SNMPMib.Value := Value;
SNMPMib.ValueType := ValueType; SNMPMib.ValueType := ValueType;
SNMPMibList.Add(SNMPMib); FSNMPMibList.Add(SNMPMib);
end; end;
procedure TTrapPDU.MIBDelete(Index: integer); procedure TTrapPDU.MIBDelete(Index: Integer);
begin begin
if (Index >= 0) and (Index < SNMPMibList.count) then if (Index >= 0) and (Index < FSNMPMibList.Count) then
begin begin
TSNMPMib(SNMPMibList[Index]).Free; TSNMPMib(FSNMPMibList[Index]).Free;
SNMPMibList.Delete(Index); FSNMPMibList.Delete(Index);
end; end;
end; end;
function TTrapPDU.MIBGet(MIB: string): string; function TTrapPDU.MIBGet(const MIB: string): string;
var var
i: integer; i: Integer;
begin begin
Result := ''; Result := '';
for i := 0 to SNMPMibList.count - 1 do for i := 0 to FSNMPMibList.Count - 1 do
begin begin
if ((TSNMPMib(SNMPMibList[i])).OID = MIB) then if TSNMPMib(FSNMPMibList[i]).OID = MIB then
begin begin
Result := (TSNMPMib(SNMPMibList[i])).Value; Result := TSNMPMib(FSNMPMibList[i]).Value;
break; Break;
end; end;
end; end;
end; end;
function TTrapPDU.EncodeTrap: integer; function TTrapPDU.EncodeTrap: Integer;
var var
s: string; s: string;
n: integer; n: Integer;
SNMPMib: TSNMPMib; SNMPMib: TSNMPMib;
begin begin
Buffer := ''; FBuffer := '';
for n:=0 to SNMPMibList.Count-1 do for n := 0 to FSNMPMibList.Count - 1 do
begin begin
SNMPMib := SNMPMibList[n]; SNMPMib := FSNMPMibList[n];
case (SNMPMib.ValueType) of case SNMPMib.ValueType of
ASN1_INT: ASN1_INT:
begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
+ASNObject(ASNEncInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS: ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
+ASNObject(ASNEncUInt(strToIntDef(SNMPMib.Value,0)),SNMPMib.ValueType);
end;
ASN1_OBJID: ASN1_OBJID:
begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(MibToID(SNMPMib.Value),SNMPMib.ValueType); ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType);
end;
ASN1_IPADDR: ASN1_IPADDR:
begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject(IPToID(SNMPMib.Value),SNMPMib.ValueType); ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType);
end;
ASN1_NULL: ASN1_NULL:
begin s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
s := ASNObject(MibToID(SNMPMib.OID),ASN1_OBJID) + ASNObject('',ASN1_NULL); ASNObject('', ASN1_NULL);
end;
else 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; end;
Buffer := Buffer + ASNObject(s, ASN1_SEQ); FBuffer := FBuffer + ASNObject(s, ASN1_SEQ);
end; end;
Buffer := ASNObject(Buffer, ASN1_SEQ); FBuffer := ASNObject(FBuffer, ASN1_SEQ);
Buffer := ASNObject(ASNEncInt(GenTrap), ASN1_INT) FBuffer := ASNObject(ASNEncInt(FGenTrap), ASN1_INT) +
+ ASNObject(ASNEncInt(SpecTrap), ASN1_INT) ASNObject(ASNEncInt(FSpecTrap), ASN1_INT) +
+ ASNObject(ASNEncUInt(TimeTicks), ASN1_TIMETICKS) ASNObject(ASNEncUInt(FTimeTicks), ASN1_TIMETICKS) +
+ Buffer; FBuffer;
Buffer := ASNObject(MibToID(Enterprise), ASN1_OBJID) FBuffer := ASNObject(MibToID(FEnterprise), ASN1_OBJID) +
+ ASNObject(IPToID(TrapHost), ASN1_IPADDR) ASNObject(IPToID(FTrapHost), ASN1_IPADDR) +
+ Buffer; FBuffer;
Buffer := ASNObject(ASNEncInt(Version), ASN1_INT) FBuffer := ASNObject(ASNEncInt(FVersion), ASN1_INT) +
+ ASNObject(Community, ASN1_OCTSTR) ASNObject(FCommunity, ASN1_OCTSTR) +
+ ASNObject(Buffer, Self.PDUType); ASNObject(FBuffer, Self.FPDUType);
Buffer := ASNObject(Buffer, ASN1_SEQ); FBuffer := ASNObject(FBuffer, ASN1_SEQ);
Result := 1; Result := 1;
end; end;
function TTrapPDU.DecodeTrap: boolean; function TTrapPDU.DecodeTrap: Boolean;
var var
Pos, EndPos: integer; Pos, EndPos: Integer;
Sm, Sv: string; Sm, Sv: string;
Svt:integer; Svt: Integer;
begin begin
clear; Clear;
result:=false; Result := False;
if length(buffer)<2 if Length(FBuffer) < 2 then
then exit; Exit;
if (ord(buffer[1]) and $20)=0 if (Ord(FBuffer[1]) and $20) = 0 then
then exit; Exit;
Pos := 2; Pos := 2;
EndPos := ASNDecLen(Pos, Buffer); EndPos := ASNDecLen(Pos, FBuffer);
Version := StrToIntDef(ASNItem(Pos, Buffer,svt), 0); FVersion := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
Community := ASNItem(Pos, Buffer,svt); FCommunity := ASNItem(Pos, FBuffer, Svt);
PDUType := StrToIntDef(ASNItem(Pos, Buffer,svt), PDU_TRAP); FPDUType := StrToIntDef(ASNItem(Pos, FBuffer, Svt), PDU_TRAP);
Enterprise := ASNItem(Pos, Buffer,svt); FEnterprise := ASNItem(Pos, FBuffer, Svt);
TrapHost := ASNItem(Pos, Buffer,svt); FTrapHost := ASNItem(Pos, FBuffer, Svt);
GenTrap := StrToIntDef(ASNItem(Pos, Buffer,svt), 0); FGenTrap := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
Spectrap := StrToIntDef(ASNItem(Pos, Buffer,svt), 0); FSpecTrap := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
TimeTicks := StrToIntDef(ASNItem(Pos, Buffer,svt), 0); FTimeTicks := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
ASNItem(Pos, Buffer,svt); ASNItem(Pos, FBuffer, Svt);
while (Pos < EndPos) do while Pos < EndPos do
begin begin
ASNItem(Pos, Buffer,svt); ASNItem(Pos, FBuffer, Svt);
Sm := ASNItem(Pos, Buffer,svt); Sm := ASNItem(Pos, FBuffer, Svt);
Sv := ASNItem(Pos, Buffer,svt); Sv := ASNItem(Pos, FBuffer, Svt);
MIBAdd(Sm, Sv, svt); MIBAdd(Sm, Sv, Svt);
end; end;
Result := true; Result := True;
end; end;
constructor TTrapSNMP.Create; constructor TTrapSNMP.Create;
begin begin
inherited Create; inherited Create;
Sock := TUDPBlockSocket.Create; FSock := TUDPBlockSocket.Create;
Trap := TTrapPDU.Create; FTrap := TTrapPDU.Create;
Timeout := 5000; FTimeout := 5000;
SNMPHost := '127.0.0.1'; FSNMPHost := cLocalhost;
Sock.CreateSocket; FSock.CreateSocket;
end; end;
destructor TTrapSNMP.Destroy; destructor TTrapSNMP.Destroy;
begin begin
Trap.Free; FTrap.Free;
Sock.Free; FSock.Free;
inherited Destroy; inherited Destroy;
end; end;
function TTrapSNMP.Send: integer; function TTrapSNMP.Send: Integer;
begin begin
Trap.EncodeTrap; FTrap.EncodeTrap;
Sock.Connect(SNMPHost, IntToStr(Trap.TrapPort)); FSock.Connect(SNMPHost, FTrap.TrapPort);
Sock.SendBuffer(PChar(Trap.Buffer), Length(Trap.Buffer)); FSock.SendBuffer(PChar(FTrap.FBuffer), Length(FTrap.FBuffer));
Result := 1; Result := 1;
end; end;
function TTrapSNMP.Recv: integer; function TTrapSNMP.Recv: Integer;
var var
x: integer; x: Integer;
begin begin
Result := 0; Result := 0;
Sock.Bind('0.0.0.0', IntToStr(Trap.TrapPort)); FSock.Bind('0.0.0.0', FTrap.TrapPort);
if Sock.CanRead(Timeout) then if FSock.CanRead(FTimeout) then
begin begin
x := Sock.WaitingData; x := FSock.WaitingData;
if (x > 0) then if x > 0 then
begin begin
SetLength(Trap.Buffer, x); SetLength(FTrap.FBuffer, x);
Sock.RecvBuffer(PChar(Trap.Buffer), x); FSock.RecvBuffer(PChar(FTrap.FBuffer), x);
if Trap.DecodeTrap if FTrap.DecodeTrap then
then Result:=1; Result := 1;
end; end;
end; end;
end; end;
function SendTrap(Dest, Source, Enterprise, Community: string; function SendTrap(const Dest, Source, Enterprise, Community: string;
Generic, Specific, Seconds: integer; MIBName, MIBValue: string; MIBtype:integer): integer; Generic, Specific, Seconds: Integer; const MIBName, MIBValue: string;
var MIBtype: Integer): Integer;
SNMP: TTrapSNMP;
begin begin
SNMP := TTrapSNMP.Create; with TTrapSNMP.Create do
try try
SNMP.SNMPHost := Dest; SNMPHost := Dest;
SNMP.Trap.TrapHost := Source; Trap.TrapHost := Source;
SNMP.Trap.Enterprise := Enterprise; Trap.Enterprise := Enterprise;
SNMP.Trap.Community := Community; Trap.Community := Community;
SNMP.Trap.GenTrap := Generic; Trap.GenTrap := Generic;
SNMP.Trap.SpecTrap := Specific; Trap.SpecTrap := Specific;
SNMP.Trap.TimeTicks := Seconds; Trap.TimeTicks := Seconds;
SNMP.Trap.MIBAdd(MIBName,MIBValue,MIBType); Trap.MIBAdd(MIBName, MIBValue, MIBType);
Result := SNMP.Send; Result := Send;
finally finally
SNMP.Free; Free;
end; end;
end; end;
function RecvTrap(var Dest, Source, Enterprise, Community: string; function RecvTrap(var Dest, Source, Enterprise, Community: string;
var Generic, Specific, Seconds: integer; var MIBName, MIBValue: TStringList): var Generic, Specific, Seconds: Integer;
integer; const MIBName, MIBValue: TStringList): Integer;
var var
SNMP: TTrapSNMP; i: Integer;
i: integer;
begin begin
SNMP := TTrapSNMP.Create; with TTrapSNMP.Create do
try try
SNMP.SNMPHost := Dest; SNMPHost := Dest;
Result := SNMP.Recv; Result := Recv;
if (Result <> 0) then if Result <> 0 then
begin begin
Dest := SNMP.SNMPHost; Dest := SNMPHost;
Source := SNMP.Trap.TrapHost; Source := Trap.TrapHost;
Enterprise := SNMP.Trap.Enterprise; Enterprise := Trap.Enterprise;
Community := SNMP.Trap.Community; Community := Trap.Community;
Generic := SNMP.Trap.GenTrap; Generic := Trap.GenTrap;
Specific := SNMP.Trap.SpecTrap; Specific := Trap.SpecTrap;
Seconds := SNMP.Trap.TimeTicks; Seconds := Trap.TimeTicks;
MIBName.Clear; MIBName.Clear;
MIBValue.Clear; MIBValue.Clear;
for i:=0 to (SNMP.Trap.SNMPMibList.count - 1) do for i := 0 to Trap.SNMPMibList.Count - 1 do
begin begin
MIBName.Add(TSNMPMib(SNMP.Trap.SNMPMibList[i]).OID); MIBName.Add(TSNMPMib(Trap.SNMPMibList[i]).OID);
MIBValue.Add(TSNMPMib(SNMP.Trap.SNMPMibList[i]).Value); MIBValue.Add(TSNMPMib(Trap.SNMPMibList[i]).Value);
end; end;
end; end;
finally finally
SNMP.Free; Free;
end; end;
end; 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 | | 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 | | (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/ |
| | | |
@ -14,7 +14,7 @@
| The Original Code is Synapse Delphi Library. | | The Original Code is Synapse Delphi Library. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | 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. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
@ -24,142 +24,144 @@
|==============================================================================} |==============================================================================}
{$Q-} {$Q-}
{$WEAKPACKAGEUNIT ON}
unit SNTPsend; unit SNTPsend;
interface interface
uses uses
synsock, SysUtils, blcksock; SysUtils,
synsock, blcksock;
const
cNtpProtocol = 'ntp';
type type
PNtp = ^TNtp;
TNtp = packed record TNtp = packed record
mode: Byte; mode: Byte;
stratum: Byte; stratum: Byte;
poll: Byte; poll: Byte;
Precision: Byte; Precision: Byte;
RootDelay : longint; RootDelay: Longint;
RootDisperson : longint; RootDisperson: Longint;
RefID : longint; RefID: Longint;
Ref1, Ref2, Ref1: Longint;
Org1, Org2, Ref2: Longint;
Rcv1, Rcv2, Org1: Longint;
Xmit1, Xmit2 : longint; Org2: Longint;
Rcv1: Longint;
Rcv2: Longint;
Xmit1: Longint;
Xmit2: Longint;
end; end;
TSNTPSend = class(TObject) TSNTPSend = class(TObject)
private private
Sock:TUDPBlockSocket; FNTPReply: TNtp;
Buffer:string; FNTPTime: TDateTime;
FSntpHost: string;
FTimeout: Integer;
FSock: TUDPBlockSocket;
FBuffer: string;
public public
timeout:integer;
SntpHost:string;
NTPReply:TNtp;
NTPTime:TDateTime;
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
function DecodeTs(nsec,nfrac:Longint):tdatetime; function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
function GetNTP: Boolean; function GetNTP: Boolean;
function GetBroadcastNTP: 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; end;
implementation implementation
{==============================================================================} constructor TSNTPSend.Create;
{TSNTPSend.Create}
Constructor TSNTPSend.Create;
begin begin
inherited Create; inherited Create;
sock:=TUDPBlockSocket.create; FSock := TUDPBlockSocket.Create;
sock.CreateSocket; FSock.CreateSocket;
timeout:=5000; FTimeout := 5000;
sntphost:='localhost'; FSntpHost := cLocalhost;
end; end;
{TSNTPSend.Destroy} destructor TSNTPSend.Destroy;
Destructor TSNTPSend.Destroy;
begin begin
Sock.free; FSock.Free;
inherited destroy; inherited Destroy;
end; end;
{TSNTPSend.DecodeTs} function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
function TSNTPSend.DecodeTs(nsec,nfrac:Longint):tdatetime;
const const
maxi = 4294967296.0; maxi = 4294967296.0;
var var
d, d1: double; d, d1: Double;
begin begin
nsec:=synsock.htonl(nsec); Nsec := synsock.htonl(Nsec);
nfrac:=synsock.htonl(nfrac); Nfrac := synsock.htonl(Nfrac);
d:=nsec; d := Nsec;
if d<0 if d < 0 then
then d:=maxi+d-1; d := maxi + d - 1;
d1 := nfrac; d1 := Nfrac;
if d1<0 if d1 < 0 then
then d1:=maxi+d1-1; d1 := maxi + d1 - 1;
d1 := d1 / maxi; d1 := d1 / maxi;
d1:=trunc(d1*1000)/1000; d1 := Trunc(d1 * 1000) / 1000;
result:=(d+d1)/86400; Result := (d + d1) / 86400;
result := Result + 2; Result := Result + 2;
end; end;
{TSNTPSend.GetBroadcastNTP}
function TSNTPSend.GetBroadcastNTP: Boolean; function TSNTPSend.GetBroadcastNTP: Boolean;
var var
PNtp:^TNtp; NtpPtr: PNtp;
x:integer; x: Integer;
begin begin
Result := False; Result := False;
sock.bind('0.0.0.0','ntp'); FSock.Bind('0.0.0.0', cNtpProtocol);
if sock.canread(timeout) if FSock.CanRead(Timeout) then
then begin begin
x:=sock.waitingdata; x := FSock.WaitingData;
setlength(Buffer,x); SetLength(FBuffer, x);
sock.recvbufferFrom(Pointer(Buffer),x); FSock.RecvBufferFrom(Pointer(FBuffer), x);
if (sntphost='0.0.0.0') or (sock.GetRemoteSinIP=sntphost) then if (SntpHost = '0.0.0.0') or (FSock.GetRemoteSinIP = SntpHost) then
if x >= SizeOf(NTPReply) then if x >= SizeOf(NTPReply) then
begin begin
PNtp:=Pointer(Buffer); NtpPtr := Pointer(FBuffer);
NtpReply:=PNtp^; FNTPReply := NtpPtr^;
NTPtime:=DeCodeTs(ntpreply.Xmit1,ntpreply.Xmit2); FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
Result := True; Result := True;
end; end;
end; end;
end; end;
{TSNTPSend.GetNTP}
function TSNTPSend.GetNTP: Boolean; function TSNTPSend.GetNTP: Boolean;
var var
q:Tntp; q: TNtp;
PNtp:^TNtp; NtpPtr: PNtp;
x:integer; x: Integer;
begin begin
Result := False; Result := False;
sock.Connect(sntphost,'ntp'); FSock.Connect(sntphost, cNtpProtocol);
fillchar(q,SizeOf(q),0); FillChar(q, SizeOf(q), 0);
q.mode:=$1b; q.mode := $1B;
sock.SendBuffer(@q,SizeOf(q)); FSock.SendBuffer(@q, SizeOf(q));
if sock.canread(timeout) if FSock.CanRead(Timeout) then
then begin begin
x:=sock.waitingdata; x := FSock.WaitingData;
setlength(Buffer,x); SetLength(FBuffer, x);
sock.recvbuffer(Pointer(Buffer),x); FSock.RecvBuffer(Pointer(FBuffer), x);
if x >= SizeOf(NTPReply) then if x >= SizeOf(NTPReply) then
begin begin
PNtp:=Pointer(Buffer); NtpPtr := Pointer(FBuffer);
NtpReply:=PNtp^; FNTPReply := NtpPtr^;
NTPtime:=DeCodeTs(ntpreply.Xmit1,ntpreply.Xmit2); FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
Result := True; Result := True;
end; end;
end; end;
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 | | 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 | | (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, | | 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 | | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
@ -24,26 +24,28 @@
|==============================================================================} |==============================================================================}
{$Q-} {$Q-}
{$WEAKPACKAGEUNIT ON}
unit SynaCode; unit SynaCode;
interface interface
uses uses
sysutils; SysUtils;
type type
TSpecials=set of char; TSpecials = set of Char;
const const
SpecialChar:TSpecials
=['=','(',')','[',']','<','>',':',';','.',',','@','/','?','\','"','_'];
URLFullSpecialChar:TSpecials
=[';','/','?',':','@','=','&','#'];
URLSpecialChar:TSpecials
=[#$00..#$1f,'_','<','>','"','%','{','}','|','\','^','~','[',']','`',#$7f..#$ff];
SpecialChar: TSpecials =
['=', '(', ')', '[', ']', '<', '>', ':', ';', '.', ',', '@', '/', '?', '\',
'"', '_'];
URLFullSpecialChar: TSpecials =
[';', '/', '?', ':', '@', '=', '&', '#'];
URLSpecialChar: TSpecials =
[#$00..#$20, '_', '<', '>', '"', '%', '{', '}', '|', '\', '^', '~', '[', ']',
'`', #$7F..#$FF];
TableBase64 = TableBase64 =
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='; 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';
TableUU = TableUU =
@ -52,286 +54,291 @@ const
'+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_'; '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_';
Crc32Tab: array[0..255] of integer = ( function DecodeTriplet(const Value: string; Delimiter: Char): string;
Integer($00000000),Integer($77073096),Integer($ee0e612c),Integer($990951ba), function DecodeQuotedPrintable(const Value: string): string;
Integer($076dc419),Integer($706af48f),Integer($e963a535),Integer($9e6495a3), function DecodeURL(const Value: string): string;
Integer($0edb8832),Integer($79dcb8a4),Integer($e0d5e91e),Integer($97d2d988), function EncodeTriplet(const Value: string; Delimiter: Char;
Integer($09b64c2b),Integer($7eb17cbd),Integer($e7b82d07),Integer($90bf1d91), Specials: TSpecials): string;
Integer($1db71064),Integer($6ab020f2),Integer($f3b97148),Integer($84be41de), function EncodeQuotedPrintable(const Value: string): string;
Integer($1adad47d),Integer($6ddde4eb),Integer($f4d4b551),Integer($83d385c7), function EncodeURLElement(const Value: string): string;
Integer($136c9856),Integer($646ba8c0),Integer($fd62f97a),Integer($8a65c9ec), function EncodeURL(const Value: string): string;
Integer($14015c4f),Integer($63066cd9),Integer($fa0f3d63),Integer($8d080df5), function Decode4to3(const Value, Table: string): string;
Integer($3b6e20c8),Integer($4c69105e),Integer($d56041e4),Integer($a2677172), function DecodeBase64(const Value: string): string;
Integer($3c03e4d1),Integer($4b04d447),Integer($d20d85fd),Integer($a50ab56b), function EncodeBase64(const Value: string): string;
Integer($35b5a8fa),Integer($42b2986c),Integer($dbbbc9d6),Integer($acbcf940), function DecodeUU(const Value: string): string;
Integer($32d86ce3),Integer($45df5c75),Integer($dcd60dcf),Integer($abd13d59), function DecodeXX(const Value: string): string;
Integer($26d930ac),Integer($51de003a),Integer($c8d75180),Integer($bfd06116), function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
Integer($21b4f4b5),Integer($56b3c423),Integer($cfba9599),Integer($b8bda50f), function Crc32(const Value: string): Integer;
Integer($2802b89e),Integer($5f058808),Integer($c60cd9b2),Integer($b10be924), function UpdateCrc16(Value: Byte; Crc16: Word): Word;
Integer($2f6f7c87),Integer($58684c11),Integer($c1611dab),Integer($b6662d3d), function Crc16(const Value: string): Word;
Integer($76dc4190),Integer($01db7106),Integer($98d220bc),Integer($efd5102a), function MD5(const Value: string): string;
Integer($71b18589),Integer($06b6b51f),Integer($9fbfe4a5),Integer($e8b8d433), function HMAC_MD5(Text, Key: string): string;
Integer($7807c9a2),Integer($0f00f934),Integer($9609a88e),Integer($e10e9818),
Integer($7f6a0dbb),Integer($086d3d2d),Integer($91646c97),Integer($e6635c01), implementation
Integer($6b6b51f4),Integer($1c6c6162),Integer($856530d8),Integer($f262004e),
Integer($6c0695ed),Integer($1b01a57b),Integer($8208f4c1),Integer($f50fc457), const
Integer($65b0d9c6),Integer($12b7e950),Integer($8bbeb8ea),Integer($fcb9887c),
Integer($62dd1ddf),Integer($15da2d49),Integer($8cd37cf3),Integer($fbd44c65), Crc32Tab: array[0..255] of Integer = (
Integer($4db26158),Integer($3ab551ce),Integer($a3bc0074),Integer($d4bb30e2), Integer($00000000), Integer($77073096), Integer($EE0E612C), Integer($990951BA),
Integer($4adfa541),Integer($3dd895d7),Integer($a4d1c46d),Integer($d3d6f4fb), Integer($076DC419), Integer($706AF48F), Integer($E963A535), Integer($9E6495A3),
Integer($4369e96a),Integer($346ed9fc),Integer($ad678846),Integer($da60b8d0), Integer($0EDB8832), Integer($79DCB8A4), Integer($E0D5E91E), Integer($97D2D988),
Integer($44042d73),Integer($33031de5),Integer($aa0a4c5f),Integer($dd0d7cc9), Integer($09B64C2B), Integer($7EB17CBD), Integer($E7B82D07), Integer($90BF1D91),
Integer($5005713c),Integer($270241aa),Integer($be0b1010),Integer($c90c2086), Integer($1DB71064), Integer($6AB020F2), Integer($F3B97148), Integer($84BE41DE),
Integer($5768b525),Integer($206f85b3),Integer($b966d409),Integer($ce61e49f), Integer($1ADAD47D), Integer($6DDDE4EB), Integer($F4D4B551), Integer($83D385C7),
Integer($5edef90e),Integer($29d9c998),Integer($b0d09822),Integer($c7d7a8b4), Integer($136C9856), Integer($646BA8C0), Integer($FD62F97A), Integer($8A65C9EC),
Integer($59b33d17),Integer($2eb40d81),Integer($b7bd5c3b),Integer($c0ba6cad), Integer($14015C4F), Integer($63066CD9), Integer($FA0F3D63), Integer($8D080DF5),
Integer($edb88320),Integer($9abfb3b6),Integer($03b6e20c),Integer($74b1d29a), Integer($3B6E20C8), Integer($4C69105E), Integer($D56041E4), Integer($A2677172),
Integer($ead54739),Integer($9dd277af),Integer($04db2615),Integer($73dc1683), Integer($3C03E4D1), Integer($4B04D447), Integer($D20D85FD), Integer($A50AB56B),
Integer($e3630b12),Integer($94643b84),Integer($0d6d6a3e),Integer($7a6a5aa8), Integer($35B5A8FA), Integer($42B2986C), Integer($DBBBC9D6), Integer($ACBCF940),
Integer($e40ecf0b),Integer($9309ff9d),Integer($0a00ae27),Integer($7d079eb1), Integer($32D86CE3), Integer($45DF5C75), Integer($DCD60DCF), Integer($ABD13D59),
Integer($f00f9344),Integer($8708a3d2),Integer($1e01f268),Integer($6906c2fe), Integer($26D930AC), Integer($51DE003A), Integer($C8D75180), Integer($BFD06116),
Integer($f762575d),Integer($806567cb),Integer($196c3671),Integer($6e6b06e7), Integer($21B4F4B5), Integer($56B3C423), Integer($CFBA9599), Integer($B8BDA50F),
Integer($fed41b76),Integer($89d32be0),Integer($10da7a5a),Integer($67dd4acc), Integer($2802B89E), Integer($5F058808), Integer($C60CD9B2), Integer($B10BE924),
Integer($f9b9df6f),Integer($8ebeeff9),Integer($17b7be43),Integer($60b08ed5), Integer($2F6F7C87), Integer($58684C11), Integer($C1611DAB), Integer($B6662D3D),
Integer($d6d6a3e8),Integer($a1d1937e),Integer($38d8c2c4),Integer($4fdff252), Integer($76DC4190), Integer($01DB7106), Integer($98D220BC), Integer($EFD5102A),
Integer($d1bb67f1),Integer($a6bc5767),Integer($3fb506dd),Integer($48b2364b), Integer($71B18589), Integer($06B6B51F), Integer($9FBFE4A5), Integer($E8B8D433),
Integer($d80d2bda),Integer($af0a1b4c),Integer($36034af6),Integer($41047a60), Integer($7807C9A2), Integer($0F00F934), Integer($9609A88E), Integer($E10E9818),
Integer($df60efc3),Integer($a867df55),Integer($316e8eef),Integer($4669be79), Integer($7F6A0DBB), Integer($086D3D2D), Integer($91646C97), Integer($E6635C01),
Integer($cb61b38c),Integer($bc66831a),Integer($256fd2a0),Integer($5268e236), Integer($6B6B51F4), Integer($1C6C6162), Integer($856530D8), Integer($F262004E),
Integer($cc0c7795),Integer($bb0b4703),Integer($220216b9),Integer($5505262f), Integer($6C0695ED), Integer($1B01A57B), Integer($8208F4C1), Integer($F50FC457),
Integer($c5ba3bbe),Integer($b2bd0b28),Integer($2bb45a92),Integer($5cb36a04), Integer($65B0D9C6), Integer($12B7E950), Integer($8BBEB8EA), Integer($FCB9887C),
Integer($c2d7ffa7),Integer($b5d0cf31),Integer($2cd99e8b),Integer($5bdeae1d), Integer($62DD1DDF), Integer($15DA2D49), Integer($8CD37CF3), Integer($FBD44C65),
Integer($9b64c2b0),Integer($ec63f226),Integer($756aa39c),Integer($026d930a), Integer($4DB26158), Integer($3AB551CE), Integer($A3BC0074), Integer($D4BB30E2),
Integer($9c0906a9),Integer($eb0e363f),Integer($72076785),Integer($05005713), Integer($4ADFA541), Integer($3DD895D7), Integer($A4D1C46D), Integer($D3D6F4FB),
Integer($95bf4a82),Integer($e2b87a14),Integer($7bb12bae),Integer($0cb61b38), Integer($4369E96A), Integer($346ED9FC), Integer($AD678846), Integer($DA60B8D0),
Integer($92d28e9b),Integer($e5d5be0d),Integer($7cdcefb7),Integer($0bdbdf21), Integer($44042D73), Integer($33031DE5), Integer($AA0A4C5F), Integer($DD0D7CC9),
Integer($86d3d2d4),Integer($f1d4e242),Integer($68ddb3f8),Integer($1fda836e), Integer($5005713C), Integer($270241AA), Integer($BE0B1010), Integer($C90C2086),
Integer($81be16cd),Integer($f6b9265b),Integer($6fb077e1),Integer($18b74777), Integer($5768B525), Integer($206F85B3), Integer($B966D409), Integer($CE61E49F),
Integer($88085ae6),Integer($ff0f6a70),Integer($66063bca),Integer($11010b5c), Integer($5EDEF90E), Integer($29D9C998), Integer($B0D09822), Integer($C7D7A8B4),
Integer($8f659eff),Integer($f862ae69),Integer($616bffd3),Integer($166ccf45), Integer($59B33D17), Integer($2EB40D81), Integer($B7BD5C3B), Integer($C0BA6CAD),
Integer($a00ae278),Integer($d70dd2ee),Integer($4e048354),Integer($3903b3c2), Integer($EDB88320), Integer($9ABFB3B6), Integer($03B6E20C), Integer($74B1D29A),
Integer($a7672661),Integer($d06016f7),Integer($4969474d),Integer($3e6e77db), Integer($EAD54739), Integer($9DD277AF), Integer($04DB2615), Integer($73DC1683),
Integer($aed16a4a),Integer($d9d65adc),Integer($40df0b66),Integer($37d83bf0), Integer($E3630B12), Integer($94643B84), Integer($0D6D6A3E), Integer($7A6A5AA8),
Integer($a9bcae53),Integer($debb9ec5),Integer($47b2cf7f),Integer($30b5ffe9), Integer($E40ECF0B), Integer($9309FF9D), Integer($0A00AE27), Integer($7D079EB1),
Integer($bdbdf21c),Integer($cabac28a),Integer($53b39330),Integer($24b4a3a6), Integer($F00F9344), Integer($8708A3D2), Integer($1E01F268), Integer($6906C2FE),
Integer($bad03605),Integer($cdd70693),Integer($54de5729),Integer($23d967bf), Integer($F762575D), Integer($806567CB), Integer($196C3671), Integer($6E6B06E7),
Integer($b3667a2e),Integer($c4614ab8),Integer($5d681b02),Integer($2a6f2b94), Integer($FED41B76), Integer($89D32BE0), Integer($10DA7A5A), Integer($67DD4ACC),
Integer($b40bbe37),Integer($c30c8ea1),Integer($5a05df1b),Integer($2d02ef8d) 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 = ( Crc16Tab: array[0..255] of Word = (
$0000, $1189, $2312, $329b, $4624, $57ad, $6536, $74bf, $0000, $1189, $2312, $329B, $4624, $57AD, $6536, $74BF,
$8c48, $9dc1, $af5a, $bed3, $ca6c, $dbe5, $e97e, $f8f7, $8C48, $9DC1, $AF5A, $BED3, $CA6C, $DBE5, $E97E, $F8F7,
$1081, $0108, $3393, $221a, $56a5, $472c, $75b7, $643e, $1081, $0108, $3393, $221A, $56A5, $472C, $75B7, $643E,
$9cc9, $8d40, $bfdb, $ae52, $daed, $cb64, $f9ff, $e876, $9CC9, $8D40, $BFDB, $AE52, $DAED, $CB64, $F9FF, $E876,
$2102, $308b, $0210, $1399, $6726, $76af, $4434, $55bd, $2102, $308B, $0210, $1399, $6726, $76AF, $4434, $55BD,
$ad4a, $bcc3, $8e58, $9fd1, $eb6e, $fae7, $c87c, $d9f5, $AD4A, $BCC3, $8E58, $9FD1, $EB6E, $FAE7, $C87C, $D9F5,
$3183, $200a, $1291, $0318, $77a7, $662e, $54b5, $453c, $3183, $200A, $1291, $0318, $77A7, $662E, $54B5, $453C,
$bdcb, $ac42, $9ed9, $8f50, $fbef, $ea66, $d8fd, $c974, $BDCB, $AC42, $9ED9, $8F50, $FBEF, $EA66, $D8FD, $C974,
$4204, $538d, $6116, $709f, $0420, $15a9, $2732, $36bb, $4204, $538D, $6116, $709F, $0420, $15A9, $2732, $36BB,
$ce4c, $dfc5, $ed5e, $fcd7, $8868, $99e1, $ab7a, $baf3, $CE4C, $DFC5, $ED5E, $FCD7, $8868, $99E1, $AB7A, $BAF3,
$5285, $430c, $7197, $601e, $14a1, $0528, $37b3, $263a, $5285, $430C, $7197, $601E, $14A1, $0528, $37B3, $263A,
$decd, $cf44, $fddf, $ec56, $98e9, $8960, $bbfb, $aa72, $DECD, $CF44, $FDDF, $EC56, $98E9, $8960, $BBFB, $AA72,
$6306, $728f, $4014, $519d, $2522, $34ab, $0630, $17b9, $6306, $728F, $4014, $519D, $2522, $34AB, $0630, $17B9,
$ef4e, $fec7, $cc5c, $ddd5, $a96a, $b8e3, $8a78, $9bf1, $EF4E, $FEC7, $CC5C, $DDD5, $A96A, $B8E3, $8A78, $9BF1,
$7387, $620e, $5095, $411c, $35a3, $242a, $16b1, $0738, $7387, $620E, $5095, $411C, $35A3, $242A, $16B1, $0738,
$ffcf, $ee46, $dcdd, $cd54, $b9eb, $a862, $9af9, $8b70, $FFCF, $EE46, $DCDD, $CD54, $B9EB, $A862, $9AF9, $8B70,
$8408, $9581, $a71a, $b693, $c22c, $d3a5, $e13e, $f0b7, $8408, $9581, $A71A, $B693, $C22C, $D3A5, $E13E, $F0B7,
$0840, $19c9, $2b52, $3adb, $4e64, $5fed, $6d76, $7cff, $0840, $19C9, $2B52, $3ADB, $4E64, $5FED, $6D76, $7CFF,
$9489, $8500, $b79b, $a612, $d2ad, $c324, $f1bf, $e036, $9489, $8500, $B79B, $A612, $D2AD, $C324, $F1BF, $E036,
$18c1, $0948, $3bd3, $2a5a, $5ee5, $4f6c, $7df7, $6c7e, $18C1, $0948, $3BD3, $2A5A, $5EE5, $4F6C, $7DF7, $6C7E,
$a50a, $b483, $8618, $9791, $e32e, $f2a7, $c03c, $d1b5, $A50A, $B483, $8618, $9791, $E32E, $F2A7, $C03C, $D1B5,
$2942, $38cb, $0a50, $1bd9, $6f66, $7eef, $4c74, $5dfd, $2942, $38CB, $0A50, $1BD9, $6F66, $7EEF, $4C74, $5DFD,
$b58b, $a402, $9699, $8710, $f3af, $e226, $d0bd, $c134, $B58B, $A402, $9699, $8710, $F3AF, $E226, $D0BD, $C134,
$39c3, $284a, $1ad1, $0b58, $7fe7, $6e6e, $5cf5, $4d7c, $39C3, $284A, $1AD1, $0B58, $7FE7, $6E6E, $5CF5, $4D7C,
$c60c, $d785, $e51e, $f497, $8028, $91a1, $a33a, $b2b3, $C60C, $D785, $E51E, $F497, $8028, $91A1, $A33A, $B2B3,
$4a44, $5bcd, $6956, $78df, $0c60, $1de9, $2f72, $3efb, $4A44, $5BCD, $6956, $78DF, $0C60, $1DE9, $2F72, $3EFB,
$d68d, $c704, $f59f, $e416, $90a9, $8120, $b3bb, $a232, $D68D, $C704, $F59F, $E416, $90A9, $8120, $B3BB, $A232,
$5ac5, $4b4c, $79d7, $685e, $1ce1, $0d68, $3ff3, $2e7a, $5AC5, $4B4C, $79D7, $685E, $1CE1, $0D68, $3FF3, $2E7A,
$e70e, $f687, $c41c, $d595, $a12a, $b0a3, $8238, $93b1, $E70E, $F687, $C41C, $D595, $A12A, $B0A3, $8238, $93B1,
$6b46, $7acf, $4854, $59dd, $2d62, $3ceb, $0e70, $1ff9, $6B46, $7ACF, $4854, $59DD, $2D62, $3CEB, $0E70, $1FF9,
$f78f, $e606, $d49d, $c514, $b1ab, $a022, $92b9, $8330, $F78F, $E606, $D49D, $C514, $B1AB, $A022, $92B9, $8330,
$7bc7, $6a4e, $58d5, $495c, $3de3, $2c6a, $1ef1, $0f78 $7BC7, $6A4E, $58D5, $495C, $3DE3, $2C6A, $1EF1, $0F78
); );
type type
TMD5Ctx = record TMD5Ctx = record
State: array[0..3] of integer; State: array[0..3] of Integer;
Count: array[0..1] of integer; Count: array[0..1] of Integer;
case Integer of case Integer of
0: (BufChar: array[0..63] of Byte); 0: (BufChar: array[0..63] of Byte);
1: (BufLong: array[0..15] of integer); 1: (BufLong: array[0..15] of Integer);
end; 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 var
x:integer; x: Integer;
c:char; c: Char;
s: string; s: string;
begin begin
result:=''; Result := '';
x := 1; x := 1;
while x<=length(value) do while x <= Length(Value) do
begin begin
c:=value[x]; c := Value[x];
inc(x); Inc(x);
if c<>limiter if c <> Delimiter then
then result:=result+c Result := Result + c
else else
if x<length(value) if x < Length(Value) then
then
begin begin
s:=copy(value,x,2); s := Copy(Value, x, 2);
inc(x,2); Inc(x, 2);
result:=result+char(strtointdef('$'+s,32)); if pos(#13, s) + pos(#10, s) = 0 then
Result := Result + Char(StrToIntDef('$' + s, 32));
end; end;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{DecodeQuotedPrintable} {DecodeQuotedPrintable}
function DecodeQuotedPrintable(value:string):string;
function DecodeQuotedPrintable(const Value: string): string;
begin begin
Result := DecodeTriplet(Value, '='); Result := DecodeTriplet(Value, '=');
end; end;
{==============================================================================} {==============================================================================}
{DecodeURL}
function DecodeURL(value:string):string; function DecodeURL(const Value: string): string;
begin begin
Result := DecodeTriplet(Value, '%'); Result := DecodeTriplet(Value, '%');
end; end;
{==============================================================================} {==============================================================================}
{EncodeTriplet}
function EncodeTriplet(value:string;limiter:char;specials:TSpecials):string; function EncodeTriplet(const Value: string; Delimiter: Char;
Specials: TSpecials): string;
var var
n:integer; n: Integer;
s: string; s: string;
begin begin
result:=''; Result := '';
for n:=1 to length(value) do for n := 1 to Length(Value) do
begin begin
s:=value[n]; s := Value[n];
if s[1] in Specials if s[1] in Specials then
then s:=limiter+inttohex(ord(s[1]),2); s := Delimiter + IntToHex(Ord(s[1]), 2);
result:=result+s; Result := Result + s;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{EncodeQuotedPrintable}
function EncodeQuotedPrintable(value:string):string; function EncodeQuotedPrintable(const Value: string): string;
begin 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; end;
{==============================================================================} {==============================================================================}
{EncodeURLElement}
function EncodeURLElement(value:string):string; function EncodeURLElement(const Value: string): string;
begin begin
Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar); Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar);
end; end;
{==============================================================================} {==============================================================================}
{EncodeURL}
function EncodeURL(value:string):string; function EncodeURL(const Value: string): string;
begin begin
Result := EncodeTriplet(Value, '%', URLSpecialChar); Result := EncodeTriplet(Value, '%', URLSpecialChar);
end; end;
{==============================================================================} {==============================================================================}
{Decode4to3}
function Decode4to3(value,table:string):string; function Decode4to3(const Value, Table: string): string;
var var
x,y,n:integer; x, y, n: Integer;
d: array[0..3] of byte; d: array[0..3] of Byte;
begin begin
result:=''; Result := '';
x := 1; x := 1;
while x<length(value) do while x < Length(Value) do
begin begin
for n := 0 to 3 do for n := 0 to 3 do
begin begin
if x>length(value) if x > Length(Value) then
then d[n]:=64 d[n] := 64
else else
begin begin
y:=pos(value[x],table); y := Pos(Value[x], Table);
if y<1 then y:=65; if y < 1 then
y := 65;
d[n] := y - 1; d[n] := y - 1;
end; end;
inc(x); Inc(x);
end; 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 if d[2] <> 64 then
begin 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 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; end;
end; end;
{==============================================================================} {==============================================================================}
{DecodeBase64}
function DecodeBase64(value:string):string; function DecodeBase64(const Value: string): string;
begin begin
result:=Decode4to3(value,TableBase64); Result := Decode4to3(Value, TableBase64);
end; end;
{==============================================================================} {==============================================================================}
{EncodeBase64}
function EncodeBase64(value:string):string; function EncodeBase64(const Value: string): string;
var var
c:byte; c: Byte;
n:integer; n: Integer;
Count:integer; Count: Integer;
DOut:array [0..3] of byte; DOut: array[0..3] of Byte;
begin begin
result:=''; Result := '';
Count := 1; Count := 1;
while count<=length(value) do while Count <= Length(Value) do
begin begin
c:=ord(value[count]); c := Ord(Value[Count]);
inc(count); Inc(Count);
DOut[0] := (c and $FC) shr 2; DOut[0] := (c and $FC) shr 2;
DOut[1] := (c and $03) shl 4; DOut[1] := (c and $03) shl 4;
if count<=length(value) if Count <= Length(Value) then
then
begin begin
c:=ord(value[count]); c := Ord(Value[Count]);
inc(count); Inc(Count);
DOut[1] := DOut[1] + (c and $F0) shr 4; DOut[1] := DOut[1] + (c and $F0) shr 4;
DOut[2] := (c and $0F) shl 2; DOut[2] := (c and $0F) shl 2;
if count<=length(value) if Count <= Length(Value) then
then
begin begin
c:=ord(value[count]); c := Ord(Value[Count]);
inc(count); Inc(Count);
DOut[2] := DOut[2] + (c and $C0) shr 6; DOut[2] := DOut[2] + (c and $C0) shr 6;
DOut[3] := (c and $3F); DOut[3] := (c and $3F);
end end
@ -346,103 +353,113 @@ begin
DOut[3] := $40; DOut[3] := $40;
end; end;
for n := 0 to 3 do for n := 0 to 3 do
result:=result+TableBase64[DOut[n]+1]; Result := Result + TableBase64[DOut[n] + 1];
end; end;
end; end;
{==============================================================================} {==============================================================================}
{DecodeUU}
function DecodeUU(value:string):string; function DecodeUU(const Value: string): string;
var var
s: string; s: string;
uut: string; uut: string;
x:integer; x: Integer;
begin begin
result:=''; Result := '';
uut := TableUU; uut := TableUU;
s:=trim(uppercase(value)); s := trim(UpperCase(Value));
if s='' then exit; if s = '' then Exit;
if pos('BEGIN',s)=1 then exit; if Pos('BEGIN', s) = 1 then
if pos('END',s)=1 then exit; Exit;
if pos('TABLE',s)=1 then exit; //ignore table yet (set custom UUT) if Pos('END', s) = 1 then
Exit;
if Pos('TABLE', s) = 1 then
Exit; //ignore Table yet (set custom UUT)
//begin decoding //begin decoding
x:=pos(value[1],uut)-1; x := Pos(Value[1], uut) - 1;
x:=round((x/3)*4); x := Round((x / 3) * 4);
//x - lenght UU line //x - lenght UU line
s:=copy(value,2,x); s := Copy(Value, 2, x);
if s='' then exit; if s = '' then
result:=Decode4to3(s,uut); Exit;
Result := Decode4to3(s, uut);
end; end;
{==============================================================================} {==============================================================================}
{DecodeXX}
function DecodeXX(value:string):string; function DecodeXX(const Value: string): string;
var var
s: string; s: string;
x:integer; x: Integer;
begin begin
result:=''; Result := '';
s:=trim(uppercase(value)); s := trim(UpperCase(Value));
if s='' then exit; if s = '' then
if pos('BEGIN',s)=1 then exit; Exit;
if pos('END',s)=1 then exit; if Pos('BEGIN', s) = 1 then
Exit;
if Pos('END', s) = 1 then
Exit;
//begin decoding //begin decoding
x:=pos(value[1],TableXX)-1; x := Pos(Value[1], TableXX) - 1;
x:=round((x/3)*4); x := Round((x / 3) * 4);
//x - lenght XX line //x - lenght XX line
s:=copy(value,2,x); s := Copy(Value, 2, x);
if s='' then exit; if s = '' then
result:=Decode4to3(s,TableXX); Exit;
Result := Decode4to3(s, TableXX);
end; end;
{==============================================================================} {==============================================================================}
{UpdateCrc32}
function UpdateCrc32(value:byte;crc32:integer):integer; function UpdateCrc32(Value: Byte; Crc32: Integer): Integer;
begin begin
result:=((crc32 shr 8) and Integer($00FFFFFF)) Result := ((Crc32 shr 8) and Integer($00FFFFFF)) xor
xor crc32tab[byte(crc32 XOR integer(value)) and Integer($000000FF)]; crc32tab[Byte(Crc32 xor Integer(Value)) and Integer($000000FF)];
end; end;
{==============================================================================} {==============================================================================}
{Crc32}
function Crc32(value:string):integer; function Crc32(const Value: string): Integer;
var var
n:integer; n: Integer;
begin begin
result:=Integer($FFFFFFFF); Result := Integer($FFFFFFFF);
for n:=1 to length(value) do for n := 1 to Length(Value) do
result:=UpdateCrc32(ord(value[n]), result); Result := UpdateCrc32(Ord(Value[n]), Result);
end; end;
{==============================================================================} {==============================================================================}
{UpdateCrc16}
function UpdateCrc16(value:byte;crc16:word):word; function UpdateCrc16(Value: Byte; Crc16: Word): Word;
begin begin
result:=((crc16 shr 8) and $00FF) Result := ((Crc16 shr 8) and $00FF) xor
xor crc16tab[byte(crc16 XOR (word(value)) and $00FF)]; crc16tab[Byte(Crc16 xor (Word(Value)) and $00FF)];
end; end;
{==============================================================================} {==============================================================================}
{Crc16}
function Crc16(value:string):word; function Crc16(const Value: string): Word;
var var
n:integer; n: Integer;
begin begin
result:=$FFFF; Result := $FFFF;
for n:=1 to length(value) do for n := 1 to Length(Value) do
result:=UpdateCrc16(ord(value[n]), result); Result := UpdateCrc16(Ord(Value[n]), Result);
end; end;
{==============================================================================} {==============================================================================}
procedure MD5Init(var MD5Context: TMD5Ctx); procedure MD5Init(var MD5Context: TMD5Ctx);
begin begin
FillChar(MD5Context, SizeOf(TMD5Ctx), #0); FillChar(MD5Context, SizeOf(TMD5Ctx), #0);
with MD5Context do begin with MD5Context do
begin
State[0] := Integer($67452301); State[0] := Integer($67452301);
State[1] := Integer($EFCDAB89); State[1] := Integer($EFCDAB89);
State[2] := Integer($98BADCFE); State[2] := Integer($98BADCFE);
State[3] := Integer($10325476); State[3] := Integer($10325476);
end end;
end; end;
procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt);
@ -453,28 +470,28 @@ var
begin begin
Inc(W, (Z xor (X and (Y xor Z))) + Data); Inc(W, (Z xor (X and (Y xor Z))) + Data);
W := (W shl S) or (W shr (32 - S)); W := (W shl S) or (W shr (32 - S));
Inc(W, X) Inc(W, X);
end; end;
procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
begin begin
Inc(W, (Y xor (Z and (X xor Y))) + Data); Inc(W, (Y xor (Z and (X xor Y))) + Data);
W := (W shl S) or (W shr (32 - S)); W := (W shl S) or (W shr (32 - S));
Inc(W, X) Inc(W, X);
end; end;
procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
begin begin
Inc(W, (X xor Y xor Z) + Data); Inc(W, (X xor Y xor Z) + Data);
W := (W shl S) or (W shr (32 - S)); W := (W shl S) or (W shr (32 - S));
Inc(W, X) Inc(W, X);
end; end;
procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte);
begin begin
Inc(W, (Y xor (X or not Z)) + Data); Inc(W, (Y xor (X or not Z)) + Data);
W := (W shl S) or (W shr (32 - S)); W := (W shl S) or (W shr (32 - S));
Inc(W, X) Inc(W, X);
end; end;
begin begin
A := Buf[0]; A := Buf[0];
@ -482,73 +499,73 @@ begin
C := Buf[2]; C := Buf[2];
D := Buf[3]; D := Buf[3];
Round1(A,B,C,D, Data[ 0] + longint($d76aa478), 7); Round1(A, B, C, D, Data[0] + Longint($D76AA478), 7);
Round1(D,A,B,C, Data[ 1] + longint($e8c7b756), 12); Round1(D, A, B, C, Data[1] + Longint($E8C7B756), 12);
Round1(C,D,A,B, Data[ 2] + longint($242070db), 17); Round1(C, D, A, B, Data[2] + Longint($242070DB), 17);
Round1(B,C,D,A, Data[ 3] + longint($c1bdceee), 22); Round1(B, C, D, A, Data[3] + Longint($C1BDCEEE), 22);
Round1(A,B,C,D, Data[ 4] + longint($f57c0faf), 7); Round1(A, B, C, D, Data[4] + Longint($F57C0FAF), 7);
Round1(D,A,B,C, Data[ 5] + longint($4787c62a), 12); Round1(D, A, B, C, Data[5] + Longint($4787C62A), 12);
Round1(C,D,A,B, Data[ 6] + longint($a8304613), 17); Round1(C, D, A, B, Data[6] + Longint($A8304613), 17);
Round1(B,C,D,A, Data[ 7] + longint($fd469501), 22); Round1(B, C, D, A, Data[7] + Longint($FD469501), 22);
Round1(A,B,C,D, Data[ 8] + longint($698098d8), 7); Round1(A, B, C, D, Data[8] + Longint($698098D8), 7);
Round1(D,A,B,C, Data[ 9] + longint($8b44f7af), 12); Round1(D, A, B, C, Data[9] + Longint($8B44F7AF), 12);
Round1(C,D,A,B, Data[10] + longint($ffff5bb1), 17); Round1(C, D, A, B, Data[10] + Longint($FFFF5BB1), 17);
Round1(B,C,D,A, Data[11] + longint($895cd7be), 22); Round1(B, C, D, A, Data[11] + Longint($895CD7BE), 22);
Round1(A,B,C,D, Data[12] + longint($6b901122), 7); Round1(A, B, C, D, Data[12] + Longint($6B901122), 7);
Round1(D,A,B,C, Data[13] + longint($fd987193), 12); Round1(D, A, B, C, Data[13] + Longint($FD987193), 12);
Round1(C,D,A,B, Data[14] + longint($a679438e), 17); Round1(C, D, A, B, Data[14] + Longint($A679438E), 17);
Round1(B,C,D,A, Data[15] + longint($49b40821), 22); Round1(B, C, D, A, Data[15] + Longint($49B40821), 22);
Round2(A,B,C,D, Data[ 1] + longint($f61e2562), 5); Round2(A, B, C, D, Data[1] + Longint($F61E2562), 5);
Round2(D,A,B,C, Data[ 6] + longint($c040b340), 9); Round2(D, A, B, C, Data[6] + Longint($C040B340), 9);
Round2(C,D,A,B, Data[11] + longint($265e5a51), 14); Round2(C, D, A, B, Data[11] + Longint($265E5A51), 14);
Round2(B,C,D,A, Data[ 0] + longint($e9b6c7aa), 20); Round2(B, C, D, A, Data[0] + Longint($E9B6C7AA), 20);
Round2(A,B,C,D, Data[ 5] + longint($d62f105d), 5); Round2(A, B, C, D, Data[5] + Longint($D62F105D), 5);
Round2(D,A,B,C, Data[10] + longint($02441453), 9); Round2(D, A, B, C, Data[10] + Longint($02441453), 9);
Round2(C,D,A,B, Data[15] + longint($d8a1e681), 14); Round2(C, D, A, B, Data[15] + Longint($D8A1E681), 14);
Round2(B,C,D,A, Data[ 4] + longint($e7d3fbc8), 20); Round2(B, C, D, A, Data[4] + Longint($E7D3FBC8), 20);
Round2(A,B,C,D, Data[ 9] + longint($21e1cde6), 5); Round2(A, B, C, D, Data[9] + Longint($21E1CDE6), 5);
Round2(D,A,B,C, Data[14] + longint($c33707d6), 9); Round2(D, A, B, C, Data[14] + Longint($C33707D6), 9);
Round2(C,D,A,B, Data[ 3] + longint($f4d50d87), 14); Round2(C, D, A, B, Data[3] + Longint($F4D50D87), 14);
Round2(B,C,D,A, Data[ 8] + longint($455a14ed), 20); Round2(B, C, D, A, Data[8] + Longint($455A14ED), 20);
Round2(A,B,C,D, Data[13] + longint($a9e3e905), 5); Round2(A, B, C, D, Data[13] + Longint($A9E3E905), 5);
Round2(D,A,B,C, Data[ 2] + longint($fcefa3f8), 9); Round2(D, A, B, C, Data[2] + Longint($FCEFA3F8), 9);
Round2(C,D,A,B, Data[ 7] + longint($676f02d9), 14); Round2(C, D, A, B, Data[7] + Longint($676F02D9), 14);
Round2(B,C,D,A, Data[12] + longint($8d2a4c8a), 20); Round2(B, C, D, A, Data[12] + Longint($8D2A4C8A), 20);
Round3(A,B,C,D, Data[ 5] + longint($fffa3942), 4); Round3(A, B, C, D, Data[5] + Longint($FFFA3942), 4);
Round3(D,A,B,C, Data[ 8] + longint($8771f681), 11); Round3(D, A, B, C, Data[8] + Longint($8771F681), 11);
Round3(C,D,A,B, Data[11] + longint($6d9d6122), 16); Round3(C, D, A, B, Data[11] + Longint($6D9D6122), 16);
Round3(B,C,D,A, Data[14] + longint($fde5380c), 23); Round3(B, C, D, A, Data[14] + Longint($FDE5380C), 23);
Round3(A,B,C,D, Data[ 1] + longint($a4beea44), 4); Round3(A, B, C, D, Data[1] + Longint($A4BEEA44), 4);
Round3(D,A,B,C, Data[ 4] + longint($4bdecfa9), 11); Round3(D, A, B, C, Data[4] + Longint($4BDECFA9), 11);
Round3(C,D,A,B, Data[ 7] + longint($f6bb4b60), 16); Round3(C, D, A, B, Data[7] + Longint($F6BB4B60), 16);
Round3(B,C,D,A, Data[10] + longint($bebfbc70), 23); Round3(B, C, D, A, Data[10] + Longint($BEBFBC70), 23);
Round3(A,B,C,D, Data[13] + longint($289b7ec6), 4); Round3(A, B, C, D, Data[13] + Longint($289B7EC6), 4);
Round3(D,A,B,C, Data[ 0] + longint($eaa127fa), 11); Round3(D, A, B, C, Data[0] + Longint($EAA127FA), 11);
Round3(C,D,A,B, Data[ 3] + longint($d4ef3085), 16); Round3(C, D, A, B, Data[3] + Longint($D4EF3085), 16);
Round3(B,C,D,A, Data[ 6] + longint($04881d05), 23); Round3(B, C, D, A, Data[6] + Longint($04881D05), 23);
Round3(A,B,C,D, Data[ 9] + longint($d9d4d039), 4); Round3(A, B, C, D, Data[9] + Longint($D9D4D039), 4);
Round3(D,A,B,C, Data[12] + longint($e6db99e5), 11); Round3(D, A, B, C, Data[12] + Longint($E6DB99E5), 11);
Round3(C,D,A,B, Data[15] + longint($1fa27cf8), 16); Round3(C, D, A, B, Data[15] + Longint($1FA27CF8), 16);
Round3(B,C,D,A, Data[ 2] + longint($c4ac5665), 23); Round3(B, C, D, A, Data[2] + Longint($C4AC5665), 23);
Round4(A,B,C,D, Data[ 0] + longint($f4292244), 6); Round4(A, B, C, D, Data[0] + Longint($F4292244), 6);
Round4(D,A,B,C, Data[ 7] + longint($432aff97), 10); Round4(D, A, B, C, Data[7] + Longint($432AFF97), 10);
Round4(C,D,A,B, Data[14] + longint($ab9423a7), 15); Round4(C, D, A, B, Data[14] + Longint($AB9423A7), 15);
Round4(B,C,D,A, Data[ 5] + longint($fc93a039), 21); Round4(B, C, D, A, Data[5] + Longint($FC93A039), 21);
Round4(A,B,C,D, Data[12] + longint($655b59c3), 6); Round4(A, B, C, D, Data[12] + Longint($655B59C3), 6);
Round4(D,A,B,C, Data[ 3] + longint($8f0ccc92), 10); Round4(D, A, B, C, Data[3] + Longint($8F0CCC92), 10);
Round4(C,D,A,B, Data[10] + longint($ffeff47d), 15); Round4(C, D, A, B, Data[10] + Longint($FFEFF47D), 15);
Round4(B,C,D,A, Data[ 1] + longint($85845dd1), 21); Round4(B, C, D, A, Data[1] + Longint($85845DD1), 21);
Round4(A,B,C,D, Data[ 8] + longint($6fa87e4f), 6); Round4(A, B, C, D, Data[8] + Longint($6FA87E4F), 6);
Round4(D,A,B,C, Data[15] + longint($fe2ce6e0), 10); Round4(D, A, B, C, Data[15] + Longint($FE2CE6E0), 10);
Round4(C,D,A,B, Data[ 6] + longint($a3014314), 15); Round4(C, D, A, B, Data[6] + Longint($A3014314), 15);
Round4(B,C,D,A, Data[13] + longint($4e0811a1), 21); Round4(B, C, D, A, Data[13] + Longint($4E0811A1), 21);
Round4(A,B,C,D, Data[ 4] + longint($f7537e82), 6); Round4(A, B, C, D, Data[4] + Longint($F7537E82), 6);
Round4(D,A,B,C, Data[11] + longint($bd3af235), 10); Round4(D, A, B, C, Data[11] + Longint($BD3AF235), 10);
Round4(C,D,A,B, Data[ 2] + longint($2ad7d2bb), 15); Round4(C, D, A, B, Data[2] + Longint($2AD7D2BB), 15);
Round4(B,C,D,A, Data[ 9] + longint($eb86d391), 21); Round4(B, C, D, A, Data[9] + Longint($EB86D391), 21);
Inc(Buf[0], A); Inc(Buf[0], A);
Inc(Buf[1], B); Inc(Buf[1], B);
@ -558,9 +575,9 @@ end;
procedure MD5Update(var MD5Context: TMD5Ctx; const Data: string); procedure MD5Update(var MD5Context: TMD5Ctx; const Data: string);
var var
Index,t,len:integer; Index, t, len: Integer;
begin begin
len:=length(data); len := Length(Data);
with MD5Context do with MD5Context do
begin begin
T := Count[0]; T := Count[0];
@ -600,7 +617,7 @@ var
Cnt: Word; Cnt: Word;
P: Byte; P: Byte;
digest: array[0..15] of Char; digest: array[0..15] of Char;
i:integer; i: Integer;
begin begin
for I := 0 to 15 do for I := 0 to 15 do
Byte(Digest[I]) := I + 1; Byte(Digest[I]) := I + 1;
@ -617,67 +634,59 @@ begin
MD5Transform(State, BufLong); MD5Transform(State, BufLong);
FillChar(BufChar, 56, #0); FillChar(BufChar, 56, #0);
end end
else fillChar(BufChar[P], Cnt-8, #0); else
FillChar(BufChar[P], Cnt - 8, #0);
BufLong[14] := Count[0]; BufLong[14] := Count[0];
BufLong[15] := Count[1]; BufLong[15] := Count[1];
MD5Transform(State, BufLong); MD5Transform(State, BufLong);
Move(State, Digest, 16); Move(State, Digest, 16);
result:=''; Result := '';
for i := 0 to 15 do for i := 0 to 15 do
result:=result+char(digest[i]); Result := Result + Char(digest[i]);
end; end;
FillChar(MD5Context, SizeOf(TMD5Ctx), #0) FillChar(MD5Context, SizeOf(TMD5Ctx), #0)
end; end;
{==============================================================================} {==============================================================================}
{MD5}
function MD5(value:string): string; function MD5(const Value: string): string;
var var
MD5Context: TMD5Ctx; MD5Context: TMD5Ctx;
begin begin
MD5Init(MD5Context); MD5Init(MD5Context);
MD5Update(MD5Context,value); MD5Update(MD5Context, Value);
result:=MD5Final(MD5Context); Result := MD5Final(MD5Context);
end; end;
{==============================================================================} {==============================================================================}
{HMAC_MD5}
function HMAC_MD5(text,key:string):string; function HMAC_MD5(Text, Key: string): string;
var var
ipad, opad, s: string; ipad, opad, s: string;
n:integer; n: Integer;
MD5Context: TMD5Ctx; MD5Context: TMD5Ctx;
begin begin
if length(key)>64 then if Length(Key) > 64 then
key:=md5(key); Key := md5(Key);
ipad := ''; ipad := '';
for n := 1 to 64 do for n := 1 to 64 do
ipad := ipad + #$36; ipad := ipad + #$36;
opad := ''; opad := '';
for n := 1 to 64 do for n := 1 to 64 do
opad:=opad+#$5c; opad := opad + #$5C;
for n:=1 to length(key) do for n := 1 to Length(Key) do
begin begin
ipad[n]:=char(byte(ipad[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])); opad[n] := Char(Byte(opad[n]) xor Byte(Key[n]));
end; end;
MD5Init(MD5Context); MD5Init(MD5Context);
MD5Update(MD5Context, ipad); MD5Update(MD5Context, ipad);
MD5Update(MD5Context,text); MD5Update(MD5Context, Text);
s := MD5Final(MD5Context); s := MD5Final(MD5Context);
MD5Init(MD5Context); MD5Init(MD5Context);
MD5Update(MD5Context, opad); MD5Update(MD5Context, opad);
MD5Update(MD5Context, s); MD5Update(MD5Context, s);
result:=MD5Final(MD5Context); Result := MD5Final(MD5Context);
end; end;
{==============================================================================}
begin
exit;
asm
db 'Synapse coding and decoding support library by Lukas Gebauer',0
end;
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 | | 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 | | (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, | | 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 | | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for |
@ -32,73 +32,79 @@ unit SynaUtil;
interface interface
uses uses
sysutils, classes, SysUtils, Classes,
{$IFDEF LINUX} {$IFDEF LINUX}
libc; Libc;
{$ELSE} {$ELSE}
windows; Windows;
{$ENDIF} {$ENDIF}
function timezone:string; function Timezone: string;
function Rfc822DateTime(t:TDateTime):String; function Rfc822DateTime(t: TDateTime): string;
function CodeInt(Value:word):string; function CodeInt(Value: Word): string;
function DeCodeInt(Value:string;Index:integer):word; function DecodeInt(const Value: string; Index: Integer): Word;
function IsIP(Value:string):Boolean; function IsIP(const Value: string): Boolean;
function ReverseIP(Value: string): string; function ReverseIP(Value: string): string;
procedure Dump (Buffer:string;DumpFile:string); procedure Dump(const Buffer, DumpFile: string);
function SeparateLeft(value,delimiter:string):string; function SeparateLeft(const Value, Delimiter: string): string;
function SeparateRight(value,delimiter:string):string; function SeparateRight(const Value, Delimiter: string): string;
function getparameter(value,parameter:string):string; function GetParameter(const Value, Parameter: string): string;
function GetEmailAddr(value:string):string; function GetEmailAddr(const Value: string): string;
function GetEmailDesc(value:string):string; function GetEmailDesc(Value: string): string;
function StrToHex(value:string):string; function StrToHex(const Value: string): string;
function IntToBin(value:integer;digits:byte):string; function IntToBin(Value: Integer; Digits: Byte): string;
function BinToInt(value:string):integer; function BinToInt(const Value: string): Integer;
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,
function StringReplace(value,search,replace:string):string; Para: string): string;
function StringReplace(Value, Search, Replace: string): string;
implementation implementation
{==============================================================================} {==============================================================================}
{timezone}
function timezone:string; function Timezone: string;
{$IFDEF LINUX} {$IFDEF LINUX}
var var
t: TTime_T; t: TTime_T;
UT: TUnixTime; UT: TUnixTime;
bias:integer; bias: Integer;
h,m:integer; h, m: Integer;
begin begin
__time(@T); __time(@T);
localtime_r(@T, UT); localtime_r(@T, UT);
bias := ut.__tm_gmtoff div 60; bias := ut.__tm_gmtoff div 60;
if bias>=0 then result:='+' if bias >= 0 then
else result:='-'; Result := '+'
else
Result := '-';
{$ELSE} {$ELSE}
var var
zoneinfo: TTimeZoneInformation; zoneinfo: TTimeZoneInformation;
bias:integer; bias: Integer;
h,m:integer; h, m: Integer;
begin begin
case GetTimeZoneInformation(Zoneinfo) of case GetTimeZoneInformation(Zoneinfo) of
2: bias:=zoneinfo.bias+zoneinfo.DaylightBias; 2:
1: bias:=zoneinfo.bias+zoneinfo.StandardBias; bias := zoneinfo.Bias + zoneinfo.DaylightBias;
1:
bias := zoneinfo.Bias + zoneinfo.StandardBias;
else else
bias:=zoneinfo.bias; bias := zoneinfo.Bias;
end; end;
if bias<=0 then result:='+' if bias <= 0 then
else result:='-'; Result := '+'
else
Result := '-';
{$ENDIF} {$ENDIF}
bias:=abs(bias); bias := Abs(bias);
h := bias div 60; h := bias div 60;
m := bias mod 60; m := bias mod 60;
result:=result+format('%.2d%.2d',[h,m]); Result := Result + Format('%.2d%.2d', [h, m]);
end; end;
{==============================================================================} {==============================================================================}
{Rfc822DateTime} function Rfc822DateTime(t: TDateTime): string;
function Rfc822DateTime(t:TDateTime):String;
var var
I: Integer; I: Integer;
SaveDayNames: array[1..7] of string; SaveDayNames: array[1..7] of string;
@ -111,8 +117,8 @@ const
'May', 'Jun', 'Jul', 'Aug', 'May', 'Jun', 'Jul', 'Aug',
'Sep', 'Oct', 'Nov', 'Dec'); 'Sep', 'Oct', 'Nov', 'Dec');
begin begin
if ShortDayNames[1] = MyDayNames[1] if ShortDayNames[1] = MyDayNames[1] then
then Result := FormatDateTime('ddd, d mmm yyyy hh:mm:ss', t) Result := FormatDateTime('ddd, d mmm yyyy hh:mm:ss', t)
else else
begin begin
for I := Low(ShortDayNames) to High(ShortDayNames) do 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 begin
Result := Chr(Hi(Value)) + Chr(Lo(Value)) Result := Chr(Hi(Value)) + Chr(Lo(Value))
end; end;
{==============================================================================} {==============================================================================}
{DeCodeInt} function DecodeInt(const Value: string; Index: Integer): Word;
function DeCodeInt(Value:string;Index:integer):word;
var var
x, y: Byte; x, y: Byte;
begin begin
if Length(Value)>index then x:=Ord(Value[index]) if Length(Value) > Index then
else x:=0; x := Ord(Value[Index])
if Length(Value)>(Index+1) then y:=Ord(Value[Index+1]) else
else y:=0; x := 0;
if Length(Value) > (Index + 1) then
y := Ord(Value[Index + 1])
else
y := 0;
Result := x * 256 + y; Result := x * 256 + y;
end; end;
{==============================================================================} {==============================================================================}
{IsIP} function IsIP(const Value: string): Boolean;
function IsIP(Value:string):Boolean;
var var
n,x:integer; n, x: Integer;
begin begin
Result := true; Result := true;
x := 0; x := 0;
for n := 1 to Length(Value) do for n := 1 to Length(Value) do
if not (Value[n] in ['0'..'9','.']) if not (Value[n] in ['0'..'9', '.']) then
then begin begin
Result := False; Result := False;
break; Break;
end end
else begin else
if Value[n]='.' then Inc(x); begin
if Value[n] = '.' then
Inc(x);
end; end;
if x<>3 then Result:=False; if x <> 3 then
Result := False;
end; end;
{==============================================================================} {==============================================================================}
{ReverseIP}
function ReverseIP(Value: string): string; function ReverseIP(Value: string): string;
var var
x:integer; x: Integer;
begin begin
Result := ''; Result := '';
repeat repeat
@ -197,263 +206,273 @@ end;
{==============================================================================} {==============================================================================}
{dump} procedure Dump(const Buffer, DumpFile: string);
procedure dump (Buffer:string;DumpFile:string);
var var
n:integer; n: Integer;
s: string; s: string;
f: Text; f: Text;
begin begin
s := ''; s := '';
for n := 1 to Length(Buffer) do for n := 1 to Length(Buffer) do
s := s + ' +#$' + IntToHex(Ord(Buffer[n]), 2); s := s + ' +#$' + IntToHex(Ord(Buffer[n]), 2);
Assignfile(f,DumpFile); AssignFile(f, DumpFile);
if fileexists(DumpFile) then deletefile(PChar(DumpFile)); if FileExists(DumpFile) then
rewrite(f); DeleteFile(PChar(DumpFile));
Rewrite(f);
try try
writeln(f,s); Writeln(f, s);
finally finally
closefile(f); CloseFile(f);
end; end;
end; end;
{==============================================================================} {==============================================================================}
{SeparateLeft}
function SeparateLeft(value,delimiter:string):string; function SeparateLeft(const Value, Delimiter: string): string;
var var
x:integer; x: Integer;
begin begin
x:=pos(delimiter,value); x := Pos(Delimiter, Value);
if x<1 if x < 1 then
then result:=trim(value) Result := Trim(Value)
else result:=trim(copy(value,1,x-1)); else
Result := Trim(Copy(Value, 1, x - 1));
end; end;
{==============================================================================} {==============================================================================}
{SeparateRight}
function SeparateRight(value,delimiter:string):string; function SeparateRight(const Value, Delimiter: string): string;
var var
x:integer; x: Integer;
begin begin
x:=pos(delimiter,value); x := Pos(Delimiter, Value);
if x>0 if x > 0 then
then x:=x+length(delimiter)-1; x := x + Length(Delimiter) - 1;
result:=trim(copy(value,x+1,length(value)-x)); Result := Trim(Copy(Value, x + 1, Length(Value) - x));
end; end;
{==============================================================================} {==============================================================================}
{GetParameter}
function getparameter(value,parameter:string):string; function GetParameter(const Value, Parameter: string): string;
var var
x,x1:integer; x, x1: Integer;
s: string; s: string;
begin begin
x:=pos(uppercase(parameter),uppercase(value)); x := Pos(UpperCase(Parameter), UpperCase(Value));
result:=''; Result := '';
if x > 0 then if x > 0 then
begin begin
s:=copy(value,x+length(parameter),length(value)-(x+length(parameter))+1); s := Copy(Value, x + Length(Parameter), Length(Value)
s:=trim(s); - (x + Length(Parameter)) + 1);
x1:=length(s); s := Trim(s);
if length(s)>1 then x1 := Length(s);
if Length(s) > 1 then
begin begin
if s[1]='"' if s[1] = '"' then
then
begin begin
s:=copy(s,2,length(s)-1); s := Copy(s, 2, Length(s) - 1);
x:=pos('"',s); x := Pos('"', s);
if x>0 then x1:=x-1; if x > 0 then
x1 := x - 1;
end end
else else
begin begin
x:=pos(' ',s); x := Pos(' ', s);
if x>0 then x1:=x-1; if x > 0 then
x1 := x - 1;
end; end;
end; end;
result:=copy(s,1,x1); Result := Copy(s, 1, x1);
end; end;
end; end;
{==============================================================================} {==============================================================================}
{GetEmailAddr}
function GetEmailAddr(value:string):string; function GetEmailAddr(const Value: string): string;
var var
s: string; s: string;
begin begin
s:=separateright(value,'<'); s := SeparateRight(Value, '<');
s:=separateleft(s,'>'); s := SeparateLeft(s, '>');
result:=trim(s); Result := Trim(s);
end; end;
{==============================================================================} {==============================================================================}
{GetEmailDesc}
function GetEmailDesc(value:string):string; function GetEmailDesc(Value: string): string;
var var
s: string; s: string;
begin begin
value:=trim(value); Value := Trim(Value);
s:=separateright(value,'"'); s := SeparateRight(Value, '"');
if s<>value if s <> Value then
then s:=separateleft(s,'"') s := SeparateLeft(s, '"')
else else
begin begin
s:=separateright(value,'('); s := SeparateRight(Value, '(');
if s<>value if s <> Value then
then s:=separateleft(s,')') s := SeparateLeft(s, ')')
else else
begin begin
s:=separateleft(value,'<'); s := SeparateLeft(Value, '<');
if s=value if s = Value then
then s:=''; s := '';
end; end;
end; end;
result:=trim(s); Result := Trim(s);
end; end;
{==============================================================================} {==============================================================================}
{StrToHex}
function StrToHex(value:string):string; function StrToHex(const Value: string): string;
var var
n:integer; n: Integer;
begin begin
result:=''; Result := '';
for n:=1 to length(value) do for n := 1 to Length(Value) do
Result:=Result+IntToHex(Byte(value[n]),2); Result := Result + IntToHex(Byte(Value[n]), 2);
result:=lowercase(result); Result := LowerCase(Result);
end; end;
{==============================================================================} {==============================================================================}
{IntToBin}
function IntToBin(value:integer;digits:byte):string; function IntToBin(Value: Integer; Digits: Byte): string;
var var
x,y,n:integer; x, y, n: Integer;
begin begin
result:=''; Result := '';
x:=value; x := Value;
repeat repeat
y := x mod 2; y := x mod 2;
x := x div 2; x := x div 2;
if y>0 if y > 0 then
then result:='1'+result Result := '1' + Result
else result:='0'+result; else
Result := '0' + Result;
until x = 0; until x = 0;
x:=length(result); x := Length(Result);
for n:=x to digits-1 do for n := x to Digits - 1 do
result:='0'+result; Result := '0' + Result;
end; end;
{==============================================================================} {==============================================================================}
{BinToInt}
function BinToInt(value:string):integer; function BinToInt(const Value: string): Integer;
var var
x,n:integer; n: Integer;
begin begin
result:=0; Result := 0;
for n:=1 to length(value) do for n := 1 to Length(Value) do
begin begin
if value[n]='0' if Value[n] = '0' then
then x:=0 Result := Result * 2
else x:=1; else
result:=result*2+x; if Value[n] = '1' then
Result := Result * 2 + 1
else
Break;
end; end;
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 var
x:integer; x: Integer;
sURL: string; sURL: string;
s: string; s: string;
s1, s2: string; s1, s2: string;
begin begin
prot:='http'; Prot := 'http';
user:=''; User := '';
pass:=''; Pass := '';
port:='80'; Port := '80';
para:=''; Para := '';
x:=pos('://',URL); x := Pos('://', URL);
if x > 0 then if x > 0 then
begin begin
prot:=separateleft(URL,'://'); Prot := SeparateLeft(URL, '://');
sURL:=separateright(URL,'://'); sURL := SeparateRight(URL, '://');
end end
else sURL:=URL; else
x:=pos('@',sURL); sURL := URL;
x := Pos('@', sURL);
if x > 0 then if x > 0 then
begin begin
s:=separateleft(sURL,'@'); s := SeparateLeft(sURL, '@');
sURL:=separateright(sURL,'@'); sURL := SeparateRight(sURL, '@');
x:=pos(':',s); x := Pos(':', s);
if x > 0 then if x > 0 then
begin begin
user:=separateleft(s,':'); User := SeparateLeft(s, ':');
pass:=separateright(s,':'); Pass := SeparateRight(s, ':');
end end
else user:=s; else
User := s;
end; end;
x:=pos('/',sURL); x := Pos('/', sURL);
if x > 0 then if x > 0 then
begin begin
s1:=separateleft(sURL,'/'); s1 := SeparateLeft(sURL, '/');
s2:=separateright(sURL,'/'); s2 := SeparateRight(sURL, '/');
end end
else else
begin begin
s1 := sURL; s1 := sURL;
s2 := ''; s2 := '';
end; end;
x:=pos(':',s1); x := Pos(':', s1);
if x > 0 then if x > 0 then
begin begin
host:=separateleft(s1,':'); Host := SeparateLeft(s1, ':');
port:=separateright(s1,':'); Port := SeparateRight(s1, ':');
end end
else host:=s1; else
result:='/'+s2; Host := s1;
x:=pos('?',s2); Result := '/' + s2;
x := Pos('?', s2);
if x > 0 then if x > 0 then
begin begin
path:='/'+separateleft(s2,'?'); Path := '/' + SeparateLeft(s2, '?');
para:=separateright(s2,'?'); Para := SeparateRight(s2, '?');
end end
else path:='/'+s2; else
if host='' Path := '/' + s2;
then host:='localhost'; if Host = '' then
Host := 'localhost';
end; end;
{==============================================================================} {==============================================================================}
{StringReplace}
function StringReplace(value,search,replace:string):string; function StringReplace(Value, Search, Replace: string): string;
var var
x,l,ls,lr:integer; x, l, ls, lr: Integer;
begin begin
if (value='') or (Search='') then if (Value = '') or (Search = '') then
begin begin
result:=value; Result := Value;
Exit; Exit;
end; end;
ls:=length(search); ls := Length(Search);
lr:=length(replace); lr := Length(Replace);
result:=''; Result := '';
x:=pos(search,value); x := Pos(Search, Value);
while x > 0 do while x > 0 do
begin begin
l:=length(result); l := Length(Result);
setlength(result,l+x-1); SetLength(Result, l + x - 1);
Move(pointer(value)^,Pointer(@result[l+1])^, x-1); Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1);
// result:=result+copy(value,1,x-1); // Result:=Result+Copy(Value,1,x-1);
l:=length(result); l := Length(Result);
setlength(result,l+lr); SetLength(Result, l + lr);
Move(pointer(replace)^,Pointer(@result[l+1])^, lr); Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr);
// result:=result+replace; // Result:=Result+Replace;
delete(value,1,x-1+ls); Delete(Value, 1, x - 1 + ls);
x:=pos(search,value); x := Pos(Search, Value);
end; end;
result:=result+value; Result := Result + Value;
end; end;
{==============================================================================}
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 | | 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 | | (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/ |
| | | |
@ -23,15 +23,17 @@
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{$WEAKPACKAGEUNIT ON}
unit synsock; unit synsock;
interface interface
uses uses
{$IFDEF LINUX} {$IFDEF LINUX}
libc, kernelioctl; Libc, KernelIoctl;
{$ELSE} {$ELSE}
winsock, windows; Windows, WinSock;
{$ENDIF} {$ENDIF}
{$IFDEF LINUX} {$IFDEF LINUX}
@ -90,6 +92,7 @@ const
WSANO_DATA = -6; WSANO_DATA = -6;
{$ELSE} {$ELSE}
const const
DLLStackName = 'wsock32.dll'; DLLStackName = 'wsock32.dll';
var var
@ -111,13 +114,12 @@ type
iMaxUdpDg: Word; iMaxUdpDg: Word;
lpVendorInfo: PChar; lpVendorInfo: PChar;
end; end;
DWORD=integer; DWORD = Integer;
TLinger = Linger; TLinger = Linger;
{$ENDIF} {$ENDIF}
type type
TWSAStartup = function (wVersionRequired: word; TWSAStartup = function(wVersionRequired: Word;
var WSData: TWSAData): Integer; stdcall; var WSData: TWSAData): Integer; stdcall;
TWSACleanup = function: Integer; stdcall; TWSACleanup = function: Integer; stdcall;
TWSAGetLastError = function: Integer; stdcall; TWSAGetLastError = function: Integer; stdcall;
@ -126,32 +128,26 @@ type
TGetProtoByName = function(name: PChar): PProtoEnt; stdcall; TGetProtoByName = function(name: PChar): PProtoEnt; stdcall;
TGetProtoByNumber = function(proto: Integer): PProtoEnt; stdcall; TGetProtoByNumber = function(proto: Integer): PProtoEnt; stdcall;
TGetHostByName = function(name: PChar): PHostEnt; 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; TGetHostName = function(name: PChar; len: Integer): Integer; stdcall;
TShutdown = function(s: TSocket; how: Integer): Integer; stdcall; TShutdown = function(s: TSocket; how: Integer): Integer; stdcall;
TSetSockOpt = function(s: TSocket; level, optname: Integer; TSetSockOpt = function(s: TSocket; level, optname: Integer;
optval: PChar; optval: PChar; optlen: Integer): Integer; stdcall;
optlen: Integer): Integer; stdcall;
TGetSockOpt = function(s: TSocket; level, optname: Integer; TGetSockOpt = function(s: TSocket; level, optname: Integer;
optval: PChar; optval: PChar; var optlen: Integer): Integer; stdcall;
var optlen: Integer): Integer; stdcall;
TSendTo = function(s: TSocket; var Buf; TSendTo = function(s: TSocket; var Buf;
len, flags: Integer; len, flags: Integer; var addrto: TSockAddr;
var addrto: TSockAddr;
tolen: Integer): Integer; stdcall; tolen: Integer): Integer; stdcall;
TSend = function(s: TSocket; var Buf; TSend = function(s: TSocket; var Buf;
len, flags: Integer): Integer; stdcall; len, flags: Integer): Integer; stdcall;
TRecv = function(s: TSocket; TRecv = function(s: TSocket;
var Buf; var Buf; len, flags: Integer): Integer; stdcall;
len, flags: Integer): Integer; stdcall;
TRecvFrom = function(s: TSocket; TRecvFrom = function(s: TSocket;
var Buf; len, flags: Integer; var Buf; len, flags: Integer; var from: TSockAddr;
var from: TSockAddr;
var fromlen: Integer): Integer; stdcall; var fromlen: Integer): Integer; stdcall;
Tntohs = function(netshort: u_short): u_short; stdcall; Tntohs = function(netshort: u_short): u_short; stdcall;
Tntohl = function(netlong: u_long): u_long; stdcall; Tntohl = function(netlong: u_long): u_long; stdcall;
TListen = function (s: TSocket; TListen = function(s: TSocket; backlog: Integer): Integer; stdcall;
backlog: Integer): Integer; stdcall;
TIoctlSocket = function(s: TSocket; cmd: DWORD; TIoctlSocket = function(s: TSocket; cmd: DWORD;
var arg: u_long): Integer; stdcall; var arg: u_long): Integer; stdcall;
TInet_ntoa = function(inaddr: TInAddr): PChar; stdcall; TInet_ntoa = function(inaddr: TInAddr): PChar; stdcall;
@ -169,7 +165,7 @@ type
namelen: Integer): Integer; stdcall; namelen: Integer): Integer; stdcall;
TAccept = function(s: TSocket; addr: PSockAddr; TAccept = function(s: TSocket; addr: PSockAddr;
addrlen: PInteger): TSocket; stdcall; 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; TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint; stdcall; timeout: PTimeVal): Longint; stdcall;
@ -220,15 +216,19 @@ function LSGetServByPort (port: Integer; proto: PChar): PServEnt; stdcall;
function LSGetProtoByName(name: PChar): PProtoEnt; stdcall; function LSGetProtoByName(name: PChar): PProtoEnt; stdcall;
function LSGetProtoByNumber(proto: Integer): PProtoEnt; stdcall; function LSGetProtoByNumber(proto: Integer): PProtoEnt; stdcall;
function LSGetHostByName(name: PChar): PHostEnt; 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 LSGetHostName(name: PChar; len: Integer): Integer; stdcall;
function LSShutdown(s: TSocket; how: 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 LSSetSockOpt(s: TSocket; level, optname: Integer; optval: PChar;
function LSGetSockOpt (s: TSocket; level, optname: Integer; optval: PChar; var optlen: Integer): Integer; stdcall; optlen: Integer): Integer; stdcall;
function LSSendTo (s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr; tolen: 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 LSSend(s: TSocket; var Buf; len, flags: Integer): Integer; stdcall;
function LSRecv(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 LSntohs(netshort: u_short): u_short; stdcall;
function LSntohl(netlong: u_long): u_long; stdcall; function LSntohl(netlong: u_long): u_long; stdcall;
function LSListen(s: TSocket; backlog: Integer): Integer; 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 LSInet_addr(cp: PChar): u_long; stdcall;
function LShtons(hostshort: u_short): u_short; stdcall; function LShtons(hostshort: u_short): u_short; stdcall;
function LShtonl(hostlong: u_long): u_long; stdcall; function LShtonl(hostlong: u_long): u_long; stdcall;
function LSGetSockName (s: TSocket; var name: TSockAddr; var namelen: Integer): Integer; stdcall; function LSGetSockName(s: TSocket; var name: TSockAddr;
function LSGetPeerName (s: TSocket; var name: TSockAddr; var namelen: Integer): Integer; stdcall; 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 LSConnect(s: TSocket; var name: TSockAddr; namelen: Integer): Integer; stdcall;
function LSCloseSocket(s: TSocket): Integer; stdcall; function LSCloseSocket(s: TSocket): Integer; stdcall;
function LSBind(s: TSocket; var addr: TSockAddr; namelen: Integer): Integer; stdcall; function LSBind(s: TSocket; var addr: TSockAddr; namelen: Integer): Integer; stdcall;
function LSAccept(s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket; stdcall; function LSAccept(s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket; stdcall;
function LSSocketProc (af, Struct, protocol: Integer): TSocket; stdcall; function LSSocketProc(af, Struc, Protocol: Integer): TSocket; stdcall;
function LSSelect (nfds: Integer; readfds, writefds, exceptfds: PFDSet; timeout: PTimeVal): Longint; stdcall; function LSSelect(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint; stdcall;
{$ENDIF} {$ENDIF}
implementation implementation
{$IFDEF LINUX} {$IFDEF LINUX}
function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
begin begin
WSData.wVersion:=wVersionRequired; with WSData do
WSData.wHighVersion:=$101; begin
WSData.szDescription:='Synapse Platform Independent Socket Layer'; wVersion := wVersionRequired;
WSData.szSystemStatus:='On Linux'; wHighVersion := $101;
WSData.iMaxSockets:=32768; szDescription := 'Synapse Platform Independent Socket Layer';
WSData.iMaxUdpDg:=8192; szSystemStatus := 'On Linux';
result:=0; iMaxSockets := 32768;
iMaxUdpDg := 8192;
end;
Result := 0;
end; end;
function LSWSACleanup: Integer; function LSWSACleanup: Integer;
@ -269,37 +275,37 @@ end;
function LSWSAGetLastError: Integer; function LSWSAGetLastError: Integer;
begin begin
result:=System.GetLastError; Result := System.GetLastError;
end; end;
function LSGetServByName(name, proto: PChar): PServEnt; function LSGetServByName(name, proto: PChar): PServEnt;
begin begin
result:=libc.GetServByName(name,proto); Result := libc.GetServByName(name, proto);
end; end;
function LSGetServByPort(port: Integer; proto: PChar): PServEnt; function LSGetServByPort(port: Integer; proto: PChar): PServEnt;
begin begin
result:=libc.GetServByPort(port,proto); Result := libc.GetServByPort(port, proto);
end; end;
function LSGetProtoByName(name: PChar): PProtoEnt; function LSGetProtoByName(name: PChar): PProtoEnt;
begin begin
result:=libc.getprotobyname(Name); Result := libc.GetProtoByName(Name);
end; end;
function LSGetProtoByNumber(proto: Integer): PProtoEnt; function LSGetProtoByNumber(proto: Integer): PProtoEnt;
begin begin
result:=libc.getprotobynumber(proto); Result := libc.GetProtoByNumber(proto);
end; end;
function LSGetHostByName(name: PChar): PHostEnt; function LSGetHostByName(name: PChar): PHostEnt;
begin begin
result:=libc.GetHostByName(Name); Result := libc.GetHostByName(Name);
end; end;
function LSGetHostByAddr (addr: Pointer; len, Struct: Integer): PHostEnt; function LSGetHostByAddr(addr: Pointer; len, Struc: Integer): PHostEnt;
begin begin
Result:=libc.GetHostByAddr(Addr,len,struct); Result := libc.GetHostByAddr(Addr, len, struc);
end; end;
function LSGetHostName(name: PChar; len: Integer): Integer; function LSGetHostName(name: PChar; len: Integer): Integer;
@ -309,37 +315,41 @@ end;
function LSShutdown(s: TSocket; how: Integer): Integer; function LSShutdown(s: TSocket; how: Integer): Integer;
begin begin
result:=libc.Shutdown(S,How); Result := libc.Shutdown(S, How);
end; 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 begin
result:=libc.SetSockOpt(S,Level,OptName,OptVal,OptLen); Result := libc.SetSockOpt(S, Level, OptName, OptVal, OptLen);
end; 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 begin
result:=libc.getsockopt(s,level,optname,optval,cardinal(optlen)); Result := libc.getsockopt(s, level, optname, optval, cardinal(optlen));
end; 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 begin
result:=libc.SendTo(S,Buf,Len,Flags,Addrto,Tolen); Result := libc.SendTo(S, Buf, Len, Flags, Addrto, Tolen);
end; end;
function LSSend(s: TSocket; var Buf; len, flags: Integer): Integer; function LSSend(s: TSocket; var Buf; len, flags: Integer): Integer;
begin begin
result:=libc.Send(S,Buf,Len,Flags); Result := libc.Send(S, Buf, Len, Flags);
end; end;
function LSRecv(s: TSocket; var Buf; len, flags: Integer): Integer; function LSRecv(s: TSocket; var Buf; len, flags: Integer): Integer;
begin begin
result:=libc.Recv(S,Buf,Len,Flags); Result := libc.Recv(S, Buf, Len, Flags);
end; 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 begin
result:=libc.RecvFrom(S,Buf,Len,Flags,@from,@fromlen); Result := libc.RecvFrom(S, Buf, Len, Flags, @from, @fromlen);
end; end;
function LSntohs(netshort: u_short): u_short; function LSntohs(netshort: u_short): u_short;
@ -354,27 +364,27 @@ end;
function LSListen(s: TSocket; backlog: Integer): Integer; function LSListen(s: TSocket; backlog: Integer): Integer;
begin begin
result:=libc.Listen(S,Backlog); Result := libc.Listen(S, Backlog);
end; end;
function LSIoctlSocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer; function LSIoctlSocket(s: TSocket; cmd: DWORD; var arg: u_long): Integer;
begin begin
result:=libc.ioctl(s,cmd,@arg); Result := libc.ioctl(s, cmd, @arg);
end; end;
function LSInet_ntoa(inaddr: TInAddr): PChar; function LSInet_ntoa(inaddr: TInAddr): PChar;
begin begin
result:=libc.inet_ntoa(inaddr); Result := libc.inet_ntoa(inaddr);
end; end;
function LSInet_addr(cp: PChar): u_long; function LSInet_addr(cp: PChar): u_long;
begin begin
result:=libc.inet_addr(cp); Result := libc.inet_addr(cp);
end; end;
function LShtons(hostshort: u_short): u_short; function LShtons(hostshort: u_short): u_short;
begin begin
result:=libc.HToNs(HostShort); Result := libc.HToNs(HostShort);
end; end;
function LShtonl(hostlong: u_long): u_long; function LShtonl(hostlong: u_long): u_long;
@ -394,37 +404,37 @@ end;
function LSConnect(s: TSocket; var name: TSockAddr; namelen: Integer): Integer; function LSConnect(s: TSocket; var name: TSockAddr; namelen: Integer): Integer;
begin begin
result:=libc.Connect(S,name,namelen); Result := libc.Connect(S, name, namelen);
end; end;
function LSCloseSocket(s: TSocket): Integer; function LSCloseSocket(s: TSocket): Integer;
begin begin
result:=libc.__close(s); Result := libc.__close(s);
end; end;
function LSBind(s: TSocket; var addr: TSockAddr; namelen: Integer): Integer; function LSBind(s: TSocket; var addr: TSockAddr; namelen: Integer): Integer;
begin begin
result:=libc.Bind(S,addr,namelen); Result := libc.Bind(S, addr, namelen);
end; end;
function LSAccept(s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket; function LSAccept(s: TSocket; addr: PSockAddr; addrlen: PInteger): TSocket;
begin begin
result:=libc.Accept(S,addr,psocketlength(addrlen)); Result := libc.Accept(S, addr, psocketlength(addrlen));
end; end;
function LSSocketProc (af, Struct, protocol: Integer): TSocket; function LSSocketProc(af, Struc, Protocol: Integer): TSocket;
begin begin
result:=libc.Socket(Af,Struct,Protocol); Result := libc.Socket(Af, Struc, Protocol);
end; end;
function LSSelect (nfds: Integer; readfds, writefds, exceptfds: PFDSet; timeout: PTimeVal): Longint; function LSSelect(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint;
begin begin
Result := libc.Select(nfds, readfds, writefds, exceptfds, timeout); Result := libc.Select(nfds, readfds, writefds, exceptfds, timeout);
end; end;
{$ENDIF} {$ENDIF}
function InitSocketInterface(stack: string): Boolean; function InitSocketInterface(stack: string): Boolean;
begin begin
{$IFDEF LINUX} {$IFDEF LINUX}
@ -451,23 +461,24 @@ begin
SetSockOpt := LSsetsockopt; SetSockOpt := LSsetsockopt;
ShutDown := LSshutdown; ShutDown := LSshutdown;
Socket := LSsocketProc; Socket := LSsocketProc;
GetHostByAddr := LSgethostbyaddr; GetHostByAddr := LSGetHostByAddr;
GetHostByName := LSgethostbyname; GetHostByName := LSGetHostByName;
GetProtoByName := LSgetprotobyname; GetProtoByName := LSGetProtoByName;
GetProtoByNumber := LSgetprotobynumber; GetProtoByNumber := LSGetProtoByNumber;
GetServByName := LSgetservbyname; GetServByName := LSGetServByName;
GetServByPort := LSgetservbyport; GetServByPort := LSGetServByPort;
GetHostName := LSgethostname; GetHostName := LSGetHostName;
WSAGetLastError := LSWSAGetLastError; WSAGetLastError := LSWSAGetLastError;
WSAStartup := LSWSAStartup; WSAStartup := LSWSAStartup;
WSACleanup := LSWSACleanup; WSACleanup := LSWSACleanup;
Result := True; Result := True;
{$ELSE} {$ELSE}
Result := False; Result := False;
if stack='' if stack = '' then
then stack:=DLLStackName; stack := DLLStackName;
LibHandle := Windows.LoadLibrary(PChar(Stack)); LibHandle := Windows.LoadLibrary(PChar(Stack));
if LibHandle <> 0 then begin if LibHandle <> 0 then
begin
Accept := Windows.GetProcAddress(LibHandle, PChar('accept')); Accept := Windows.GetProcAddress(LibHandle, PChar('accept'));
Bind := Windows.GetProcAddress(LibHandle, PChar('bind')); Bind := Windows.GetProcAddress(LibHandle, PChar('bind'));
CloseSocket := Windows.GetProcAddress(LibHandle, PChar('closesocket')); CloseSocket := Windows.GetProcAddress(LibHandle, PChar('closesocket'));
@ -510,13 +521,11 @@ function DestroySocketInterface:Boolean;
begin begin
{$IFDEF LINUX} {$IFDEF LINUX}
{$ELSE} {$ELSE}
if LibHandle <> 0 then begin if LibHandle <> 0 then
Windows.FreeLibrary(libHandle); Windows.FreeLibrary(libHandle);
end;
LibHandle := 0; LibHandle := 0;
{$ENDIF} {$ENDIF}
Result := True; Result := True;
end; end;
end. end.