pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

Release 33

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@72 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2008-04-24 07:29:09 +00:00
parent 02ab154a09
commit 9fc9a696f4
31 changed files with 11698 additions and 3771 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
asn1util.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 001.004.002 |
| Project : Ararat Synapse | 001.004.003 |
|==============================================================================|
| Content: support for ASN.1 BER coding and decoding |
|==============================================================================|
@ -44,6 +44,18 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(Utilities for handling ASN.1 BER encoding)
By this unit you can parse ASN.1 BER encoded data to elements or build back any
elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to
human readable form for easy debugging, too.
Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL,
ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER,
ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE
For sample of using, look to @link(TSnmpSend) class.
}
{$Q-}
{$H+}
{$IFDEF FPC}
@ -55,7 +67,7 @@ unit asn1util;
interface
uses
SysUtils, Classes;
SysUtils, Classes, SynaUtil;
const
ASN1_BOOL = $01;
@ -72,24 +84,50 @@ const
ASN1_TIMETICKS = $43;
ASN1_OPAQUE = $44;
function ASNEncOIDItem(Value: Integer): string;
function ASNDecOIDItem(var Start: Integer; const Buffer: string): Integer;
function ASNEncLen(Len: Integer): string;
function ASNDecLen(var Start: Integer; const Buffer: string): Integer;
function ASNEncInt(Value: Integer): string;
function ASNEncUInt(Value: Integer): string;
function ASNObject(const Data: string; ASNType: Integer): string;
function ASNItem(var Start: Integer; const Buffer: string;
var ValueType: Integer): string;
function MibToId(Mib: string): string;
function IdToMib(const Id: string): string;
function IntMibToStr(const Value: string): string;
function ASNdump(const Value: string): string;
{:Encodes OID item to binary form.}
function ASNEncOIDItem(Value: Integer): AnsiString;
{:Decodes an OID item of the next element in the "Buffer" from the "Start"
position.}
function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer;
{:Encodes the length of ASN.1 element to binary.}
function ASNEncLen(Len: Integer): AnsiString;
{:Decodes length of next element in "Buffer" from the "Start" position.}
function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
{:Encodes a signed integer to ASN.1 binary}
function ASNEncInt(Value: Integer): AnsiString;
{:Encodes unsigned integer into ASN.1 binary}
function ASNEncUInt(Value: Integer): AnsiString;
{:Encodes ASN.1 object to binary form.}
function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
{:Beginning with the "Start" position, decode the ASN.1 item of the next element
in "Buffer". Type of item is stored in "ValueType."}
function ASNItem(var Start: Integer; const Buffer: AnsiString;
var ValueType: Integer): AnsiString;
{:Encodes an MIB OID string to binary form.}
function MibToId(Mib: String): AnsiString;
{:Decodes MIB OID from binary form to string form.}
function IdToMib(const Id: AnsiString): String;
{:Encodes an one number from MIB OID to binary form. (used internally from
@link(MibToId))}
function IntMibToStr(const Value: AnsiString): AnsiString;
{:Convert ASN.1 BER encoded buffer to human readable form for debugging.}
function ASNdump(const Value: AnsiString): AnsiString;
implementation
{==============================================================================}
function ASNEncOIDItem(Value: Integer): string;
function ASNEncOIDItem(Value: Integer): AnsiString;
var
x, xm: Integer;
b: Boolean;
@ -104,12 +142,12 @@ begin
xm := xm or $80;
if x > 0 then
b := True;
Result := Char(xm) + Result;
Result := AnsiChar(xm) + Result;
until x = 0;
end;
{==============================================================================}
function ASNDecOIDItem(var Start: Integer; const Buffer: string): Integer;
function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer;
var
x: Integer;
b: Boolean;
@ -126,12 +164,12 @@ begin
end;
{==============================================================================}
function ASNEncLen(Len: Integer): string;
function ASNEncLen(Len: Integer): AnsiString;
var
x, y: Integer;
begin
if Len < $80 then
Result := Char(Len)
Result := AnsiChar(Len)
else
begin
x := Len;
@ -139,16 +177,16 @@ begin
repeat
y := x mod 256;
x := x div 256;
Result := Char(y) + Result;
Result := AnsiChar(y) + Result;
until x = 0;
y := Length(Result);
y := y or $80;
Result := Char(y) + Result;
Result := AnsiChar(y) + Result;
end;
end;
{==============================================================================}
function ASNDecLen(var Start: Integer; const Buffer: string): Integer;
function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
var
x, n: Integer;
begin
@ -171,7 +209,7 @@ begin
end;
{==============================================================================}
function ASNEncInt(Value: Integer): string;
function ASNEncInt(Value: Integer): AnsiString;
var
x, y: Cardinal;
neg: Boolean;
@ -184,14 +222,14 @@ begin
repeat
y := x mod 256;
x := x div 256;
Result := Char(y) + Result;
Result := AnsiChar(y) + Result;
until x = 0;
if (not neg) and (Result[1] > #$7F) then
Result := #0 + Result;
end;
{==============================================================================}
function ASNEncUInt(Value: Integer): string;
function ASNEncUInt(Value: Integer): AnsiString;
var
x, y: Integer;
neg: Boolean;
@ -204,28 +242,28 @@ begin
repeat
y := x mod 256;
x := x div 256;
Result := Char(y) + Result;
Result := AnsiChar(y) + Result;
until x = 0;
if neg then
Result[1] := Char(Ord(Result[1]) or $80);
Result[1] := AnsiChar(Ord(Result[1]) or $80);
end;
{==============================================================================}
function ASNObject(const Data: string; ASNType: Integer): string;
function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
begin
Result := Char(ASNType) + ASNEncLen(Length(Data)) + Data;
Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data;
end;
{==============================================================================}
function ASNItem(var Start: Integer; const Buffer: string;
var ValueType: Integer): string;
function ASNItem(var Start: Integer; const Buffer: AnsiString;
var ValueType: Integer): AnsiString;
var
ASNType: Integer;
ASNSize: Integer;
y, n: Integer;
x: byte;
s: string;
c: char;
s: AnsiString;
c: AnsiChar;
neg: Boolean;
l: Integer;
begin
@ -277,7 +315,7 @@ begin
begin
for n := 1 to ASNSize do
begin
c := Char(Buffer[Start]);
c := AnsiChar(Buffer[Start]);
Inc(Start);
s := s + c;
end;
@ -287,7 +325,7 @@ begin
begin
for n := 1 to ASNSize do
begin
c := Char(Buffer[Start]);
c := AnsiChar(Buffer[Start]);
Inc(Start);
s := s + c;
end;
@ -315,7 +353,7 @@ begin
begin
for n := 1 to ASNSize do
begin
c := Char(Buffer[Start]);
c := AnsiChar(Buffer[Start]);
Inc(Start);
s := s + c;
end;
@ -325,14 +363,14 @@ begin
end;
{==============================================================================}
function MibToId(Mib: string): string;
function MibToId(Mib: String): AnsiString;
var
x: Integer;
function WalkInt(var s: string): Integer;
function WalkInt(var s: String): Integer;
var
x: Integer;
t: string;
t: AnsiString;
begin
x := Pos('.', s);
if x < 1 then
@ -361,7 +399,7 @@ begin
end;
{==============================================================================}
function IdToMib(const Id: string): string;
function IdToMib(const Id: AnsiString): String;
var
x, y, n: Integer;
begin
@ -381,7 +419,7 @@ begin
end;
{==============================================================================}
function IntMibToStr(const Value: string): string;
function IntMibToStr(const Value: AnsiString): AnsiString;
var
n, y: Integer;
begin
@ -392,10 +430,10 @@ begin
end;
{==============================================================================}
function ASNdump(const Value: string): string;
function ASNdump(const Value: AnsiString): AnsiString;
var
i, at, x, n: integer;
s, indent: string;
s, indent: AnsiString;
il: TStringList;
begin
il := TStringList.Create;
@ -451,6 +489,8 @@ begin
else // other
Result := Result + ' unknown: ';
end;
if IsBinaryString(s) then
s := DumpExStr(s);
Result := Result + s;
end;
Result := Result + #$0d + #$0a;

2113
blcksock.pas
View File

File diff suppressed because it is too large Load Diff

164
dnssend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.003.004 |
| Project : Ararat Synapse | 002.005.001 |
|==============================================================================|
| Content: DNS client |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -41,8 +41,12 @@
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(DNS client by UDP or TCP)
Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone
transfers too!
// RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -103,11 +107,15 @@ const
QTYPE_ALL = 255;
type
{:@abstract(Implementation of DNS protocol by UDP or TCP protocol.)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TDNSSend = class(TSynaClient)
private
FID: Word;
FRCode: Integer;
FBuffer: string;
FBuffer: AnsiString;
FSock: TUDPBlockSocket;
FTCPSock: TTCPBlockSocket;
FUseTCP: Boolean;
@ -115,35 +123,84 @@ type
FNameserverInfo: TStringList;
FAdditionalInfo: TStringList;
FAuthoritative: Boolean;
function ReverseIP(Value: string): string;
function ReverseIP6(Value: string): string;
function CompressName(const Value: string): string;
function CodeHeader: string;
function CodeQuery(const Name: string; QType: Integer): string;
function DecodeLabels(var From: Integer): string;
function DecodeString(var From: Integer): string;
function ReverseIP(Value: AnsiString): AnsiString;
function ReverseIP6(Value: AnsiString): AnsiString;
function CompressName(const Value: AnsiString): AnsiString;
function CodeHeader: AnsiString;
function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
function DecodeLabels(var From: Integer): AnsiString;
function DecodeString(var From: Integer): AnsiString;
function DecodeResource(var i: Integer; const Info: TStringList;
QType: Integer): string;
function RecvTCPResponse(const WorkSock: TBlockSocket): string;
function DecodeResponse(const Buf: string; const Reply: TStrings;
QType: Integer): AnsiString;
function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
function DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
QType: Integer):boolean;
public
constructor Create;
destructor Destroy; override;
function DNSQuery(Name: string; QType: Integer;
{:Query a DNSHost for QType resources correspond to a name. Supported QType
values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA,
Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO,
Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25,
Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS,
Qtype_KX.
Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode!
"Name" is domain name or host name for queried resource. If "name" is
IP address, automatically convert to reverse domain form (.in-addr.arpa).
If result is @true, Reply contains resource records. One record on one line.
If Resource record have multiple fields, they are stored on line divided by
comma. (example: MX record contains value 'rs.cesnet.cz' with preference
number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address
in resource are converted to string form.}
function DNSQuery(Name: AnsiString; QType: Integer;
const Reply: TStrings): Boolean;
published
{:Socket object used for UDP operation. Good for seting OnStatus hook, etc.}
property Sock: TUDPBlockSocket read FSock;
{:Socket object used for TCP operation. Good for seting OnStatus hook, etc.}
property TCPSock: TTCPBlockSocket read FTCPSock;
{:if @true, then is used TCP protocol instead UDP. It is needed for zone
transfers, etc.}
property UseTCP: Boolean read FUseTCP Write FUseTCP;
{:After DNS operation contains ResultCode of DNS operation.
Values are: 0-no error, 1-format error, 2-server failure, 3-name error,
4-not implemented, 5-refused.}
property RCode: Integer read FRCode;
{:@True, if ansfer is authoritative.}
property Authoritative: Boolean read FAuthoritative;
{:Detailed informations from name server reply. One record per line. Record
have comma delimited entries with type number, TTL and data filelds.
This information contains detailed information about query reply.}
property AnsferInfo: TStringList read FAnsferInfo;
{:Detailed informations from name server reply. One record per line. Record
have comma delimited entries with type number, TTL and data filelds.
This information contains detailed information about nameserver.}
property NameserverInfo: TStringList read FNameserverInfo;
{:Detailed informations from name server reply. One record per line. Record
have comma delimited entries with type number, TTL and data filelds.
This information contains detailed additional information.}
property AdditionalInfo: TStringList read FAdditionalInfo;
end;
function GetMailServers(const DNSHost, Domain: string;
{:A very useful function, and example of it's use is found in the TDNSSend object.
This function is used to get mail servers for a domain and sort them by
preference numbers. "Servers" contains only the domain names of the mail
servers in the right order (without preference number!). The first domain name
will always be the highest preferenced mail server. Returns boolean @TRUE if
all went well.}
function GetMailServers(const DNSHost, Domain: AnsiString;
const Servers: TStrings): Boolean;
implementation
@ -172,7 +229,7 @@ begin
inherited Destroy;
end;
function TDNSSend.ReverseIP(Value: string): string;
function TDNSSend.ReverseIP(Value: AnsiString): AnsiString;
var
x: Integer;
begin
@ -187,7 +244,7 @@ begin
Delete(Result, 1, 1);
end;
function TDNSSend.ReverseIP6(Value: string): string;
function TDNSSend.ReverseIP6(Value: AnsiString): AnsiString;
var
ip6: TSockAddrIn6;
begin
@ -210,10 +267,10 @@ begin
+ '.' + ip6.sin6_addr.S_un_b.s_b1;
end;
function TDNSSend.CompressName(const Value: string): string;
function TDNSSend.CompressName(const Value: AnsiString): AnsiString;
var
n: Integer;
s: string;
s: AnsiString;
begin
Result := '';
if Value = '' then
@ -235,7 +292,7 @@ begin
end;
end;
function TDNSSend.CodeHeader: string;
function TDNSSend.CodeHeader: AnsiString;
begin
FID := Random(32767);
Result := CodeInt(FID); // ID
@ -246,14 +303,14 @@ begin
Result := Result + CodeInt(0); // ARCount
end;
function TDNSSend.CodeQuery(const Name: string; QType: Integer): string;
function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
begin
Result := CompressName(Name);
Result := Result + CodeInt(QType);
Result := Result + CodeInt(1); // Type INTERNET
end;
function TDNSSend.DecodeString(var From: Integer): string;
function TDNSSend.DecodeString(var From: Integer): AnsiString;
var
Len: integer;
begin
@ -263,7 +320,7 @@ begin
Inc(From, Len);
end;
function TDNSSend.DecodeLabels(var From: Integer): string;
function TDNSSend.DecodeLabels(var From: Integer): AnsiString;
var
l, f: Integer;
begin
@ -295,11 +352,11 @@ begin
end;
function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList;
QType: Integer): string;
QType: Integer): AnsiString;
var
Rname: string;
Rname: AnsiString;
RType, Len, j, x, y, z, n: Integer;
R: string;
R: AnsiString;
t1, t2, ttl: integer;
ip6: TSockAddrIn6;
begin
@ -331,24 +388,27 @@ begin
end;
QTYPE_AAAA:
begin
FillChar(ip6, SizeOf(ip6), 0);
ip6.sin6_addr.S_un_b.s_b1 := FBuffer[j];
ip6.sin6_addr.S_un_b.s_b2 := FBuffer[j + 1];
ip6.sin6_addr.S_un_b.s_b3 := FBuffer[j + 2];
ip6.sin6_addr.S_un_b.s_b4 := FBuffer[j + 3];
ip6.sin6_addr.S_un_b.s_b5 := FBuffer[j + 4];
ip6.sin6_addr.S_un_b.s_b6 := FBuffer[j + 5];
ip6.sin6_addr.S_un_b.s_b7 := FBuffer[j + 6];
ip6.sin6_addr.S_un_b.s_b8 := FBuffer[j + 7];
ip6.sin6_addr.S_un_b.s_b9 := FBuffer[j + 8];
ip6.sin6_addr.S_un_b.s_b10 := FBuffer[j + 9];
ip6.sin6_addr.S_un_b.s_b11 := FBuffer[j + 10];
ip6.sin6_addr.S_un_b.s_b12 := FBuffer[j + 11];
ip6.sin6_addr.S_un_b.s_b13 := FBuffer[j + 12];
ip6.sin6_addr.S_un_b.s_b14 := FBuffer[j + 13];
ip6.sin6_addr.S_un_b.s_b15 := FBuffer[j + 14];
ip6.sin6_addr.S_un_b.s_b16 := FBuffer[j + 15];
ip6.sin6_family := AF_INET6;
// FillChar(ip6, SizeOf(ip6), 0);
ip6.sin6_addr.S_un_b.s_b1 := Char(FBuffer[j]);
ip6.sin6_addr.S_un_b.s_b2 := Char(FBuffer[j + 1]);
ip6.sin6_addr.S_un_b.s_b3 := Char(FBuffer[j + 2]);
ip6.sin6_addr.S_un_b.s_b4 := Char(FBuffer[j + 3]);
ip6.sin6_addr.S_un_b.s_b5 := Char(FBuffer[j + 4]);
ip6.sin6_addr.S_un_b.s_b6 := Char(FBuffer[j + 5]);
ip6.sin6_addr.S_un_b.s_b7 := Char(FBuffer[j + 6]);
ip6.sin6_addr.S_un_b.s_b8 := Char(FBuffer[j + 7]);
ip6.sin6_addr.S_un_b.s_b9 := Char(FBuffer[j + 8]);
ip6.sin6_addr.S_un_b.s_b10 := Char(FBuffer[j + 9]);
ip6.sin6_addr.S_un_b.s_b11 := Char(FBuffer[j + 10]);
ip6.sin6_addr.S_un_b.s_b12 := Char(FBuffer[j + 11]);
ip6.sin6_addr.S_un_b.s_b13 := Char(FBuffer[j + 12]);
ip6.sin6_addr.S_un_b.s_b14 := Char(FBuffer[j + 13]);
ip6.sin6_addr.S_un_b.s_b15 := Char(FBuffer[j + 14]);
ip6.sin6_addr.S_un_b.s_b16 := Char(FBuffer[j + 15]);
ip6.sin6_family := word(AF_INET6);
ip6.sin6_port := 0;
ip6.sin6_flowinfo := 0;
ip6.sin6_scope_id := 0;
R := FSock.IP6ToStr(ip6);
end;
QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
@ -426,7 +486,7 @@ begin
Result := R;
end;
function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): string;
function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
var
l: integer;
begin
@ -436,12 +496,12 @@ begin
Result := WorkSock.RecvBufferStr(l, FTimeout);
end;
function TDNSSend.DecodeResponse(const Buf: string; const Reply: TStrings;
function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
QType: Integer):boolean;
var
n, i: Integer;
flag, qdcount, ancount, nscount, arcount: Integer;
s: string;
s: AnsiString;
begin
Result := False;
Reply.Clear;
@ -486,7 +546,7 @@ begin
end;
end;
function TDNSSend.DNSQuery(Name: string; QType: Integer;
function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer;
const Reply: TStrings): Boolean;
var
WorkSock: TBlockSocket;
@ -497,7 +557,7 @@ begin
if IsIP(Name) then
Name := ReverseIP(Name) + '.in-addr.arpa';
if IsIP6(Name) then
Name := ReverseIP6(Name) + '.ip6.int';
Name := ReverseIP6(Name) + '.ip6.arpa';
FBuffer := CodeHeader + CodeQuery(Name, QType);
if FUseTCP then
WorkSock := FTCPSock
@ -543,7 +603,7 @@ end;
{==============================================================================}
function GetMailServers(const DNSHost, Domain: string;
function GetMailServers(const DNSHost, Domain: AnsiString;
const Servers: TStrings): Boolean;
var
DNS: TDNSSend;

1254
ftpsend.pas
View File

File diff suppressed because it is too large Load Diff

77
ftptsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.002 |
| Project : Ararat Synapse | 001.001.000 |
|==============================================================================|
| Content: Trivial FTP (TFTP) client and server |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003. |
| Portions created by Lukas Gebauer are Copyright (c)2003-2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -42,7 +42,10 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
// RFC-1350
{: @abstract(TFTP client and server protocol)
Used RFC: RFC-1350
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -61,7 +64,16 @@ uses
const
cTFTPProtocol = '69';
cTFTP_RRQ = word(1);
cTFTP_WRQ = word(2);
cTFTP_DTA = word(3);
cTFTP_ACK = word(4);
cTFTP_ERR = word(5);
type
{:@abstract(Implementation of TFTP client and server)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TTFTPSend = class(TSynaClient)
private
FSock: TUDPBlockSocket;
@ -75,17 +87,44 @@ type
public
constructor Create;
destructor Destroy; override;
{:Upload @link(data) as file to TFTP server.}
function SendFile(const Filename: string): Boolean;
{:Download file from TFTP server to @link(data).}
function RecvFile(const Filename: string): Boolean;
{:Acts as TFTP server and wait for client request. When some request
incoming within Timeout, result is @true and parametres is filled with
information from request. You must handle this request, validate it, and
call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
to TFTP Client.}
function WaitForRequest(var Req: word; var filename: string): Boolean;
{:send error to TFTP client, when you acts as TFTP server.}
procedure ReplyError(Error: word; Description: string);
{:Accept uploaded file from TFTP client to @link(data), when you acts as
TFTP server.}
function ReplyRecv: Boolean;
{:Accept download request file from TFTP client and send content of
@link(data), when you acts as TFTP server.}
function ReplySend: Boolean;
published
{:Code of TFTP error.}
property ErrorCode: integer read FErrorCode;
{:Human readable decription of TFTP error. (if is sended by remote side)}
property ErrorString: string read FErrorString;
{:MemoryStream with datas for sending or receiving}
property Data: TMemoryStream read FData;
{:Address of TFTP remote side.}
property RequestIP: string read FRequestIP write FRequestIP;
{:Port of TFTP remote side.}
property RequestPort: string read FRequestPort write FRequestPort;
end;
@ -197,14 +236,16 @@ begin
n2 := FData.Size mod 512;
for n := 1 to n1 do
begin
SetLength(s, 512);
FData.Read(pointer(s)^, 512);
s := ReadStrFromStream(FData, 512);
// SetLength(s, 512);
// FData.Read(pointer(s)^, 512);
if not Sendpacket(3, ser, s) then
Exit;
inc(ser);
end;
SetLength(s, n2);
FData.Read(pointer(s)^, n2);
s := ReadStrFromStream(FData, n2);
// SetLength(s, n2);
// FData.Read(pointer(s)^, n2);
if not Sendpacket(3, ser, s) then
Exit;
Result := True;
@ -237,7 +278,8 @@ begin
if not RecvPacket(ser, s) then
Exit;
inc(ser);
FData.Write(pointer(s)^, length(s));
WriteStrToStream(FData, s);
// FData.Write(pointer(s)^, length(s));
until length(s) <> 512;
FData.Position := 0;
Result := true;
@ -266,10 +308,10 @@ begin
FRequestPort := IntToStr(FSock.GetRemoteSinPort);
Req := DecodeInt(s, 1);
delete(s, 1, 2);
filename := SeparateLeft(s, #0);
filename := Trim(SeparateLeft(s, #0));
s := SeparateRight(s, #0);
s := SeparateLeft(s, #0);
Result := lowercase(s) = 'octet';
Result := lowercase(trim(s)) = 'octet';
end;
end;
end;
@ -304,7 +346,8 @@ begin
if not RecvPacket(ser, s) then
Exit;
inc(ser);
FData.Write(pointer(s)^, length(s));
WriteStrToStream(FData, s);
// FData.Write(pointer(s)^, length(s));
until length(s) <> 512;
FData.Position := 0;
Result := true;
@ -331,14 +374,16 @@ begin
n2 := FData.Size mod 512;
for n := 1 to n1 do
begin
SetLength(s, 512);
FData.Read(pointer(s)^, 512);
s := ReadStrFromStream(FData, 512);
// SetLength(s, 512);
// FData.Read(pointer(s)^, 512);
if not Sendpacket(3, ser, s) then
Exit;
inc(ser);
end;
SetLength(s, n2);
FData.Read(pointer(s)^, n2);
s := ReadStrFromStream(FData, n2);
// SetLength(s, n2);
// FData.Read(pointer(s)^, n2);
if not Sendpacket(3, ser, s) then
Exit;
Result := True;

209
httpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 003.006.007 |
| Project : Ararat Synapse | 003.009.003 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -42,7 +42,10 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-1867, RFC-1947, RFC-2388, RFC-2616
{:@abstract(HTTP protocol client)
Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -64,10 +67,13 @@ const
cHttpProtocol = '80';
type
{:These encoding types are used internally by the THTTPSend object to identify
the transfer data types.}
TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
{:abstract(Implementation of HTTP protocol.)}
THTTPSend = class(TSynaClient)
private
protected
{$IFDEF STREAMSEC}
FSock: TSsTCPBlockSocket;
FTLSServer: TCustomTLSInternalServer;
@ -102,41 +108,151 @@ type
public
constructor Create;
destructor Destroy; override;
{:Reset headers and document and Mimetype.}
procedure Clear;
{:Decode ResultCode and ResultString from Value.}
procedure DecodeStatus(const Value: string);
{:Connects to host define in URL and access to resource defined in URL by
method. If Document is not empty, send it to server as part of HTTP request.
Server response is in Document and headers. Connection may be authorised
by username and password in URL. If you define proxy properties, connection
is made by this proxy. If all OK, result is @true, else result is @false.
If you use in URL 'https:' instead only 'http:', then your request is made
by SSL/TLS connection (if you not specify port, then port 443 is used
instead standard port 80). If you use SSL/TLS request and you have defined
HTTP proxy, then HTTP-tunnel mode is automaticly used .}
function HTTPMethod(const Method, URL: string): Boolean;
{:You can call this method from OnStatus event for break current data
transfer. (or from another thread.)}
procedure Abort;
published
{:Before HTTP operation you may define any non-standard headers for HTTP
request, except of: 'Expect: 100-continue', 'Content-Length', 'Content-Type',
'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers.
After HTTP operation contains full headers of returned document.}
property Headers: TStringList read FHeaders;
{:This is stringlist with name-value stringlist pairs. Each this pair is one
cookie. After HTTP request is returned cookies parsed to this stringlist.
You can leave this cookies untouched for next HTTP request. You can also
save this stringlist for later use.}
property Cookies: TStringList read FCookies;
{:Stream with document to send (before request, or with document received
from HTTP server (after request).}
property Document: TMemoryStream read FDocument;
{:If you need download only part of requested document, here specify
possition of subpart begin. If here 0, then is requested full document.}
property RangeStart: integer read FRangeStart Write FRangeStart;
{:If you need download only part of requested document, here specify
possition of subpart end. If here 0, then is requested document from
rangeStart to end of document. (for broken download restoration,
for example.)}
property RangeEnd: integer read FRangeEnd Write FRangeEnd;
{:Mime type of sending data. Default is: 'text/html'.}
property MimeType: string read FMimeType Write FMimeType;
{:Define protocol version. Possible values are: '1.1' (default),
'1.0' and '0.9'.}
property Protocol: string read FProtocol Write FProtocol;
{:If @true (default value), keppalives in HTTP protocol 1.1 is enabled.}
property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
{:if @true, then server is requested for 100status capability when uploading
data. Default is @false (off).}
property Status100: Boolean read FStatus100 Write FStatus100;
{:Address of proxy server (IP address or domain name) where you want to
connect in @link(HTTPMethod) method.}
property ProxyHost: string read FProxyHost Write FProxyHost;
{:Port number for proxy connection. Default value is 8080.}
property ProxyPort: string read FProxyPort Write FProxyPort;
{:Username for connect to proxy server where you want to connect in
HTTPMethod method.}
property ProxyUser: string read FProxyUser Write FProxyUser;
{:Password for connect to proxy server where you want to connect in
HTTPMethod method.}
property ProxyPass: string read FProxyPass Write FProxyPass;
{:Here you can specify custom User-Agent indentification. By default is
used: 'Mozilla/4.0 (compatible; Synapse)'}
property UserAgent: string read FUserAgent Write FUserAgent;
{:After successful @link(HTTPMethod) method contains result code of
operation.}
property ResultCode: Integer read FResultCode;
{:After successful @link(HTTPMethod) method contains string after result code.}
property ResultString: string read FResultString;
{:if this value is not 0, then data download pending. In this case you have
here total sice of downloaded data. It is good for draw download
progressbar from OnStatus event.}
property DownloadSize: integer read FDownloadSize;
{:if this value is not 0, then data upload pending. In this case you have
here total sice of uploaded data. It is good for draw upload progressbar
from OnStatus event.}
property UploadSize: integer read FUploadSize;
{$IFDEF STREAMSEC}
property Sock: TSsTCPBlockSocket read FSock;
property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
{$ELSE}
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{$ENDIF}
end;
{:A very usefull function, and example of use can be found in the THTTPSend
object. It implements the GET method of the HTTP protocol. This function sends
the GET method for URL document to an HTTP server. Returned document is in the
"Response" stringlist (without any headers). Returns boolean TRUE if all went
well.}
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
{:A very usefull function, and example of use can be found in the THTTPSend
object. It implements the GET method of the HTTP protocol. This function sends
the GET method for URL document to an HTTP server. Returned document is in the
"Response" stream. Returns boolean TRUE if all went well.}
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function sends
the SEND method for a URL document to an HTTP server. The document to be sent
is located in "Data" stream. The returned document is in the "Data" stream.
Returns boolean TRUE if all went well.}
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function is
good for POSTing form data. It sends the POST method for a URL document to
an HTTP server. You must prepare the form data in the same manner as you would
the URL data, and pass this prepared data to "URLdata". The following is
a sample of how the data would appear: 'name=Lukas&field1=some%20data'.
The information in the field must be encoded by EncodeURLElement function.
The returned document is in the "Data" stream. Returns boolean TRUE if all
went well.}
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function sends
the POST method for a URL document to an HTTP server. This function simulate
posting of file by HTML form used method 'multipart/form-data'. Posting file
is in DATA stream. Its name is Filename string. Fieldname is for name of
formular field with file. (simulate HTML INPUT FILE) The returned document is
in the ResultData Stringlist. Returns boolean TRUE if all went well.}
function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStrings): Boolean;
@ -156,8 +272,8 @@ begin
FSock := TTCPBlockSocket.Create;
{$ENDIF}
FSock.ConvertLineEnd := True;
FSock.SizeRecvBuffer := 65536;
FSock.SizeSendBuffer := 65536;
FSock.SizeRecvBuffer := c64k;
FSock.SizeSendBuffer := c64k;
FTimeout := 90000;
FTargetPort := cHttpProtocol;
FProxyHost := '';
@ -197,10 +313,10 @@ procedure THTTPSend.DecodeStatus(const Value: string);
var
s, su: string;
begin
s := SeparateRight(Value, ' ');
su := SeparateLeft(s, ' ');
s := Trim(SeparateRight(Value, ' '));
su := Trim(SeparateLeft(s, ' '));
FResultCode := StrToIntDef(su, 0);
FResultString := SeparateRight(s, ' ');
FResultString := Trim(SeparateRight(s, ' '));
if FResultString = s then
FResultString := '';
end;
@ -225,6 +341,11 @@ begin
FUploadSize := 0;
URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
if User = '' then
begin
User := FUsername;
Pass := FPassword;
end;
if UpperCase(Prot) = 'HTTPS' then
begin
HttpTunnel := FProxyHost <> '';
@ -247,9 +368,10 @@ begin
status100 := FStatus100 and Sending and (FProtocol = '1.1');
if status100 then
FHeaders.Insert(0, 'Expect: 100-continue');
FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
if Sending then
begin
FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
// FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
if FMimeType <> '' then
FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
end;
@ -260,14 +382,21 @@ begin
if FRangeEnd > 0 then
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd));
{ setting Cookies }
s := '';
for n := 0 to FCookies.Count - 1 do
FHeaders.Insert(0, 'Cookie: ' + FCookies[n]);
begin
if s <> '' then
s := s + '; ';
s := s + FCookies[n];
end;
if s <> '' then
FHeaders.Insert(0, 'Cookie: ' + s);
{ setting KeepAlives }
if not FKeepAlive then
FHeaders.Insert(0, 'Connection: close');
{ set target servers/proxy, authorizations, etc... }
if User <> '' then
FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(user + ':' + pass));
FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass));
if (FProxyHost <> '') and (FProxyUser <> '') and not(HttpTunnel) then
FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
EncodeBase64(FProxyUser + ':' + FProxyPass));
@ -416,7 +545,8 @@ begin
begin
{ old HTTP 0.9 and some buggy servers not send result }
s := s + CRLF;
FDocument.Write(Pointer(s)^, Length(s));
WriteStrToStream(FDocument, s);
// FDocument.Write(Pointer(s)^, Length(s));
FResultCode := 0;
end;
end
@ -434,21 +564,22 @@ begin
su := UpperCase(s);
if Pos('CONTENT-LENGTH:', su) = 1 then
begin
Size := StrToIntDef(SeparateRight(s, ' '), -1);
Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1);
if Size <> -1 then
FTransferEncoding := TE_IDENTITY;
end;
if Pos('CONTENT-TYPE:', su) = 1 then
FMimeType := SeparateRight(s, ' ');
FMimeType := Trim(SeparateRight(s, ' '));
if Pos('TRANSFER-ENCODING:', su) = 1 then
begin
s := SeparateRight(su, ' ');
s := Trim(SeparateRight(su, ' '));
if Pos('CHUNKED', s) > 0 then
FTransferEncoding := TE_CHUNKED;
end;
if Pos('CONNECTION: CLOSE', su) = 1 then
ToClose := True;
until FSock.LastError <> 0;
Result := FSock.LastError = 0;
{if need receive response body, read it}
Receiving := Method <> 'HEAD';
@ -457,13 +588,12 @@ begin
if Receiving then
case FTransferEncoding of
TE_UNKNOWN:
ReadUnknown;
Result := ReadUnknown;
TE_IDENTITY:
ReadIdentity(Size);
Result := ReadIdentity(Size);
TE_CHUNKED:
ReadChunked;
Result := ReadChunked;
end;
Result := True;
FDocument.Seek(0, soFromBeginning);
if ToClose then
@ -482,20 +612,22 @@ begin
repeat
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
FDocument.Write(Pointer(s)^, Length(s));
WriteStrToStream(FDocument, s);
until FSock.LastError <> 0;
Result := True;
end;
function THTTPSend.ReadIdentity(Size: Integer): Boolean;
var
x: integer;
begin
FDownloadSize := Size;
FDocument.SetSize(FDocument.Position + Size);
x := FSock.RecvBufferEx(IncPoint(FDocument.Memory, FDocument.Position), Size, FTimeout);
FDocument.SetSize(FDocument.Position + x);
Result := FSock.LastError = 0;
if Size > 0 then
begin
FDownloadSize := Size;
FSock.RecvStreamSize(FDocument, FTimeout, Size);
FDocument.Seek(0, soFromEnd);
Result := FSock.LastError = 0;
end
else
Result := true;
end;
function THTTPSend.ReadChunked: Boolean;
@ -506,14 +638,16 @@ begin
repeat
repeat
s := FSock.RecvString(FTimeout);
until s <> '';
until (s <> '') or (FSock.LastError <> 0);
if FSock.LastError <> 0 then
Break;
s := SeparateLeft(s, ' ');
s := Trim(SeparateLeft(s, ' '));
s := Trim(SeparateLeft(s, ';'));
Size := StrToIntDef('$' + s, 0);
if Size = 0 then
Break;
ReadIdentity(Size);
if not ReadIdentity(Size) then
break;
until False;
Result := FSock.LastError = 0;
end;
@ -537,7 +671,7 @@ end;
procedure THTTPSend.Abort;
begin
FSock.AbortSocket;
FSock.StopFlag := True;
end;
{==============================================================================}
@ -591,7 +725,8 @@ var
begin
HTTP := THTTPSend.Create;
try
HTTP.Document.Write(Pointer(URLData)^, Length(URLData));
WriteStrToStream(HTTP.Document, URLData);
// HTTP.Document.Write(Pointer(URLData)^, Length(URLData));
HTTP.MimeType := 'application/x-www-form-urlencoded';
Result := HTTP.HTTPMethod('POST', URL);
Data.CopyFrom(HTTP.Document, 0);
@ -613,10 +748,12 @@ begin
s := s + 'content-disposition: form-data; name="' + FieldName + '";';
s := s + ' filename="' + FileName +'"' + CRLF;
s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
HTTP.Document.Write(Pointer(s)^, Length(s));
WriteStrToStream(HTTP.Document, s);
// HTTP.Document.Write(Pointer(s)^, Length(s));
HTTP.Document.CopyFrom(Data, 0);
s := CRLF + '--' + Bound + '--' + CRLF;
HTTP.Document.Write(Pointer(s)^, Length(s));
WriteStrToStream(HTTP.Document, s);
// HTTP.Document.Write(Pointer(s)^, Length(s));
HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
Result := HTTP.HTTPMethod('POST', URL);
ResultData.LoadFromStream(HTTP.Document);

192
imapsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.004.002 |
| Project : Ararat Synapse | 002.005.000 |
|==============================================================================|
| Content: IMAP4rev1 client |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2003. |
| Portions created by Lukas Gebauer are Copyright (c)2001-2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -42,7 +42,10 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-2060, RFC-2595
{:@abstract(IMAP4 rev1 protocol client)
Used RFC: RFC-2060, RFC-2595
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -58,14 +61,20 @@ uses
{$IFDEF STREAMSEC}
TlsInternalServer, TlsSynaSock,
{$ENDIF}
blcksock, synautil, synacode;
blcksock, synautil;
const
cIMAPProtocol = '143';
type
{:@abstract(Implementation of IMAP4 protocol.)
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TIMAPSend = class(TSynaClient)
private
protected
{$IFDEF STREAMSEC}
FSock: TSsTCPBlockSocket;
FTLSServer: TCustomTLSInternalServer;
@ -76,8 +85,6 @@ type
FResultString: string;
FFullResult: TStringList;
FIMAPcap: TStringList;
FUsername: string;
FPassword: string;
FAuthDone: Boolean;
FSelectedFolder: string;
FSelectedCount: integer;
@ -97,57 +104,171 @@ type
public
constructor Create;
destructor Destroy; override;
{:By this function you can call any IMAP command. Result of this command is
in adequate properties.}
function IMAPcommand(Value: string): string;
{:By this function you can call any IMAP command what need upload any data.
Result of this command is in adequate properties.}
function IMAPuploadCommand(Value: string; const Data:TStrings): string;
{:Call CAPABILITY command and fill IMAPcap property by new values.}
function Capability: Boolean;
{:Connect to IMAP server and do login to this server. This command begin
session.}
function Login: Boolean;
procedure Logout;
{:Disconnect from IMAP server and terminate session session. If exists some
deleted and non-purged messages, these messages are not deleted!}
function Logout: Boolean;
{:Do NOOP. It is for prevent disconnect by timeout.}
function NoOp: Boolean;
{:Lists folder names. You may specify level of listing. If you specify
FromFolder as empty string, return is all folders in system.}
function List(FromFolder: string; const FolderList: TStrings): Boolean;
{:Lists folder names what match search criteria. You may specify level of
listing. If you specify FromFolder as empty string, return is all folders
in system.}
function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
{:Lists subscribed folder names. You may specify level of listing. If you
specify FromFolder as empty string, return is all subscribed folders in
system.}
function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
{:Lists subscribed folder names what matching search criteria. You may
specify level of listing. If you specify FromFolder as empty string, return
is all subscribed folders in system.}
function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
{:Create a new folder.}
function CreateFolder(FolderName: string): Boolean;
{:Delete a folder.}
function DeleteFolder(FolderName: string): Boolean;
{:Rename folder names.}
function RenameFolder(FolderName, NewFolderName: string): Boolean;
{:Subscribe folder.}
function SubscribeFolder(FolderName: string): Boolean;
{:Unsubscribe folder.}
function UnsubscribeFolder(FolderName: string): Boolean;
{:Select folder.}
function SelectFolder(FolderName: string): Boolean;
{:Select folder, but only for reading. Any changes are not allowed!}
function SelectROFolder(FolderName: string): Boolean;
{:Close a folder. (end of Selected state)}
function CloseFolder: Boolean;
{:Ask for given status of folder. I.e. if you specify as value 'UNSEEN',
result is number of unseen messages in folder. For another status
indentificator check IMAP documentation and documentation of your IMAP
server (each IMAP server can have their own statuses.)}
function StatusFolder(FolderName, Value: string): integer;
{:Hardly delete all messages marked as 'deleted' in current selected folder.}
function ExpungeFolder: Boolean;
{:Touch to folder. (use as update status of folder, etc.)}
function CheckFolder: Boolean;
{:Append given message to specified folder.}
function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
{:'Delete' message from currect selected folder. It mark message as Deleted.
Real deleting waill be done after sucessfull @link(CloseFolder) or
@link(ExpungeFolder)}
function DeleteMess(MessID: integer): boolean;
{:Get full message from specified message in selected folder.}
function FetchMess(MessID: integer; const Mess: TStrings): Boolean;
{:Get message headers only from specified message in selected folder.}
function FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
{:Return message size of specified message from current selected folder.}
function MessageSize(MessID: integer): integer;
{:Copy message from current selected folder to another folder.}
function CopyMess(MessID: integer; ToFolder: string): Boolean;
{:Return message numbers from currently selected folder as result
of searching. Search criteria is very complex language (see to IMAP
specification) similar to SQL (but not same syntax!).}
function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
{:Sets flags of message from current selected folder.}
function SetFlagsMess(MessID: integer; Flags: string): Boolean;
{:Gets flags of message from current selected folder.}
function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
{:Add flags to message's flags.}
function AddFlagsMess(MessID: integer; Flags: string): Boolean;
{:Remove flags from message's flags.}
function DelFlagsMess(MessID: integer; Flags: string): Boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:return UID of requested message ID.}
function GetUID(MessID: integer; var UID : Integer): Boolean;
{:Try to find given capabily in capabilty string returned from IMAP server.}
function FindCap(const Value: string): string;
published
{:Status line with result of last operation.}
property ResultString: string read FResultString;
{:Full result of last IMAP operation.}
property FullResult: TStringList read FFullResult;
{:List of server capabilites.}
property IMAPcap: TStringList read FIMAPcap;
property Username: string read FUsername Write FUsername;
property Password: string read FPassword Write FPassword;
{:Authorization is successful done.}
property AuthDone: Boolean read FAuthDone;
{:Turn on or off usage of UID (unicate identificator) of messages instead
only sequence numbers.}
property UID: Boolean read FUID Write FUID;
{:Name of currently selected folder.}
property SelectedFolder: string read FSelectedFolder;
{:Count of messages in currently selected folder.}
property SelectedCount: integer read FSelectedCount;
{:Count of not-visited messages in currently selected folder.}
property SelectedRecent: integer read FSelectedRecent;
{:This number with name of folder is unique indentificator of folder.
(If someone delete folder and next create new folder with exactly same name
of folder, this number is must be different!)}
property SelectedUIDvalidity: integer read FSelectedUIDvalidity;
{:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{$IFDEF STREAMSEC}
property Sock: TSsTCPBlockSocket read FSock;
property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
{$ELSE}
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{$ENDIF}
end;
@ -171,8 +292,6 @@ begin
FSock.SizeSendBuffer := 32768;
FTimeout := 60000;
FTargetPort := cIMAPProtocol;
FUsername := '';
FPassword := '';
FTagCommand := 0;
FSelectedFolder := '';
FSelectedCount := 0;
@ -222,8 +341,8 @@ begin
end;
end;
until FSock.LastError <> 0;
s := separateright(FResultString, ' ');
Result:=uppercase(separateleft(s, ' '));
s := Trim(separateright(FResultString, ' '));
Result:=uppercase(Trim(separateleft(s, ' ')));
end;
procedure TIMAPSend.ProcessLiterals;
@ -338,20 +457,20 @@ begin
s := uppercase(FFullResult[n]);
if Pos(' EXISTS', s) > 0 then
begin
t := separateleft(s, ' EXISTS');
t := separateright(t, '* ');
t := Trim(separateleft(s, ' EXISTS'));
t := Trim(separateright(t, '* '));
FSelectedCount := StrToIntDef(t, 0);
end;
if Pos(' RECENT', s) > 0 then
begin
t := separateleft(s, ' RECENT');
t := separateright(t, '* ');
t := Trim(separateleft(s, ' RECENT'));
t := Trim(separateright(t, '* '));
FSelectedRecent := StrToIntDef(t, 0);
end;
if Pos('UIDVALIDITY', s) > 0 then
begin
t := separateright(s, 'UIDVALIDITY ');
t := separateleft(t, ']');
t := Trim(separateright(s, 'UIDVALIDITY '));
t := Trim(separateleft(t, ']'));
FSelectedUIDvalidity := StrToIntDef(t, 0);
end;
end;
@ -369,7 +488,7 @@ begin
s := uppercase(FFullResult[n]);
if Pos('* SEARCH', s) = 1 then
begin
s := SeparateRight(s, '* SEARCH');
s := Trim(SeparateRight(s, '* SEARCH'));
while s <> '' do
Value.Add(Fetch(s, ' '));
end;
@ -436,11 +555,11 @@ begin
for n := 0 to FFullResult.Count - 1 do
if Pos('* CAPABILITY ', FFullResult[n]) = 1 then
begin
s := SeparateRight(FFullResult[n], '* CAPABILITY ');
s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY '));
while not (s = '') do
begin
t := separateleft(s, ' ');
s := separateright(s, ' ');
t := Trim(separateleft(s, ' '));
s := Trim(separateright(s, ' '));
if s = t then
s := '';
FIMAPcap.Add(t);
@ -481,9 +600,9 @@ begin
Result := AuthLogin;
end;
procedure TIMAPSend.Logout;
function TIMAPSend.Logout: Boolean;
begin
IMAPcommand('LOGOUT');
Result := IMAPcommand('LOGOUT') = 'OK';
FSelectedFolder := '';
FSock.CloseSocket;
end;
@ -499,12 +618,24 @@ begin
ParseFolderList(FolderList);
end;
function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
begin
Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK';
ParseFolderList(FolderList);
end;
function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
begin
Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK';
ParseFolderList(FolderList);
end;
function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
begin
Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK';
ParseFolderList(FolderList);
end;
function TIMAPSend.CreateFolder(FolderName: string): Boolean;
begin
Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK';
@ -641,8 +772,7 @@ begin
if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then
begin
t := SeparateRight(s, 'RFC822.SIZE ');
t := SeparateLeft(t, ')');
t := trim(t);
t := Trim(SeparateLeft(t, ')'));
Result := StrToIntDef(t, -1);
Break;
end;
@ -719,7 +849,7 @@ begin
begin
s := SeparateRight(s, 'FLAGS');
s := Separateright(s, '(');
Flags := SeparateLeft(s, ')');
Flags := Trim(SeparateLeft(s, ')'));
end;
end;
end;
@ -760,7 +890,7 @@ begin
if Pos('FETCH (UID', s) >= 1 then
begin
s := Separateright(s, '(UID ');
sUID := SeparateLeft(s, ')');
sUID := Trim(SeparateLeft(s, ')'));
end;
end;
UID := StrToIntDef(sUID, 0);

163
ldapsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.011 |
| Project : Ararat Synapse | 001.002.001 |
|==============================================================================|
| Content: LDAP client |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003. |
| Portions created by Lukas Gebauer are Copyright (c)2003-2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -42,7 +42,10 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-2251, RFC-2254, RFC-2829, RFC-2830
{:@abstract(LDAP client)
Used RFC: RFC-2251, RFC-2254, RFC-2829, RFC-2830
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -54,7 +57,7 @@ unit ldapsend;
interface
uses
Classes, SysUtils,
SysUtils, Classes,
{$IFDEF STREAMSEC}
TlsInternalServer, TlsSynaSock,
{$ENDIF}
@ -87,6 +90,9 @@ const
type
{:@abstract(LDAP attribute with list of their values)
This class holding name of LDAP attribute and list of their values. This is
descendant of TStringList class enhanced by some new properties.}
TLDAPAttribute = class(TStringList)
private
FAttributeName: string;
@ -96,10 +102,14 @@ type
procedure Put(Index: integer; const Value: string); override;
procedure SetAttributeName(Value: string);
published
{:Name of LDAP attribute.}
property AttributeName: string read FAttributeName Write SetAttributeName;
{:Return @true when attribute contains binary data.}
property IsBinary: Boolean read FIsBinary;
end;
{:@abstract(List of @link(TLDAPAttribute))
This object can hold list of TLDAPAttribute objects.}
TLDAPAttributeList = class(TObject)
private
FAttributeList: TList;
@ -107,12 +117,19 @@ type
public
constructor Create;
destructor Destroy; override;
{:Clear list.}
procedure Clear;
{:Return count of TLDAPAttribute objects in list.}
function Count: integer;
{:Add new TLDAPAttribute object to list.}
function Add: TLDAPAttribute;
{:List of TLDAPAttribute objects.}
property Items[Index: Integer]: TLDAPAttribute read GetAttribute; default;
end;
{:@abstract(LDAP result object)
This object can hold LDAP object. (their name and all their attributes with
values)}
TLDAPResult = class(TObject)
private
FObjectName: string;
@ -121,10 +138,14 @@ type
constructor Create;
destructor Destroy; override;
published
{:Name of this LDAP object.}
property ObjectName: string read FObjectName write FObjectName;
{:Here is list of object attributes.}
property Attributes: TLDAPAttributeList read FAttributes;
end;
{:@abstract(List of LDAP result objects)
This object can hold list of LDAP objects. (for example result of LDAP SEARCH.)}
TLDAPResultList = class(TObject)
private
FResultList: TList;
@ -132,24 +153,31 @@ type
public
constructor Create;
destructor Destroy; override;
{:Clear all TLDAPResult objects in list.}
procedure Clear;
{:Return count of TLDAPResult objects in list.}
function Count: integer;
{:Create and add new TLDAPResult object to list.}
function Add: TLDAPResult;
{:List of TLDAPResult objects.}
property Items[Index: Integer]: TLDAPResult read GetResult; default;
end;
{:Define possible operations for LDAP MODIFY operations.}
TLDAPModifyOp = (
MO_Add,
MO_Delete,
MO_Replace
);
{:Specify possible values for search scope.}
TLDAPSearchScope = (
SS_BaseObject,
SS_SingleLevel,
SS_WholeSubtree
);
{:Specify possible values about alias dereferencing.}
TLDAPSearchAliases = (
SA_NeverDeref,
SA_InSearching,
@ -157,6 +185,14 @@ type
SA_Always
);
{:@abstract(Implementation of LDAP client)
(version 2 and 3)
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TLDAPSend = class(TSynaClient)
private
{$IFDEF STREAMSEC}
@ -168,8 +204,6 @@ type
FResultCode: Integer;
FResultString: string;
FFullResult: string;
FUsername: string;
FPassword: string;
FAutoTLS: Boolean;
FFullSSL: Boolean;
FSeq: integer;
@ -194,46 +228,114 @@ type
public
constructor Create;
destructor Destroy; override;
{:Try to connect to LDAP server and start secure channel, when it is required.}
function Login: Boolean;
{:Try to bind to LDAP server with @link(TSynaClient.Username) and
@link(TSynaClient.Password). If this is empty strings, then it do annonymous
Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous
mode.
This method using plaintext transport of password! It is not secure!}
function Bind: Boolean;
{:Try to bind to LDAP server with @link(TSynaClient.Username) and
@link(TSynaClient.Password). If this is empty strings, then it do annonymous
Bind. When you not call Bind on LDAPv3, then is automaticly used anonymous
mode.
This method using SASL with DIGEST-MD5 method for secure transfer of your
password.}
function BindSasl: Boolean;
procedure Logout;
{:Close connection to LDAP server.}
function Logout: Boolean;
{:Modify content of LDAP attribute on this object.}
function Modify(obj: string; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean;
{:Add list of attributes to specified object.}
function Add(obj: string; const Value: TLDAPAttributeList): Boolean;
{:Delete this LDAP object from server.}
function Delete(obj: string): Boolean;
{:Modify object name of this LDAP object.}
function ModifyDN(obj, newRDN, newSuperior: string; DeleteoldRDN: Boolean): Boolean;
{:Try to compare Attribute value with this LDAP object.}
function Compare(obj, AttributeValue: string): Boolean;
{:Search LDAP base for LDAP objects by Filter.}
function Search(obj: string; TypesOnly: Boolean; Filter: string;
const Attributes: TStrings): Boolean;
{:Call any LDAPv3 extended command.}
function Extended(const Name, Value: string): Boolean;
{:Try to start SSL/TLS connection to LDAP server.}
function StartTLS: Boolean;
published
{:Specify version of used LDAP protocol. Default value is 3.}
property Version: integer read FVersion Write FVersion;
{:Result code of last LDAP operation.}
property ResultCode: Integer read FResultCode;
{:Human readable description of result code of last LDAP operation.}
property ResultString: string read FResultString;
{:Binary string with full last response of LDAP server. This string is
encoded by ASN.1 BER encoding! You need this only for debugging.}
property FullResult: string read FFullResult;
property Username: string read FUsername Write FUsername;
property Password: string read FPassword Write FPassword;
{:If @true, then try to start TSL mode in Login procedure.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:If @true, then use connection to LDAP server through SSL/TLS tunnel.}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Sequence number of last LDAp command. It is incremented by any LDAP command.}
property Seq: integer read FSeq;
{:Specify what search scope is used in search command.}
property SearchScope: TLDAPSearchScope read FSearchScope Write FSearchScope;
{:Specify how to handle aliases in search command.}
property SearchAliases: TLDAPSearchAliases read FSearchAliases Write FSearchAliases;
{:Specify result size limit in search command. Value 0 means without limit.}
property SearchSizeLimit: integer read FSearchSizeLimit Write FSearchSizeLimit;
{:Specify search time limit in search command (seconds). Value 0 means
without limit.}
property SearchTimeLimit: integer read FSearchTimeLimit Write FSearchTimeLimit;
{:Here is result of search command.}
property SearchResult: TLDAPResultList read FSearchResult;
{:On each LDAP operation can LDAP server return some referals URLs. Here is
their list.}
property Referals: TStringList read FReferals;
{:When you call @link(Extended) operation, then here is result Name returned
by server.}
property ExtName: string read FExtName;
{:When you call @link(Extended) operation, then here is result Value returned
by server.}
property ExtValue: string read FExtValue;
{$IFDEF STREAMSEC}
property Sock: TSsTCPBlockSocket read FSock;
property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
{$ELSE}
{:TCP socket used by all LDAP operations.}
property Sock: TTCPBlockSocket read FSock;
{$ENDIF}
end;
{:Dump result of LDAP SEARCH into human readable form. Good for debugging.}
function LDAPResultDump(const Value: TLDAPResultList): string;
implementation
@ -382,8 +484,6 @@ begin
{$ENDIF}
FTimeout := 60000;
FTargetPort := cLDAPProtocol;
FUsername := '';
FPassword := '';
FAutoTLS := False;
FFullSSL := False;
FSeq := 0;
@ -625,10 +725,10 @@ begin
l.CommaText := Value;
n := IndexByBegin('nonce=', l);
if n >= 0 then
nonce := UnQuoteStr(SeparateRight(l[n], 'nonce='), '"');
nonce := UnQuoteStr(Trim(SeparateRight(l[n], 'nonce=')), '"');
n := IndexByBegin('realm=', l);
if n >= 0 then
realm := UnQuoteStr(SeparateRight(l[n], 'realm='), '"');
realm := UnQuoteStr(Trim(SeparateRight(l[n], 'realm=')), '"');
cnonce := IntToHex(GetTick, 8);
nc := '00000001';
qop := 'auth';
@ -671,17 +771,17 @@ begin
'!':
// NOT rule (recursive call)
begin
Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $82);
Result := ASNOBject(TranslateFilter(GetBetween('(', ')', s)), $A2);
end;
'&':
// AND rule (recursive call)
begin
repeat
t := GetBetween('(', ')', s);
s := SeparateRight(s, t);
s := Trim(SeparateRight(s, t));
if s <> '' then
if s[1] = ')' then
System.Delete(s, 1, 1);
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1);
Result := Result + TranslateFilter(t);
until s = '';
Result := ASNOBject(Result, $A0);
@ -691,18 +791,18 @@ begin
begin
repeat
t := GetBetween('(', ')', s);
s := SeparateRight(s, t);
s := Trim(SeparateRight(s, t));
if s <> '' then
if s[1] = ')' then
System.Delete(s, 1, 1);
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(s, 1, 1);
Result := Result + TranslateFilter(t);
until s = '';
Result := ASNOBject(Result, $A1);
end;
else
begin
l := SeparateLeft(s, '=');
r := SeparateRight(s, '=');
l := Trim(SeparateLeft(s, '='));
r := Trim(SeparateRight(s, '='));
if l <> '' then
begin
c := l[Length(l)];
@ -710,7 +810,7 @@ begin
':':
// Extensible match
begin
System.Delete(l, Length(l), 1);
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
dn := False;
attr := '';
rule := '';
@ -719,8 +819,8 @@ begin
dn := True;
l := ReplaceString(l, ':dn', '');
end;
attr := SeparateLeft(l, ':');
rule := SeparateRight(l, ':');
attr := Trim(SeparateLeft(l, ':'));
rule := Trim(SeparateRight(l, ':'));
if rule = l then
rule := '';
if rule <> '' then
@ -737,7 +837,7 @@ begin
'~':
// Approx match
begin
System.Delete(l, Length(l), 1);
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
Result := ASNOBject(l, ASN1_OCTSTR)
+ ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
Result := ASNOBject(Result, $a8);
@ -745,7 +845,7 @@ begin
'>':
// Greater or equal match
begin
System.Delete(l, Length(l), 1);
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
Result := ASNOBject(l, ASN1_OCTSTR)
+ ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
Result := ASNOBject(Result, $a5);
@ -753,7 +853,7 @@ begin
'<':
// Less or equal match
begin
System.Delete(l, Length(l), 1);
{$IFDEF CIL}Borland.Delphi.{$ENDIF}System.Delete(l, Length(l), 1);
Result := ASNOBject(l, ASN1_OCTSTR)
+ ASNOBject(DecodeTriplet(r, '\'), ASN1_OCTSTR);
Result := ASNOBject(Result, $a6);
@ -802,7 +902,7 @@ begin
Exit;
Result := True;
if FAutoTLS then
StartTLS;
Result := StartTLS;
end;
function TLDAPSend.Bind: Boolean;
@ -861,10 +961,11 @@ begin
end;
end;
procedure TLDAPSend.Logout;
function TLDAPSend.Logout: Boolean;
begin
Fsock.SendString(BuildPacket(ASNObject('', LDAP_ASN1_UNBIND_REQUEST)));
FSock.CloseSocket;
Result := True;
end;
function TLDAPSend.Modify(obj: string; Op: TLDAPModifyOp; const Value: TLDAPAttribute): Boolean;
@ -942,8 +1043,8 @@ function TLDAPSend.Compare(obj, AttributeValue: string): Boolean;
var
s: string;
begin
s := ASNObject(SeparateLeft(AttributeValue, '='), ASN1_OCTSTR)
+ ASNObject(SeparateRight(AttributeValue, '='), ASN1_OCTSTR);
s := ASNObject(Trim(SeparateLeft(AttributeValue, '=')), ASN1_OCTSTR)
+ ASNObject(Trim(SeparateRight(AttributeValue, '=')), ASN1_OCTSTR);
s := ASNObject(obj, ASN1_OCTSTR) + ASNObject(s, ASN1_SEQ);
s := ASNObject(s, LDAP_ASN1_COMPARE_REQUEST);
Fsock.SendString(BuildPacket(s));

66
mimeinln.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.002 |
| Project : Ararat Synapse | 001.001.008 |
|==============================================================================|
| Content: Inline MIME support procedures and functions |
|==============================================================================|
@ -42,7 +42,11 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-1522
{:@abstract(Utilities for inline MIME)
Support for Inline MIME encoding and decoding.
Used RFC: RFC-2047, RFC-2231
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -57,12 +61,30 @@ uses
SysUtils, Classes,
synachar, synacode, synautil;
{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".}
function InlineDecode(const Value: string; CP: TMimeChar): string;
{:Encodes string to MIME inline encoding. The source characterset is "CP", and
the target charset is "MimeP".}
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
function NeedInline(const Value: string): boolean;
{:Returns @true, if "Value" contains characters needed for inline coding.}
function NeedInline(const Value: AnsiString): boolean;
{:Inline mime encoding similar to @link(InlineEncode), but you can specify
source charset, and the target characterset is automatically assigned.}
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
{:Inline MIME encoding similar to @link(InlineEncode), but the source charset
is automatically set to the system default charset, and the target charset is
automatically assigned from set of allowed encoding for MIME.}
function InlineCode(const Value: string): string;
{:Converts e-mail address to canonical mime form. You can specify source charset.}
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
{:Converts e-mail address to canonical mime form. Source charser it system
default charset.}
function InlineEmail(const Value: string): string;
implementation
@ -110,10 +132,10 @@ begin
s := Copy(v, x, y - x + 2);
Delete(v, 1, y + 1);
su := Copy(s, 3, Length(s) - 4);
ichar := GetCPFromID(su);
z := Pos('?', su);
if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
begin
ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*'));
c := UpperCase(su)[z + 1];
su := Copy(su, z + 3, Length(su) - z - 2);
if c = 'B' then
@ -144,29 +166,46 @@ end;
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
var
s, s1: string;
s, s1, e: string;
n: Integer;
begin
s := CharsetConversion(Value, CP, MimeP);
s := EncodeQuotedPrintable(s);
s := EncodeSafeQuotedPrintable(s);
e := GetIdFromCP(MimeP);
s1 := '';
Result := '';
for n := 1 to Length(s) do
if s[n] = ' ' then
s1 := s1 + '=20'
begin
// s1 := s1 + '=20';
s1 := s1 + '_';
if Length(s1) > 32 then
begin
if Result <> '' then
Result := Result + ' ';
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
s1 := '';
end;
end
else
s1 := s1 + s[n];
Result := '=?' + GetIdFromCP(MimeP) + '?Q?' + s1 + '?=';
if s1 <> '' then
begin
if Result <> '' then
Result := Result + ' ';
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
end;
end;
{==============================================================================}
function NeedInline(const Value: string): boolean;
function NeedInline(const Value: AnsiString): boolean;
var
n: Integer;
begin
Result := False;
for n := 1 to Length(Value) do
if Value[n] in (SpecialChar + [Char(1)..Char(31), Char(128)..Char(255)]) then
if Value[n] in (SpecialChar + NonAsciiChar) then
begin
Result := True;
Break;
@ -183,7 +222,12 @@ begin
begin
c := IdealCharsetCoding(Value, FromCP,
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10,
KOI8_R, KOI8_U
{$IFNDEF CIL} //error URW778 ??? :-O
, GB2312, EUC_KR, ISO_2022_JP, EUC_TW
{$ENDIF}
]);
Result := InlineEncode(Value, FromCP, c);
end
else

434
mimemess.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 002.002.003 |
| Project : Ararat Synapse | 002.004.003 |
|==============================================================================|
| Content: MIME message object |
|==============================================================================|
@ -42,6 +42,10 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(MIME message handling)
Classes for easy handling with e-mail message.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
@ -56,6 +60,11 @@ uses
mimepart, synachar, synautil, mimeinln;
type
{:Possible values for message priority}
TMessPriority = (MP_unknown, MP_low, MP_normal, MP_high);
{:@abstract(Object for basic e-mail header fields.)}
TMessHeader = class(TObject)
private
FFrom: string;
@ -67,26 +76,87 @@ type
FDate: TDateTime;
FXMailer: string;
FCharsetCode: TMimeChar;
FReplyTo: string;
FMessageID: string;
FPriority: TMessPriority;
Fpri: TMessPriority;
Fxpri: TMessPriority;
Fxmspri: TMessPriority;
protected
function ParsePriority(value: string): TMessPriority;
function DecodeHeader(value: string): boolean; virtual;
public
constructor Create;
constructor Create; virtual;
destructor Destroy; override;
{:Clears all data fields.}
procedure Clear;
procedure EncodeHeaders(const Value: TStrings);
{Add headers from from this object to Value.}
procedure EncodeHeaders(const Value: TStrings); virtual;
{:Parse header from Value to this object.}
procedure DecodeHeaders(const Value: TStrings);
{:Try find specific header in CustomHeader. Search is case insensitive.
This is good for reading any non-parsed header.}
function FindHeader(Value: string): string;
{:Try find specific headers in CustomHeader. This metod is for repeatly used
headers like 'received' header, etc. Search is case insensitive.
This is good for reading ano non-parsed header.}
procedure FindHeaderList(Value: string; const HeaderList: TStrings);
published
{:Sender of message.}
property From: string read FFrom Write FFrom;
{:Stringlist with receivers of message. (one per line)}
property ToList: TStringList read FToList;
{:Stringlist with Carbon Copy receivers of message. (one per line)}
property CCList: TStringList read FCCList;
{:Subject of message.}
property Subject: string read FSubject Write FSubject;
{:Organization string.}
property Organization: string read FOrganization Write FOrganization;
{:After decoding contains all headers lines witch not have parsed to any
other structures in this object. It mean: this conatins all other headers
except:
X-MAILER, FROM, SUBJECT, ORGANIZATION, TO, CC, DATE, MIME-VERSION,
CONTENT-TYPE, CONTENT-DESCRIPTION, CONTENT-DISPOSITION, CONTENT-ID,
CONTENT-TRANSFER-ENCODING, REPLY-TO, MESSAGE-ID, X-MSMAIL-PRIORITY,
X-PRIORITY, PRIORITY
When you encode headers, all this lines is added as headers. Be carefull
for duplicites!}
property CustomHeaders: TStringList read FCustomHeaders;
{:Date and time of message.}
property Date: TDateTime read FDate Write FDate;
{:Mailer identification.}
property XMailer: string read FXMailer Write FXMailer;
{:Address for replies}
property ReplyTo: string read FReplyTo Write FReplyTo;
{:message indetifier}
property MessageID: string read FMessageID Write FMessageID;
{:message priority}
property Priority: TMessPriority read FPriority Write FPriority;
{:Specify base charset. By default is used system charset.}
property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
end;
TMessHeaderClass = class of TMessHeader;
{:@abstract(Object for handling of e-mail message.)}
TMimeMess = class(TObject)
private
FMessagePart: TMimePart;
@ -94,23 +164,111 @@ type
FHeader: TMessHeader;
public
constructor Create;
{:create this object and assign your own descendant of @link(TMessHeader)
object to @link(header) property. So, you can create your own message
headers parser and use it by this object.}
constructor CreateAltHeaders(HeadClass: TMessHeaderClass);
destructor Destroy; override;
{:Reset component to default state.}
procedure Clear;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then one subpart,
you must have PartParent of multipart type!}
function AddPart(const PartParent: TMimePart): TMimePart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
This part is marked as multipart with secondary MIME type specified by
MultipartType parameter. (typical value is 'mixed')
This part can be used as PartParent for another parts (include next
multipart). If you need only one part, then you not need Multipart part.}
function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to text part and set all necessary
properties. Content of part is readed from value stringlist.}
function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to text part to HTML type and set all
necessary properties. Content of HTML part is readed from Value stringlist.}
function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartText), but content is readed from file}
function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartHTML), but content is readed from file}
function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart,
you must have PartParent of multipart type!
After creation of part set type to binary and set all necessary properties.
MIME primary and secondary types defined automaticly by filename extension.
Content of binary part is readed from Stream. This binary part is encoded
as file attachment.}
function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartBinary), but content is readed from file}
function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to binary and set all necessary properties.
MIME primary and secondary types defined automaticly by filename extension.
Content of binary part is readed from Stream.
This binary part is encoded as inline data with given Conten ID (cid).
Content ID can be used as reference ID in HTML source in HTML part.}
function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartHTMLBinary), but content is readed from file}
function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to message and set all necessary properties.
MIME primary and secondary types are setted to 'message/rfc822'.
Content of raw RFC-822 message is readed from Stream.}
function AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartMess), but content is readed from file}
function AddPartMessFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
{:Compose message from @link(MessagePart) to @link(Lines). Headers from
@link(Header) object is added also.}
procedure EncodeMessage;
{:Decode message from @link(Lines) to @link(MessagePart). Massage headers
are parsed into @link(Header) object.}
procedure DecodeMessage;
published
{:@link(TMimePart) object with decoded MIME message. This object can handle
any number of nested @link(TMimePart) objects itself. It is used for handle
any tree of MIME subparts.}
property MessagePart: TMimePart read FMessagePart;
{:Raw MIME encoded message.}
property Lines: TStringList read FLines;
{:Object for e-mail header fields. This object is created automaticly.
Do not free this object!}
property Header: TMessHeader read FHeader;
end;
@ -147,6 +305,9 @@ begin
FCustomHeaders.Clear;
FDate := 0;
FXMailer := '';
FReplyTo := '';
FMessageID := '';
FPriority := MP_unknown;
end;
procedure TMessHeader.EncodeHeaders(const Value: TStrings);
@ -159,8 +320,27 @@ begin
for n := FCustomHeaders.Count - 1 downto 0 do
if FCustomHeaders[n] <> '' then
Value.Insert(0, FCustomHeaders[n]);
if FPriority <> MP_unknown then
case FPriority of
MP_high:
begin
Value.Insert(0, 'X-MSMAIL-Priority: High');
Value.Insert(0, 'X-Priority: 1');
Value.Insert(0, 'Priority: urgent');
end;
MP_low:
begin
Value.Insert(0, 'X-MSMAIL-Priority: low');
Value.Insert(0, 'X-Priority: 5');
Value.Insert(0, 'Priority: non-urgent');
end;
end;
if FReplyTo <> '' then
Value.Insert(0, 'Reply-To: ' + GetEmailAddr(FReplyTo));
if FMessageID <> '' then
Value.Insert(0, 'Message-ID: <' + trim(FMessageID) + '>');
if FXMailer = '' then
Value.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer')
Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer')
else
Value.Insert(0, 'X-mailer: ' + FXMailer);
Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
@ -188,79 +368,156 @@ begin
Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
end;
procedure TMessHeader.DecodeHeaders(const Value: TStrings);
function TMessHeader.ParsePriority(value: string): TMessPriority;
var
s: string;
x: integer;
begin
Result := MP_unknown;
s := Trim(separateright(value, ':'));
s := Separateleft(s, ' ');
x := StrToIntDef(s, -1);
if x >= 0 then
case x of
1, 2:
Result := MP_High;
3:
Result := MP_Normal;
4, 5:
Result := MP_Low;
end
else
begin
s := lowercase(s);
if (s = 'urgent') or (s = 'high') or (s = 'highest') then
Result := MP_High;
if (s = 'normal') or (s = 'medium') then
Result := MP_Normal;
if (s = 'low') or (s = 'lowest')
or (s = 'no-priority') or (s = 'non-urgent') then
Result := MP_Low;
end;
end;
function TMessHeader.DecodeHeader(value: string): boolean;
var
s, t: string;
x: Integer;
cp: TMimeChar;
begin
Result := True;
cp := FCharsetCode;
s := uppercase(value);
if Pos('X-MAILER:', s) = 1 then
begin
FXMailer := Trim(SeparateRight(Value, ':'));
Exit;
end;
if Pos('FROM:', s) = 1 then
begin
FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('SUBJECT:', s) = 1 then
begin
FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('ORGANIZATION:', s) = 1 then
begin
FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('TO:', s) = 1 then
begin
s := Trim(SeparateRight(Value, ':'));
repeat
t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
if t <> '' then
FToList.Add(t);
until s = '';
Exit;
end;
if Pos('CC:', s) = 1 then
begin
s := Trim(SeparateRight(Value, ':'));
repeat
t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
if t <> '' then
FCCList.Add(t);
until s = '';
Exit;
end;
if Pos('DATE:', s) = 1 then
begin
FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':')));
Exit;
end;
if Pos('REPLY-TO:', s) = 1 then
begin
FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('MESSAGE-ID:', s) = 1 then
begin
FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':')));
Exit;
end;
if Pos('PRIORITY:', s) = 1 then
begin
FPri := ParsePriority(value);
Exit;
end;
if Pos('X-PRIORITY:', s) = 1 then
begin
FXPri := ParsePriority(value);
Exit;
end;
if Pos('X-MSMAIL-PRIORITY:', s) = 1 then
begin
FXmsPri := ParsePriority(value);
Exit;
end;
if Pos('MIME-VERSION:', s) = 1 then
Exit;
if Pos('CONTENT-TYPE:', s) = 1 then
Exit;
if Pos('CONTENT-DESCRIPTION:', s) = 1 then
Exit;
if Pos('CONTENT-DISPOSITION:', s) = 1 then
Exit;
if Pos('CONTENT-ID:', s) = 1 then
Exit;
if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then
Exit;
Result := False;
end;
procedure TMessHeader.DecodeHeaders(const Value: TStrings);
var
s: string;
x: Integer;
begin
Clear;
Fpri := MP_unknown;
Fxpri := MP_unknown;
Fxmspri := MP_unknown;
x := 0;
while Value.Count > x do
begin
s := NormalizeHeader(Value, x);
if s = '' then
Break;
if Pos('X-MAILER:', UpperCase(s)) = 1 then
begin
FXMailer := SeparateRight(s, ':');
continue;
end;
if Pos('FROM:', UpperCase(s)) = 1 then
begin
FFrom := InlineDecode(SeparateRight(s, ':'), cp);
continue;
end;
if Pos('SUBJECT:', UpperCase(s)) = 1 then
begin
FSubject := InlineDecode(SeparateRight(s, ':'), cp);
continue;
end;
if Pos('ORGANIZATION:', UpperCase(s)) = 1 then
begin
FOrganization := InlineDecode(SeparateRight(s, ':'), cp);
continue;
end;
if Pos('TO:', UpperCase(s)) = 1 then
begin
s := SeparateRight(s, ':');
repeat
t := InlineDecode(FetchEx(s, ',', '"'), cp);
if t <> '' then
FToList.Add(t);
until s = '';
continue;
end;
if Pos('CC:', UpperCase(s)) = 1 then
begin
s := SeparateRight(s, ':');
repeat
t := InlineDecode(FetchEx(s, ',', '"'), cp);
if t <> '' then
FCCList.Add(t);
until s = '';
continue;
end;
if Pos('DATE:', UpperCase(s)) = 1 then
begin
FDate := DecodeRfcDateTime(SeparateRight(s, ':'));
continue;
end;
if Pos('MIME-VERSION:', UpperCase(s)) = 1 then
continue;
if Pos('CONTENT-TYPE:', UpperCase(s)) = 1 then
continue;
if Pos('CONTENT-DESCRIPTION:', UpperCase(s)) = 1 then
continue;
if Pos('CONTENT-DISPOSITION:', UpperCase(s)) = 1 then
continue;
if Pos('CONTENT-ID:', UpperCase(s)) = 1 then
continue;
if Pos('CONTENT-TRANSFER-ENCODING:', UpperCase(s)) = 1 then
continue;
FCustomHeaders.Add(s);
if not DecodeHeader(s) then
FCustomHeaders.Add(s);
end;
if Fpri <> MP_unknown then
FPriority := Fpri
else
if Fxpri <> MP_unknown then
FPriority := Fxpri
else
if Fxmspri <> MP_unknown then
FPriority := Fxmspri
end;
function TMessHeader.FindHeader(Value: string): string;
@ -271,7 +528,7 @@ begin
for n := 0 to FCustomHeaders.Count - 1 do
if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
begin
Result := SeparateRight(FCustomHeaders[n], ':');
Result := Trim(SeparateRight(FCustomHeaders[n], ':'));
break;
end;
end;
@ -284,18 +541,23 @@ begin
for n := 0 to FCustomHeaders.Count - 1 do
if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
begin
HeaderList.Add(SeparateRight(FCustomHeaders[n], ':'));
HeaderList.Add(Trim(SeparateRight(FCustomHeaders[n], ':')));
end;
end;
{==============================================================================}
constructor TMimeMess.Create;
begin
CreateAltHeaders(TMessHeader);
end;
constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass);
begin
inherited Create;
FMessagePart := TMimePart.Create;
FLines := TStringList.Create;
FHeader := TMessHeader.Create;
FHeader := HeadClass.Create;
end;
destructor TMimeMess.Destroy;
@ -353,7 +615,12 @@ begin
Disposition := 'inline';
CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset,
[ISO_8859_1, ISO_8859_2, ISO_8859_3, ISO_8859_4, ISO_8859_5,
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10]);
ISO_8859_6, ISO_8859_7, ISO_8859_8, ISO_8859_9, ISO_8859_10,
KOI8_R, KOI8_U
{$IFNDEF CIL} //error URW778 ??? :-O
, GB2312, EUC_KR, ISO_2022_JP, EUC_TW
{$ENDIF}
]);
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
EncodePartHeader;
@ -456,6 +723,37 @@ begin
end;
end;
function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
var
part: Tmimepart;
begin
Result := AddPart(PartParent);
part := AddPart(result);
part.lines.addstrings(Value);
part.DecomposeParts;
with Result do
begin
Primary := 'message';
Secondary := 'rfc822';
Description := 'E-mail Message';
EncodePart;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
tmp: TStrings;
begin
tmp := TStringList.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartMess(tmp, PartParent);
Finally
tmp.Free;
end;
end;
{==============================================================================}
procedure TMimeMess.EncodeMessage;

274
mimepart.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.004.008 |
| Project : Ararat Synapse | 002.006.002 |
|==============================================================================|
| Content: MIME support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -42,10 +42,18 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(MIME part handling)
Handling with MIME parts.
Used RFC: RFC-2045
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$Q-}
{$R-}
unit mimepart;
@ -65,14 +73,41 @@ uses
type
TMimePart = class;
{:@abstract(Procedural type for @link(TMimepart.Walkpart) hook). This hook is used for
easy walking through MIME subparts.}
THookWalkPart = procedure(const Sender: TMimePart) of object;
TMimePrimary = (MP_TEXT, MP_MULTIPART,
MP_MESSAGE, MP_BINARY);
{:The four types of MIME parts. (textual, multipart, message or any other
binary data.)}
TMimePrimary = (MP_TEXT, MP_MULTIPART, MP_MESSAGE, MP_BINARY);
{:The various types of possible part encodings.}
TMimeEncoding = (ME_7BIT, ME_8BIT, ME_QUOTED_PRINTABLE,
ME_BASE64, ME_UU, ME_XX);
{:@abstract(Object for working with parts of MIME e-mail.)
Each TMimePart object can handle any number of nested subparts as new
TMimepart objects. It can handle any tree hierarchy structure of nested MIME
subparts itself.
Basic tasks are:
Decoding of MIME message:
- store message into Lines property
- call DecomposeParts. Now you have decomposed MIME parts in all nested levels!
- now you can explore all properties and subparts. (You can use WalkPart method)
- if you need decode part, call DecodePart.
Encoding of MIME message:
- if you need multipart message, you must create subpart by AddSubPart.
- set all properties of all parts.
- set content of part into DecodedLines stream
- encode this stream by EncodePart.
- compose full message by ComposeParts. (it build full MIME message from all subparts. Do not call this method for each subpart! It is needed on root part!)
- encoded MIME message is stored in Lines property.
}
TMimePart = class(TObject)
private
FPrimary: string;
@ -108,48 +143,171 @@ type
public
constructor Create;
destructor Destroy; override;
{:Assign content of another object to this object. (Only this part,
not subparts!)}
procedure Assign(Value: TMimePart);
{:Assign content of another object to this object. (With all subparts!)}
procedure AssignSubParts(Value: TMimePart);
{:Clear all data values to default values. It also call @link(ClearSubparts).}
procedure Clear;
{:Decode Mime part from @link(Lines) to @link(DecodedLines).}
procedure DecodePart;
{:Parse header lines from Headers property into another properties.}
procedure DecodePartHeader;
{:Encode mime part from @link(DecodedLines) to @link(Lines) and build mime
headers.}
procedure EncodePart;
{:Build header lines in Headers property from another properties.}
procedure EncodePartHeader;
{:generate primary and secondary mime type from filename extension in value.
If type not recognised, it return 'Application/octet-string' type.}
procedure MimeTypeFromExt(Value: string);
{:Return number of decomposed subparts. (On this level! Each of this
subparts can hold any number of their own nested subparts!)}
function GetSubPartCount: integer;
{:Get nested subpart object as new TMimePart. For getting maximum possible
index you can use @link(GetSubPartCount) method.}
function GetSubPart(index: integer): TMimePart;
{:delete subpart on given index.}
procedure DeleteSubPart(index: integer);
{:Clear and destroy all subpart TMimePart objects.}
procedure ClearSubParts;
{:Add and create new subpart.}
function AddSubPart: TMimePart;
{:E-mail message in @link(Lines) property is parsed into this object.
E-mail headers are stored in @link(Headers) property and is parsed into
another properties automaticly. Not need call @link(DecodePartHeader)!
Content of message (part) is stored into @link(PartBody) property. This
part is in undecoded form! If you need decode it, then you must call
@link(DecodePart) method by your hands. Lot of another properties is filled
also.
Decoding of parts you must call separately due performance reasons. (Not
needed to decode all parts in all reasons.)
For each MIME subpart is created new TMimepart object (accessible via
method @link(GetSubPart)).}
procedure DecomposeParts;
{:This part and all subparts is composed into one MIME message stored in
@link(Lines) property.}
procedure ComposeParts;
{:By calling this method is called @link(OnWalkPart) event for each part
and their subparts. It is very good for calling some code for each part in
MIME message}
procedure WalkPart;
{:Return @true when is possible create next subpart. (@link(maxSublevel)
is still not reached)}
function CanSubPart: boolean;
published
{:Primary Mime type of part. (i.e. 'application') Writing to this property
automaticly generate value of @link(PrimaryCode).}
property Primary: string read FPrimary write SetPrimary;
{:String representation of used Mime encoding in part. (i.e. 'base64')
Writing to this property automaticly generate value of @link(EncodingCode).}
property Encoding: string read FEncoding write SetEncoding;
{:String representation of used Mime charset in part. (i.e. 'iso-8859-1')
Writing to this property automaticly generate value of @link(CharsetCode).
Charset is used only for text parts.}
property Charset: string read FCharset write SetCharset;
{:Define default charset for decoding text MIME parts without charset
specification. Default value is 'ISO-8859-1' by RCF documents.
But Microsoft Outlook use windows codings as default. This property allows
properly decode textual parts from some broken versions of Microsoft
Outlook. (this is bad software!)}
property DefaultCharset: string read FDefaultCharset write FDefaultCharset;
{:Decoded primary type. Possible values are: MP_TEXT, MP_MULTIPART,
MP_MESSAGE and MP_BINARY. If type not recognised, result is MP_BINARY.}
property PrimaryCode: TMimePrimary read FPrimaryCode Write FPrimaryCode;
{:Decoded encoding type. Possible values are: ME_7BIT, ME_8BIT,
ME_QUOTED_PRINTABLE and ME_BASE64. If type not recognised, result is
ME_7BIT.}
property EncodingCode: TMimeEncoding read FEncodingCode Write FEncodingCode;
{:Decoded charset type. Possible values are defined in @link(SynaChar) unit.}
property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
{:System charset type. Default value is charset used by default in your
operating system.}
property TargetCharset: TMimeChar read FTargetCharset Write FTargetCharset;
{:Secondary Mime type of part. (i.e. 'mixed')}
property Secondary: string read FSecondary Write FSecondary;
{:Description of Mime part.}
property Description: string read FDescription Write FDescription;
{:Value of content disposition field. (i.e. 'inline' or 'attachment')}
property Disposition: string read FDisposition Write FDisposition;
{:Content ID.}
property ContentID: string read FContentID Write FContentID;
{:Boundary delimiter of multipart Mime part. Used only in multipart part.}
property Boundary: string read FBoundary Write FBoundary;
{:Filename of file in binary part.}
property FileName: string read FFileName Write FFileName;
{:String list with lines contains mime part (It can be a full message).}
property Lines: TStringList read FLines;
{:Encoded form of MIME part data.}
property PartBody: TStringList read FPartBody;
{:All header lines of MIME part.}
property Headers: TStringList read FHeaders;
{:On multipart this contains part of message between first line of message
and first boundary.}
property PrePart: TStringList read FPrePart;
{:On multipart this contains part of message between last boundary and end
of message.}
property PostPart: TStringList read FPostPart;
{:Stream with decoded form of budy part.}
property DecodedLines: TMemoryStream read FDecodedLines;
{:Show nested level in subpart tree. Value 0 means root part. 1 means
subpart from this root. etc.}
property SubLevel: integer read FSubLevel write FSubLevel;
{:Specify maximum sublevel value for decomposing.}
property MaxSubLevel: integer read FMaxSubLevel write FMaxSubLevel;
{:When is @true, then this part maybe(!) have included some uuencoded binary
data.}
property AttachInside: boolean read FAttachInside;
{:Here you can assign hook procedure for walking through all part and their
subparts.}
property OnWalkPart: THookWalkPart read FOnWalkPart write FOnWalkPart;
{:Here you can specify maximum line length for encoding of MIME part.
If line is longer, then is splitted by standard of MIME. Correct MIME
mailers can de-split this line into original length.}
property MaxLineLength: integer read FMaxLineLength Write FMaxLineLength;
end;
@ -185,7 +343,11 @@ const
('ZIP', 'application', 'ZIP')
);
{:Read header from "Value" stringlist beginning at "Index" position. If header
is Splitted into multiple lines, then this procedure de-split it into one line.}
function NormalizeHeader(Value: TStrings; var Index: Integer): string;
{:Generates a unique boundary string.}
function GenerateBoundary: string;
implementation
@ -206,7 +368,7 @@ begin
for n := 1 to Length(t) do
if t[n] = #9 then
t[n] := ' ';
if t[1] <> ' ' then
if not(t[1] in [' ', '"', ':', '=']) then
Break
else
begin
@ -401,12 +563,11 @@ begin
//extract prepart
if FPrimaryCode = MP_MULTIPART then
begin
SkipEmpty;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
s := FLines[x];
Inc(x);
if s = '--' + FBoundary then
if TrimRight(s) = '--' + FBoundary then
Break;
FPrePart.Add(s);
if not FAttachInside then
@ -428,7 +589,6 @@ begin
Break;
Mime.Lines.Add(s);
end;
StringsTrim(Mime.Lines);
Mime.DecomposeParts;
end
else
@ -451,26 +611,22 @@ begin
Inc(x);
Mime.Lines.Add(s);
end;
StringsTrim(Mime.Lines);
Mime.DecomposeParts;
end
else
begin
SkipEmpty;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
s := FLines[x];
Inc(x);
FPartBody.Add(s);
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
StringsTrim(FPartBody);
end;
//extract postpart
if FPrimaryCode = MP_MULTIPART then
begin
SkipEmpty;
while FLines.Count > x do
begin
s := TrimRight(FLines[x]);
@ -479,7 +635,6 @@ begin
if not FAttachInside then
FAttachInside := IsUUcode(s);
end;
StringsTrim(FPostPart);
end;
end;
@ -570,7 +725,8 @@ end;
procedure TMIMEPart.DecodePart;
var
n: Integer;
s: string;
s, t: string;
b: Boolean;
begin
FDecodedLines.Clear;
case FEncodingCode of
@ -591,8 +747,27 @@ begin
s := FPartBody.Text;
end;
if FPrimaryCode = MP_TEXT then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
FDecodedLines.Write(Pointer(s)^, Length(s));
if uppercase(FSecondary) = 'HTML' then
begin
b := False;
for n := 0 to FPartBody.Count - 1 do
begin
t := uppercase(FPartBody[n]);
if Pos('HTTP-EQUIV', t) > 0 then
if Pos('CONTENT-TYPE', t) > 0 then
begin
b := True;
Break;
end;
if Pos('</HEAD>', t) > 0 then
Break;
end;
if not b then
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
end
else
s := CharsetConversion(s, FCharsetCode, FTargetCharset);
WriteStrToStream(FDecodedLines, s);
FDecodedLines.Seek(0, soFromBeginning);
end;
@ -620,39 +795,39 @@ begin
su := UpperCase(s);
if Pos('CONTENT-TYPE:', su) = 1 then
begin
st := SeparateRight(su, ':');
st2 := SeparateLeft(st, ';');
Primary := SeparateLeft(st2, '/');
FSecondary := SeparateRight(st2, '/');
st := Trim(SeparateRight(su, ':'));
st2 := Trim(SeparateLeft(st, ';'));
Primary := Trim(SeparateLeft(st2, '/'));
FSecondary := Trim(SeparateRight(st2, '/'));
if (FSecondary = Primary) and (Pos('/', st2) < 1) then
FSecondary := '';
case FPrimaryCode of
MP_TEXT:
begin
Charset := UpperCase(GetParameter(s, 'charset='));
FFileName := GetParameter(s, 'name=');
Charset := UpperCase(GetParameter(s, 'charset'));
FFileName := GetParameter(s, 'name');
end;
MP_MULTIPART:
FBoundary := GetParameter(s, 'Boundary=');
FBoundary := GetParameter(s, 'Boundary');
MP_MESSAGE:
begin
end;
MP_BINARY:
FFileName := GetParameter(s, 'name=');
FFileName := GetParameter(s, 'name');
end;
end;
if Pos('CONTENT-TRANSFER-ENCODING:', su) = 1 then
Encoding := SeparateRight(su, ':');
Encoding := Trim(SeparateRight(su, ':'));
if Pos('CONTENT-DESCRIPTION:', su) = 1 then
FDescription := SeparateRight(s, ':');
FDescription := Trim(SeparateRight(s, ':'));
if Pos('CONTENT-DISPOSITION:', su) = 1 then
begin
FDisposition := SeparateRight(su, ':');
FDisposition := Trim(SeparateLeft(FDisposition, ';'));
fn := GetParameter(s, 'FileName=');
fn := GetParameter(s, 'FileName');
end;
if Pos('CONTENT-ID:', su) = 1 then
FContentID := SeparateRight(s, ':');
FContentID := Trim(SeparateRight(s, ':'));
end;
if FFileName = '' then
FFileName := fn;
@ -668,6 +843,7 @@ var
s, t: string;
n, x: Integer;
d1, d2: integer;
NeedBOM: Boolean;
begin
if (FEncodingCode = ME_UU) or (FEncodingCode = ME_XX) then
Encoding := 'base64';
@ -675,6 +851,7 @@ begin
FPartBody.Clear;
FDecodedLines.Seek(0, soFromBeginning);
try
NeedBOM := True;
case FPrimaryCode of
MP_MULTIPART, MP_MESSAGE:
FPartBody.LoadFromStream(FDecodedLines);
@ -683,11 +860,19 @@ begin
begin
while FDecodedLines.Position < FDecodedLines.Size do
begin
Setlength(s, 54);
x := FDecodedLines.Read(pointer(s)^, 54);
Setlength(s, x);
s := ReadStrFromStream(FDecodedLines, 54);
// Setlength(s, 54);
// x := FDecodedLines.Read(pointer(s)^, 54);
// Setlength(s, x);
if FPrimaryCode = MP_TEXT then
begin
s := CharsetConversion(s, FTargetCharset, FCharsetCode);
if NeedBOM then
begin
s := GetBOM(FCharSetCode) + s;
NeedBOM := False;
end;
end;
s := EncodeBase64(s);
FPartBody.Add(s);
end;
@ -696,9 +881,10 @@ begin
begin
if FPrimaryCode = MP_BINARY then
begin
SetLength(s, FDecodedLines.Size);
x := FDecodedLines.Read(pointer(s)^, FDecodedLines.Size);
Setlength(s, x);
s := ReadStrFromStream(FDecodedLines, FDecodedLines.Size);
// SetLength(s, FDecodedLines.Size);
// x := FDecodedLines.Read(pointer(s)^, FDecodedLines.Size);
// Setlength(s, x);
l.Add(s);
end
else
@ -707,13 +893,17 @@ begin
begin
s := l[n];
if (FPrimaryCode = MP_TEXT) and (FEncodingCode <> ME_7BIT) then
begin
s := CharsetConversion(s, FTargetCharset, FCharsetCode);
if NeedBOM then
begin
s := GetBOM(FCharSetCode) + s;
NeedBOM := False;
end;
end;
if FEncodingCode = ME_QUOTED_PRINTABLE then
begin
if FPrimaryCode = MP_BINARY then
s := EncodeQuotedPrintable(s)
else
s := EncodeTriplet(s, '=', [Char(0)..Char(31), '=', Char(127)..Char(255)]);
s := EncodeQuotedPrintable(s);
repeat
if Length(s) < FMaxLineLength then
begin
@ -908,7 +1098,7 @@ end;
function TMIMEPart.IsUUcode(Value: string): boolean;
begin
Value := UpperCase(Value);
Result := (pos('BEGIN ', Value) = 1) and (SeparateRight(Value, ' ') <> '');
Result := (pos('BEGIN ', Value) = 1) and (Trim(SeparateRight(Value, ' ')) <> '');
end;
{==============================================================================}

101
nntpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 001.003.003 |
| Project : Ararat Synapse | 001.004.000 |
|==============================================================================|
| Content: NNTP client |
|==============================================================================|
@ -42,7 +42,11 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-977, RFC-2980
{:@abstract(NNTP client)
NNTP (network news transfer protocol)
Used RFC: RFC-977, RFC-2980
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -58,12 +62,20 @@ uses
{$IFDEF STREAMSEC}
TlsInternalServer, TlsSynaSock,
{$ENDIF}
blcksock, synautil, synacode;
blcksock, synautil;
const
cNNTPProtocol = 'nntp';
type
{:abstract(Implementation of Network News Transfer Protocol.
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TNNTPSend = class(TSynaClient)
private
{$IFDEF STREAMSEC}
@ -76,8 +88,6 @@ type
FResultString: string;
FData: TStringList;
FDataToSend: TStringList;
FUsername: string;
FPassword: string;
FAutoTLS: Boolean;
FFullSSL: Boolean;
FNNTPcap: TStringList;
@ -88,40 +98,105 @@ type
public
constructor Create;
destructor Destroy; override;
{:Connects to NNTP server and begin session.}
function Login: Boolean;
procedure Logout;
{:Logout from NNTP server and terminate session.}
function Logout: Boolean;
{:By this you can call any NNTP command.}
function DoCommand(const Command: string): boolean;
{:by this you can call any NNTP command. This variant is used for commands
for download information from server.}
function DoCommandRead(const Command: string): boolean;
{:by this you can call any NNTP command. This variant is used for commands
for upload information to server.}
function DoCommandWrite(const Command: string): boolean;
{:Download full message to @link(data) property. Value can be number of
message or message-id (in brackets).}
function GetArticle(const Value: string): Boolean;
{:Download only body of message to @link(data) property. Value can be number
of message or message-id (in brackets).}
function GetBody(const Value: string): Boolean;
{:Download only headers of message to @link(data) property. Value can be
number of message or message-id (in brackets).}
function GetHead(const Value: string): Boolean;
{:Get message status. Value can be number of message or message-id
(in brackets).}
function GetStat(const Value: string): Boolean;
{:Select given group.}
function SelectGroup(const Value: string): Boolean;
{:Tell to server 'I have mesage with given message-ID.' If server need this
message, message is uploaded to server.}
function IHave(const MessID: string): Boolean;
{:Move message pointer to last item in group.}
function GotoLast: Boolean;
{:Move message pointer to next item in group.}
function GotoNext: Boolean;
{:Download to @link(data) property list of all groups on NNTP server.}
function ListGroups: Boolean;
{:Download to @link(data) property list of all groups created after given time.}
function ListNewGroups(Since: TDateTime): Boolean;
{:Download to @link(data) property list of message-ids in given group since
given time.}
function NewArticles(const Group: string; Since: TDateTime): Boolean;
{:Upload new article to server. (for new messages by you)}
function PostArticle: Boolean;
{:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP
server'.}
function SwitchToSlave: Boolean;
{:Call NNTP XOVER command.}
function Xover(xoStart, xoEnd: string): boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:Try to find given capability in extension list. This list is getted after
successful login to NNTP server. If extension capability is not found,
then return is empty string.}
function FindCap(const Value: string): string;
{:Try get list of server extensions. List is returned in @link(data) property.}
function ListExtensions: Boolean;
published
property Username: string read FUsername write FUsername;
property Password: string read FPassword write FPassword;
{:Result code number of last operation.}
property ResultCode: Integer read FResultCode;
{:String description of last result code from NNTP server.}
property ResultString: string read FResultString;
{:Readed data. (message, etc.)}
property Data: TStringList read FData;
{:If is set to @true, then upgrade to SSL/TLS mode after login if remote
server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{$IFDEF STREAMSEC}
property Sock: TSsTCPBlockSocket read FSock;
property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
{$ELSE}
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{$ENDIF}
end;
@ -144,8 +219,6 @@ begin
FSock.ConvertLineEnd := True;
FTimeout := 60000;
FTargetPort := cNNTPProtocol;
FUsername := '';
FPassword := '';
FAutoTLS := False;
FFullSSL := False;
end;
@ -246,9 +319,9 @@ begin
Result := (ReadResult div 100) = 2;
ListExtensions;
FNNTPcap.Assign(Fdata);
if result then
if Result then
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
result := StartTLS;
Result := StartTLS;
if (FUsername <> '') and Result then
begin
FSock.SendString('AUTHINFO USER ' + FUsername + CRLF);
@ -260,10 +333,10 @@ begin
end;
end;
procedure TNNTPSend.Logout;
function TNNTPSend.Logout: Boolean;
begin
FSock.SendString('QUIT' + CRLF);
ReadResult;
Result := (ReadResult div 100) = 2;
FSock.CloseSocket;
end;

62
pingsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 003.001.005 |
| Project : Ararat Synapse | 003.001.006 |
|==============================================================================|
| Content: PING sender |
|==============================================================================|
@ -42,6 +42,16 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(ICMP PING implementation.)
Allows create PING and TRACEROUTE. Or you can diagnose your network.
Warning: this unit using RAW sockets. On some systems you must have special
rights for using this sort of sockets. So, it working allways when you have
administator/root rights. Otherwise you can have problems!
Note: IPv6 not working under .NET. It is lack of Microsoft's .NET framework.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
@ -74,6 +84,7 @@ const
ICMP6_TIME_EXCEEDED = 3;
type
{:Record for ICMP ECHO packet header.}
TIcmpEchoHeader = record
i_type: Byte;
i_code: Byte;
@ -83,6 +94,8 @@ type
TimeStamp: ULong;
end;
{:record used internally by TPingSend for compute checksum of ICMPv6 packet
pseudoheader.}
TICMP6Packet = record
in_source: TInAddr6;
in_dest: TInAddr6;
@ -93,6 +106,7 @@ type
proto: Byte;
end;
{:List of possible ICMP reply packet types.}
TICMPError = (
IE_NoError,
IE_Other,
@ -104,6 +118,10 @@ type
IE_UnreachPort
);
{:@abstract(Implementation of ICMP PING and ICMPv6 PING.)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TPINGSend = class(TSynaClient)
private
FSock: TICMPBlockSocket;
@ -125,21 +143,49 @@ type
function ReadPacket: Boolean;
procedure TranslateError;
public
{:Send ICMP ping to host and count @link(pingtime). If ping OK, result is
@true.}
function Ping(const Host: string): Boolean;
constructor Create;
destructor Destroy; override;
published
{:Size of PING packet. Default size is 32 bytes.}
property PacketSize: Integer read FPacketSize Write FPacketSize;
{:Time between request and reply.}
property PingTime: Integer read FPingTime;
{:From this address is sended reply for your PING request. It maybe not your
requested destination, when some error occured!}
property ReplyFrom: string read FReplyFrom;
{:ICMP type of PING reply. Each protocol using another values! For IPv4 and
IPv6 are used different values!}
property ReplyType: byte read FReplyType;
{:ICMP code of PING reply. Each protocol using another values! For IPv4 and
IPv6 are used different values! For protocol independent value look to
@link(ReplyError)}
property ReplyCode: byte read FReplyCode;
{:Return type of returned ICMP message. This value is independent on used
protocol!}
property ReplyError: TICMPError read FReplyError;
{:Return human readable description of returned packet type.}
property ReplyErrorDesc: string read FReplyErrorDesc;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TICMPBlockSocket read FSock;
end;
{:A very useful function and example of its use would be found in the TPINGSend
object. Use it to ping to any host. If successful, returns the ping time in
milliseconds. Returns -1 if an error occurred.}
function PingHost(const Host: string): Integer;
{:A very useful function and example of its use would be found in the TPINGSend
object. Use it to TraceRoute to any host.}
function TraceRouteHost(const Host: string): string;
implementation
@ -175,6 +221,7 @@ var
IcmpEchoHeaderPtr: ^TICMPEchoHeader;
t: Boolean;
x: cardinal;
IcmpReqHead: string;
begin
Result := False;
FPingTime := -1;
@ -218,6 +265,8 @@ begin
i_CheckSum := CheckSum(FBuffer);
end;
FSock.SendString(FBuffer);
// remember first 8 bytes of ICMP packet
IcmpReqHead := Copy(FBuffer, 1, 8);
x := GetTick;
repeat
t := ReadPacket;
@ -228,9 +277,10 @@ begin
{$IFDEF LINUX}
IcmpEchoHeaderPtr := Pointer(FBuffer);
{$ELSE}
FBuffer := StringOfChar(#0, 4) + FBuffer;
//WinXP SP1 with networking update doing this think by another way ;-O
// FBuffer := StringOfChar(#0, 4) + FBuffer;
IcmpEchoHeaderPtr := Pointer(FBuffer);
IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply;
// IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply;
{$ENDIF}
end
else
@ -239,9 +289,11 @@ begin
IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
end;
//it discard sometimes possible 'echoes' of previosly sended packet
//or other unwanted ICMP packets...
until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho)
and ((IcmpEchoHeaderPtr^.i_id = FId) or (IcmpEchoHeaderPtr^.i_id = 0));
//it discard sometimes possible 'echoes' of previosly sended packet...
and ((IcmpEchoHeaderPtr^.i_id = FId)
or (Pos(IcmpReqHead, FBuffer) > 0));
if t then
begin
FPingTime := TickDelta(x, GetTick);

102
pop3send.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 002.001.010 |
| Project : Ararat Synapse | 002.003.000 |
|==============================================================================|
| Content: POP3 client |
|==============================================================================|
@ -42,7 +42,10 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
{:@abstract(POP3 protocol client)
Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -64,8 +67,18 @@ const
cPop3Protocol = 'pop3';
type
{:The three types of possible authorization methods for "logging in" to a POP3
server.}
TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
{:@abstract(Implementation of POP3 client protocol.)
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TPOP3Send = class(TSynaClient)
private
{$IFDEF STREAMSEC}
@ -77,8 +90,6 @@ type
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
FUsername: string;
FPassword: string;
FStatCount: Integer;
FStatSize: Integer;
FTimeStamp: string;
@ -93,35 +104,93 @@ type
public
constructor Create;
destructor Destroy; override;
{:Call CAPA command for get POP3 server capabilites.
note: not all servers support this command!}
function Capability: Boolean;
{:Connect to remote POP3 host. If all OK, result is @true.}
function Login: Boolean;
procedure Logout;
{:Disconnects from POP3 server.}
function Logout: Boolean;
{:Send RSET command. If all OK, result is @true.}
function Reset: Boolean;
{:Send NOOP command. If all OK, result is @true.}
function NoOp: Boolean;
{:Send STAT command and fill @link(StatCount) and @link(StatSize) property.
If all OK, result is @true.}
function Stat: Boolean;
{:Send LIST command. If Value is 0, LIST is for all messages. After
successful operation is listing in FullResult. If all OK, result is @True.}
function List(Value: Integer): Boolean;
{:Send RETR command. After successful operation dowloaded message in
@link(FullResult). If all OK, result is @true.}
function Retr(Value: Integer): Boolean;
{:Send DELE command for delete specified message. If all OK, result is @true.}
function Dele(Value: Integer): Boolean;
{:Send TOP command. After successful operation dowloaded headers of message
and maxlines count of message in @link(FullResult). If all OK, result is
@true.}
function Top(Value, Maxlines: Integer): Boolean;
{:Send UIDL command. If Value is 0, UIDL is for all messages. After
successful operation is listing in FullResult. If all OK, result is @True.}
function Uidl(Value: Integer): Boolean;
{:Call STLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:Try to find given capabily in capabilty string returned from POP3 server
by CAPA command.}
function FindCap(const Value: string): string;
published
{:Result code of last POP3 operation. 0 - error, 1 - OK.}
property ResultCode: Integer read FResultCode;
{:Result string of last POP3 operation.}
property ResultString: string read FResultString;
{:Stringlist with full lines returned as result of POP3 operation. I.e. if
operation is LIST, this property is filled by list of messages. If
operation is RETR, this property have downloaded message.}
property FullResult: TStringList read FFullResult;
property Username: string read FUsername Write FUsername;
property Password: string read FPassword Write FPassword;
{:After STAT command is there count of messages in inbox.}
property StatCount: Integer read FStatCount;
{:After STAT command is there size of all messages in inbox.}
property StatSize: Integer read FStatSize;
{:If server support this, after comnnect is in this property timestamp of
remote server.}
property TimeStamp: string read FTimeStamp;
{:Type of authorisation for login to POP3 server. Dafault is autodetect one
of possible authorisation. Autodetect do this:
If remote POP3 server support APOP, try login by APOP method. If APOP is
not supported, or if APOP login failed, try classic USER+PASS login method.}
property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
{:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{$IFDEF STREAMSEC}
property Sock: TSsTCPBlockSocket read FSock;
property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
{$ELSE}
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{$ENDIF}
end;
@ -143,8 +212,6 @@ begin
FSock.ConvertLineEnd := true;
FTimeout := 60000;
FTargetPort := cPop3Protocol;
FUsername := '';
FPassword := '';
FStatCount := 0;
FStatSize := 0;
FAuthType := POP3AuthAll;
@ -254,7 +321,7 @@ begin
s := SeparateRight(FResultString, '<');
if s <> FResultString then
begin
s1 := SeparateLeft(s, '>');
s1 := Trim(SeparateLeft(s, '>'));
if s1 <> s then
FTimeStamp := '<' + s1 + '>';
end;
@ -262,7 +329,12 @@ begin
if Capability then
if FAutoTLS and (Findcap('STLS') <> '') then
if StartTLS then
Capability;
Capability
else
begin
Result := False;
Exit;
end;
if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
begin
Result := AuthApop;
@ -278,10 +350,10 @@ begin
Result := AuthLogin;
end;
procedure TPOP3Send.Logout;
function TPOP3Send.Logout: Boolean;
begin
FSock.SendString('QUIT' + CRLF);
ReadResult(False);
Result := ReadResult(False) = 1;
FSock.CloseSocket;
end;
@ -306,8 +378,8 @@ begin
if ReadResult(False) <> 1 then
Exit;
s := SeparateRight(ResultString, '+OK ');
FStatCount := StrToIntDef(SeparateLeft(s, ' '), 0);
FStatSize := StrToIntDef(SeparateRight(s, ' '), 0);
FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
Result := True;
end;

194
slogsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.006 |
| Project : Ararat Synapse | 001.002.000 |
|==============================================================================|
| Content: SysLog client |
|==============================================================================|
@ -37,12 +37,16 @@
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Christian Brosius |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
// RFC-3164
{:@abstract(BSD SYSLOG protocol)
Used RFC: RFC-3164
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -87,78 +91,214 @@ const
FCL_Local7 = 23;
type
{:@abstract(Define possible priority of Syslog message)}
TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
Debug);
{:@abstract(encoding or decoding of SYSLOG message)}
TSyslogMessage = class(TObject)
private
FFacility:Byte;
FSeverity:TSyslogSeverity;
FDateTime:TDateTime;
FTag:String;
FMessage:String;
FLocalIP:String;
function GetPacketBuf:String;
procedure SetPacketBuf(Value:String);
public
{:Reset values to defaults}
procedure Clear;
published
{:Define facilicity of Syslog message. For specify you may use predefined
FCL_* constants. Default is "FCL_Local0".}
property Facility:Byte read FFacility write FFacility;
{:Define possible priority of Syslog message. Default is "Debug".}
property Severity:TSyslogSeverity read FSeverity write FSeverity;
{:date and time of Syslog message}
property DateTime:TDateTime read FDateTime write FDateTime;
{:This is used for identify process of this message. Default is filename
of your executable file.}
property Tag:String read FTag write FTag;
{:Text of your message for log.}
property LogMessage:String read FMessage write FMessage;
{:IP address of message sender.}
property LocalIP:String read FLocalIP write FLocalIP;
{:This property holds encoded binary SYSLOG packet}
property PacketBuf:String read GetPacketBuf write SetPacketBuf;
end;
{:@abstract(This object implement BSD SysLog client)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSyslogSend = class(TSynaClient)
private
FSock: TUDPBlockSocket;
FFacility: Byte;
FSeverity: TSyslogSeverity;
FTag: string;
FMessage: string;
FSysLogMessage: TSysLogMessage;
public
constructor Create;
destructor Destroy; override;
{:Send Syslog UDP packet defined by @link(SysLogMessage).}
function DoIt: Boolean;
published
property Facility: Byte read FFacility Write FFacility;
property Severity: TSyslogSeverity read FSeverity Write FSeverity;
property Tag: string read FTag Write FTag;
property LogMessage: string read FMessage Write FMessage;
{:Syslog message for send}
property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage;
end;
{:Simply send packet to specified Syslog server.}
function ToSysLog(const SyslogServer: string; Facil: Byte;
Sever: TSyslogSeverity; const Content: string): Boolean;
implementation
constructor TSyslogSend.Create;
function TSyslogMessage.GetPacketBuf:String;
begin
Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>';
Result := Result + CDateTime(FDateTime) + ' ';
Result := Result + FLocalIP + ' ';
Result := Result + FTag + ': ' + FMessage;
end;
procedure TSyslogMessage.SetPacketBuf(Value:String);
var StrBuf:String;
IntBuf,Pos:Integer;
begin
if Length(Value) < 1 then exit;
Pos := 1;
if Value[Pos] <> '<' then exit;
Inc(Pos);
// Facility and Severity
StrBuf := '';
while (Value[Pos] <> '>')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
IntBuf := StrToInt(StrBuf);
FFacility := IntBuf div 8;
case (IntBuf mod 8)of
0:FSeverity := Emergency;
1:FSeverity := Alert;
2:FSeverity := Critical;
3:FSeverity := Error;
4:FSeverity := Warning;
5:FSeverity := Notice;
6:FSeverity := Info;
7:FSeverity := Debug;
end;
// DateTime
Inc(Pos);
StrBuf := '';
// Month
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
// Day
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
// Time
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FDateTime := DecodeRFCDateTime(StrBuf);
Inc(Pos);
// LocalIP
StrBuf := '';
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FLocalIP := StrBuf;
Inc(Pos);
// Tag
StrBuf := '';
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FTag := StrBuf;
// LogMessage
Inc(Pos);
StrBuf := '';
while (Pos <= Length(Value))do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FMessage := StrBuf;
end;
procedure TSysLogMessage.Clear;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FTargetPort := cSysLogProtocol;
FFacility := FCL_Local0;
FSeverity := Debug;
FTag := ExtractFileName(ParamStr(0));
FMessage := '';
FLocalIP := '0.0.0.0';
end;
//------------------------------------------------------------------------------
constructor TSyslogSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSysLogMessage := TSysLogMessage.Create;
FTargetPort := cSysLogProtocol;
end;
destructor TSyslogSend.Destroy;
begin
FSock.Free;
FSysLogMessage.Free;
inherited Destroy;
end;
function TSyslogSend.DoIt: Boolean;
var
Buf: string;
S: string;
L: TStringList;
begin
Result := False;
Buf := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>';
Buf := Buf + CDateTime(now) + ' ';
L := TStringList.Create;
try
FSock.ResolveNameToIP(FSock.Localname, L);
if L.Count < 1 then
S := '0.0.0.0'
FSysLogMessage.LocalIP := '0.0.0.0'
else
S := L[0];
FSysLogMessage.LocalIP := L[0];
finally
L.Free;
end;
Buf := Buf + S + ' ';
Buf := Buf + Tag + ': ' + FMessage;
if Length(Buf) <= 1024 then
FSysLogMessage.DateTime := Now;
if Length(FSysLogMessage.PacketBuf) <= 1024 then
begin
FSock.EnableReuse(True);
Fsock.Bind(FIPInterface, FTargetPort);
if FSock.LastError <> 0 then
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(Buf);
FSock.SendString(FSysLogMessage.PacketBuf);
Result := FSock.LastError = 0;
end;
end;
@ -171,9 +311,9 @@ begin
with TSyslogSend.Create do
try
TargetHost :=SyslogServer;
Facility := Facil;
Severity := Sever;
LogMessage := Content;
SysLogMessage.Facility := Facil;
SysLogMessage.Severity := Sever;
SysLogMessage.LogMessage := Content;
Result := DoIt;
finally
Free;

168
smtpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 003.002.011 |
| Project : Ararat Synapse | 003.003.001 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -42,8 +42,11 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487,
//RFC-2554, RFC-2821
{:@abstract(SMTP client)
Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487,
RFC-2554, RFC-2821
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -65,6 +68,14 @@ const
cSmtpProtocol = 'smtp';
type
{:@abstract(Implementation of SMTP and ESMTP procotol),
include some ESMTP extensions, include SSL/TLS too.
Note: Are you missing properties for setting Username and Password for ESMTP?
Look to parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSMTPSend = class(TSynaClient)
private
{$IFDEF STREAMSEC}
@ -78,8 +89,6 @@ type
FFullResult: TStringList;
FESMTPcap: TStringList;
FESMTP: Boolean;
FUsername: string;
FPassword: string;
FAuthDone: Boolean;
FESMTPSize: Boolean;
FMaxSize: Integer;
@ -99,47 +108,159 @@ type
public
constructor Create;
destructor Destroy; override;
{:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and
begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses
ESMTP capabilites and if you specified Username and password and remote
server can handle AUTH command, try login by AUTH command. Preffered login
method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is
@false.}
function Login: Boolean;
procedure Logout;
{:Close SMTP session (QUIT command) and disconnect from SMTP server.}
function Logout: Boolean;
{:Send RSET SMTP command for reset SMTP session. If all OK, result is @true,
else result is @false.}
function Reset: Boolean;
{:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true,
else result is @false.}
function NoOp: Boolean;
{:Send MAIL FROM SMTP command for set sender e-mail address. If sender's
e-mail address is empty string, transmited message is error message.
If size not 0 and remote server can handle SIZE parameter, append SIZE
parameter to request. If all OK, result is @true, else result is @false.}
function MailFrom(const Value: string; Size: Integer): Boolean;
{:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an
empty string. If all OK, result is @true, else result is @false.}
function MailTo(const Value: string): Boolean;
{:Send DATA SMTP command and transmit message data. If all OK, result is
@true, else result is @false.}
function MailData(const Value: Tstrings): Boolean;
{:Send ETRN SMTP command for start sending of remote queue for domain in
Value. If all OK, result is @true, else result is @false.}
function Etrn(const Value: string): Boolean;
{:Send VRFY SMTP command for check receiver e-mail address. It cannot be
an empty string. If all OK, result is @true, else result is @false.}
function Verify(const Value: string): Boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:Return string descriptive text for enhanced result codes stored in
@link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).}
function EnhCodeString: string;
{:Try to find specified capability in ESMTP response.}
function FindCap(const Value: string): string;
published
{:result code of last SMTP command.}
property ResultCode: Integer read FResultCode;
{:result string of last SMTP command (begin with string representation of
result code).}
property ResultString: string read FResultString;
{:All result strings of last SMTP command (result is maybe multiline!).}
property FullResult: TStringList read FFullResult;
{:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP
server only!).}
property ESMTPcap: TStringList read FESMTPcap;
{:@TRUE if you successfuly logged to ESMTP server.}
property ESMTP: Boolean read FESMTP;
property Username: string read FUsername Write FUsername;
property Password: string read FPassword Write FPassword;
{:@TRUE if you successfuly pass authorisation to remote server.}
property AuthDone: Boolean read FAuthDone;
{:@TRUE if remote server can handle SIZE parameter.}
property ESMTPSize: Boolean read FESMTPSize;
{:When @link(ESMTPsize) is @TRUE, contains max length of message that remote
server can handle.}
property MaxSize: Integer read FMaxSize;
{:First digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode1: Integer read FEnhCode1;
{:Second digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode2: Integer read FEnhCode2;
{:Third digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode3: Integer read FEnhCode3;
{:name of our system used in HELO and EHLO command. Implicit value is
internet address of your machine.}
property SystemName: string read FSystemName Write FSystemName;
{:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{$IFDEF STREAMSEC}
property Sock: TSsTCPBlockSocket read FSock;
property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
{$ELSE}
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{$ENDIF}
end;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Send maildata (text of e-mail with all SMTP headers! For example when
text of message is created by @link(TMimemess) object) from "MailFrom" e-mail
address to "MailTo" e-mail address (If you need more then one receiver, then
separate their addresses by comma).
Function sends e-mail to a SMTP server defined in "SMTPhost" parameter.
Username and password are used for authorization to the "SMTPhost". If you
don't want authorization, set "Username" and "Password" to empty strings. If
e-mail message is successfully sent, the result returns @true.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Send "Maildata" (text of e-mail without any SMTP headers!) from
"MailFrom" e-mail address to "MailTo" e-mail address with "Subject". (If you
need more then one receiver, then separate their addresses by comma).
This function constructs all needed SMTP headers (with DATE header) and sends
the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the
e-mail message is successfully sent, the result will be @TRUE.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings): Boolean;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Sends "MailData" (text of e-mail without any SMTP headers!) from
"MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one
receiver, then separate their addresses by comma).
This function sends the e-mail to the SMTP server defined in the "SMTPhost"
parameter. Username and password are used for authorization to the "SMTPhost".
If you dont want authorization, set "Username" and "Password" to empty Strings.
If the e-mail message is successfully sent, the result will be @TRUE.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
@ -160,8 +281,6 @@ begin
FSock.ConvertLineEnd := true;
FTimeout := 60000;
FTargetPort := cSmtpProtocol;
FUsername := '';
FPassword := '';
FSystemName := FSock.LocalName;
FAutoTLS := False;
FFullSSL := False;
@ -184,8 +303,8 @@ begin
FEnhCode2 := 0;
FEnhCode3 := 0;
s := Copy(Value, 5, Length(Value) - 4);
t := SeparateLeft(s, '.');
s := SeparateRight(s, '.');
t := Trim(SeparateLeft(s, '.'));
s := Trim(SeparateRight(s, '.'));
if t = '' then
Exit;
if Length(t) > 1 then
@ -193,14 +312,14 @@ begin
e1 := StrToIntDef(t, 0);
if e1 = 0 then
Exit;
t := SeparateLeft(s, '.');
s := SeparateRight(s, '.');
t := Trim(SeparateLeft(s, '.'));
s := Trim(SeparateRight(s, '.'));
if t = '' then
Exit;
if Length(t) > 3 then
Exit;
e2 := StrToIntDef(t, 0);
t := SeparateLeft(s, ' ');
t := Trim(SeparateLeft(s, ' '));
if t = '' then
Exit;
if Length(t) > 3 then
@ -338,6 +457,11 @@ begin
FESMTPcap.Clear;
for n := 1 to FFullResult.Count - 1 do
FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
end
else
begin
Result := False;
Exit;
end;
if not ((FUsername = '') and (FPassword = '')) then
begin
@ -362,10 +486,10 @@ begin
end;
end;
procedure TSMTPSend.Logout;
function TSMTPSend.Logout: Boolean;
begin
FSock.SendString('QUIT' + CRLF);
ReadResult;
Result := ReadResult = 221;
FSock.CloseSocket;
end;
@ -557,8 +681,8 @@ begin
// SMTP.AutoTLS := True;
// if you need support for TSL/SSL tunnel, uncomment next lines:
// SMTP.FullSSL := True;
SMTP.TargetHost := SeparateLeft(SMTPHost, ':');
s := SeparateRight(SMTPHost, ':');
SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':'));
s := Trim(SeparateRight(SMTPHost, ':'));
if (s <> '') and (s <> SMTPHost) then
SMTP.TargetPort := s;
SMTP.Username := Username;
@ -569,7 +693,7 @@ begin
begin
s := MailTo;
repeat
t := GetEmailAddr(FetchEx(s, ',', '"'));
t := GetEmailAddr(Trim(FetchEx(s, ',', '"')));
if t <> '' then
Result := SMTP.MailTo(t);
if not Result then

780
snmpsend.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 002.006.004 |
| Project : Ararat Synapse | 003.000.007 |
|==============================================================================|
| Content: SNMP client |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2003. |
| Portions created by Lukas Gebauer are Copyright (c)2000-2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
@ -43,6 +43,13 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SNMP client)
Supports SNMPv1 include traps, SNMPv2c and SNMPv3 include authorization
(encryption not yet supported!)
Used RFC: RFC-1157, RFC-1901, RFC-3412, RFC-3414, RFC-3416
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
@ -55,17 +62,27 @@ interface
uses
Classes, SysUtils,
blcksock, synautil, asn1util;
blcksock, synautil, asn1util, synacode;
const
cSnmpProtocol = '161';
cSnmpTrapProtocol = '162';
SNMP_V1 = 0;
SNMP_V2C = 1;
SNMP_V3 = 3;
//PDU type
PDUGetRequest = $A0;
PDUGetNextRequest = $A1;
PDUGetResponse = $A2;
PDUSetRequest = $A3;
PDUTrap = $A4;
PDUTrap = $A4; //Obsolete
//for SNMPv2
PDUGetBulkRequest = $A5;
PDUInformRequest = $A6;
PDUTrapV2 = $A7;
PDUReport = $A8;
//errors
ENoError = 0;
@ -74,72 +91,317 @@ const
EBadValue = 3;
EReadOnly = 4;
EGenErr = 5;
//errors SNMPv2
ENoAccess = 6;
EWrongType = 7;
EWrongLength = 8;
EWrongEncoding = 9;
EWrongValue = 10;
ENoCreation = 11;
EInconsistentValue = 12;
EResourceUnavailable = 13;
ECommitFailed = 14;
EUndoFailed = 15;
EAuthorizationError = 16;
ENotWritable = 17;
EInconsistentName = 18;
type
{:@abstract(Possible values for SNMPv3 flags.)
This flags specify level of authorization and encryption.}
TV3Flags = (
NoAuthNoPriv,
AuthNoPriv,
AuthPriv);
{:@abstract(Type of SNMPv3 authorization)}
TV3Auth = (
AuthMD5,
AuthSHA1);
{:@abstract(Data object with one record of MIB OID and corresponding values.)}
TSNMPMib = class(TObject)
private
FOID: string;
FValue: string;
protected
FOID: AnsiString;
FValue: AnsiString;
FValueType: Integer;
published
property OID: string read FOID write FOID;
property Value: string read FValue write FValue;
{:OID number in string format.}
property OID: AnsiString read FOID write FOID;
{:Value of OID object in string format.}
property Value: AnsiString read FValue write FValue;
{:Define type of Value. Supported values are defined in @link(asn1util).
For queries use ASN1_NULL, becouse you don't know type in response!}
property ValueType: Integer read FValueType write FValueType;
end;
{:@abstract(It holding all information for SNMPv3 agent synchronization)
Used internally.}
TV3Sync = record
EngineID: AnsiString;
EngineBoots: integer;
EngineTime: integer;
EngineStamp: Cardinal;
end;
{:@abstract(Data object abstracts SNMP data packet)}
TSNMPRec = class(TObject)
private
protected
FVersion: Integer;
FCommunity: string;
FPDUType: Integer;
FID: Integer;
FErrorStatus: Integer;
FErrorIndex: Integer;
FCommunity: AnsiString;
FSNMPMibList: TList;
FMaxSize: Integer;
FFlags: TV3Flags;
FFlagReportable: Boolean;
FContextEngineID: AnsiString;
FContextName: AnsiString;
FAuthMode: TV3Auth;
FAuthEngineID: AnsiString;
FAuthEngineBoots: integer;
FAuthEngineTime: integer;
FAuthEngineTimeStamp: cardinal;
FUserName: AnsiString;
FPassword: AnsiString;
FAuthKey: AnsiString;
FPrivKey: AnsiString;
FOldTrapEnterprise: AnsiString;
FOldTrapHost: AnsiString;
FOldTrapGen: Integer;
FOldTrapSpec: Integer;
FOldTrapTimeTicks: Integer;
function Pass2Key(const Value: AnsiString): AnsiString;
public
constructor Create;
destructor Destroy; override;
function DecodeBuf(const Buffer: string): Boolean;
function EncodeBuf: string;
{:Decode SNMP packet in buffer to object properties.}
function DecodeBuf(const Buffer: AnsiString): Boolean;
{:Encode obeject properties to SNMP packet.}
function EncodeBuf: AnsiString;
{:Clears all object properties to default values.}
procedure Clear;
procedure MIBAdd(const MIB, Value: string; ValueType: Integer);
{:Add entry to @link(SNMPMibList). For queries use value as empty string,
and ValueType as ASN1_NULL.}
procedure MIBAdd(const MIB, Value: AnsiString; ValueType: Integer);
{:Delete entry from @link(SNMPMibList).}
procedure MIBDelete(Index: Integer);
function MIBGet(const MIB: string): string;
{:Search @link(SNMPMibList) list for MIB and return correspond value.}
function MIBGet(const MIB: AnsiString): AnsiString;
{:return number of entries in MIB array.}
function MIBCount: integer;
{:Return MIB information from given row of MIB array.}
function MIBByIndex(Index: Integer): TSNMPMib;
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;
{:List of @link(TSNMPMib) objects.}
property SNMPMibList: TList read FSNMPMibList;
published
{:Version of SNMP packet. Default value is 0 (SNMP ver. 1). You can use
value 1 for SNMPv2c or value 3 for SNMPv3.}
property Version: Integer read FVersion write FVersion;
{:Community string for autorize access to SNMP server. (Case sensitive!)
Community string is not used in SNMPv3! Use @link(Username) and
@link(password) instead!}
property Community: AnsiString read FCommunity write FCommunity;
{:Define type of SNMP operation.}
property PDUType: Integer read FPDUType write FPDUType;
{:Contains ID number. Not need to use.}
property ID: Integer read FID write FID;
{:When packet is reply, contains error code. Supported values are defined by
E* constants.}
property ErrorStatus: Integer read FErrorStatus write FErrorStatus;
{:Point to error position in reply packet. Not usefull for users. It only
good for debugging!}
property ErrorIndex: Integer read FErrorIndex write FErrorIndex;
{:special value for GetBulkRequest of SNMPv2 and v3.}
property NonRepeaters: Integer read FErrorStatus write FErrorStatus;
{:special value for GetBulkRequest of SNMPv2 and v3.}
property MaxRepetitions: Integer read FErrorIndex write FErrorIndex;
{:Maximum message size in bytes for SNMPv3. For sending is default 1472 bytes.}
property MaxSize: Integer read FMaxSize write FMaxSize;
{:Specify if message is authorised or encrypted. Used only in SNMPv3, and
encryption is not yet supported!}
property Flags: TV3Flags read FFlags write FFlags;
{:For SNMPv3.... If is @true, SNMP agent must send reply (at least with some
error).}
property FlagReportable: Boolean read FFlagReportable write FFlagReportable;
{:For SNMPv3. If not specified, is used value from @link(AuthEngineID)}
property ContextEngineID: AnsiString read FContextEngineID write FContextEngineID;
{:For SNMPv3.}
property ContextName: AnsiString read FContextName write FContextName;
{:For SNMPv3. Specify Authorization mode. (specify used hash for
authorization)}
property AuthMode: TV3Auth read FAuthMode write FAuthMode;
{:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
property AuthEngineID: AnsiString read FAuthEngineID write FAuthEngineID;
{:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
property AuthEngineBoots: Integer read FAuthEngineBoots write FAuthEngineBoots;
{:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
property AuthEngineTime: Integer read FAuthEngineTime write FAuthEngineTime;
{:value used by SNMPv3 authorisation for synchronization with SNMP agent.}
property AuthEngineTimeStamp: Cardinal read FAuthEngineTimeStamp Write FAuthEngineTimeStamp;
{:SNMPv3 authorization username}
property UserName: AnsiString read FUserName write FUserName;
{:SNMPv3 authorization password}
property Password: AnsiString read FPassword write FPassword;
{:For SNMPv3. Computed Athorization key from @link(password).}
property AuthKey: AnsiString read FAuthKey write FAuthKey;
{:For SNMPv3. Encryption key for message encryption. Not yet used!}
property PrivKey: AnsiString read FPrivKey write FPrivKey;
{:MIB value to identify the object that sent the TRAPv1.}
property OldTrapEnterprise: AnsiString read FOldTrapEnterprise write FOldTrapEnterprise;
{:Address of TRAPv1 sender (IP address).}
property OldTrapHost: AnsiString read FOldTrapHost write FOldTrapHost;
{:Generic TRAPv1 identification.}
property OldTrapGen: Integer read FOldTrapGen write FOldTrapGen;
{:Specific TRAPv1 identification.}
property OldTrapSpec: Integer read FOldTrapSpec write FOldTrapSpec;
{:Number of 1/100th of seconds since last reboot or power up. (for TRAPv1)}
property OldTrapTimeTicks: Integer read FOldTrapTimeTicks write FOldTrapTimeTicks;
end;
{:@abstract(Implementation of SNMP protocol.)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSNMPSend = class(TSynaClient)
private
protected
FSock: TUDPBlockSocket;
FBuffer: string;
FHostIP: string;
FBuffer: AnsiString;
FHostIP: AnsiString;
FQuery: TSNMPRec;
FReply: TSNMPRec;
function InternalSendSnmp(const Value: TSNMPRec): Boolean;
function InternalRecvSnmp(const Value: TSNMPRec): Boolean;
function InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean;
function GetV3EngineID: AnsiString;
function GetV3Sync: TV3Sync;
public
constructor Create;
destructor Destroy; override;
{:Connects to a Host and send there query. If in timeout SNMP server send
back query, result is @true. If is used SNMPv3, then it synchronize self
with SNMPv3 agent first. (It is needed for SNMPv3 auhorization!)}
function SendRequest: Boolean;
{:Send SNMP packet only, but not waits for reply. Good for sending traps.}
function SendTrap: Boolean;
{:Receive SNMP packet only. Good for receiving traps.}
function RecvTrap: Boolean;
{:Mapped to @link(SendRequest) internally. This function is only for
backward compatibility.}
function DoIt: Boolean;
published
property HostIP: string read FHostIP;
{:contains raw binary form of SNMP packet. Good for debugging.}
property Buffer: AnsiString read FBuffer write FBuffer;
{:After SNMP operation hold IP address of remote side.}
property HostIP: AnsiString read FHostIP;
{:Data object contains SNMP query.}
property Query: TSNMPRec read FQuery;
{:Data object contains SNMP reply.}
property Reply: TSNMPRec read FReply;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TUDPBlockSocket read FSock;
end;
function SNMPGet(const OID, Community, SNMPHost: string; var Value: string): Boolean;
function SNMPSet(const OID, Community, SNMPHost, Value: string; ValueType: Integer): Boolean;
function SNMPGetNext(var OID: string; const Community, SNMPHost: string; var Value: string): Boolean;
function SNMPGetTable(const BaseOID, Community, SNMPHost: string; const Value: TStrings): Boolean;
function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It implements basic GET method of the SNMP protocol. The MIB value is
located in the "OID" variable, and is sent to the requested "SNMPHost" with
the proper "Community" access identifier. Upon a successful retrieval, "Value"
will contain the information requested. If the SNMP operation is successful,
the result returns @true.}
function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
{:This is useful function and example of use TSNMPSend object. It implements
the basic SET method of the SNMP protocol. If the SNMP operation is successful,
the result is @true. "Value" is value of MIB Oid for "SNMPHost" with "Community"
access identifier. You must specify "ValueType" too.}
function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It implements basic GETNEXT method of the SNMP protocol. The MIB value
is located in the "OID" variable, and is sent to the requested "SNMPHost" with
the proper "Community" access identifier. Upon a successful retrieval, "Value"
will contain the information requested. If the SNMP operation is successful,
the result returns @true.}
function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It implements basic read of SNMP MIB tables. As BaseOID you must
specify basic MIB OID of requested table (base IOD is OID without row and
column specificator!)
Table is readed into stringlist, where each string is comma delimited string.
Warning: this function is not have best performance. For better performance
you must write your own function. best performace you can get by knowledge
of structuture of table and by more then one MIB on one query. }
function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It implements basic read of SNMP MIB table element. As BaseOID you must
specify basic MIB OID of requested table (base IOD is OID without row and
column specificator!)
As next you must specify identificator of row and column for specify of needed
field of table.}
function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It implements a TRAPv1 to send with all data in the parameters.}
function SendTrap(const Dest, Source, Enterprise, Community: AnsiString;
Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString;
MIBtype: Integer): Integer;
{:A very useful function and example of its use would be found in the TSNMPSend
object. It receives a TRAPv1 and returns all the data that comes with it.}
function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString;
var Generic, Specific, Seconds: Integer; const MIBName,
MIBValue: TStringList): Integer;
implementation
@ -149,7 +411,9 @@ constructor TSNMPRec.Create;
begin
inherited Create;
FSNMPMibList := TList.Create;
Clear;
FID := 1;
FMaxSize := 1472;
end;
destructor TSNMPRec.Destroy;
@ -163,13 +427,38 @@ begin
inherited Destroy;
end;
function TSNMPRec.DecodeBuf(const Buffer: string): Boolean;
function TSNMPRec.Pass2Key(const Value: AnsiString): AnsiString;
var
key: AnsiString;
begin
case FAuthMode of
AuthMD5:
begin
key := MD5LongHash(Value, 1048576);
Result := MD5(key + FAuthEngineID + key);
end;
AuthSHA1:
begin
key := SHA1LongHash(Value, 1048576);
Result := SHA1(key + FAuthEngineID + key);
end;
else
Result := '';
end;
end;
function TSNMPRec.DecodeBuf(const Buffer: AnsiString): Boolean;
var
Pos: Integer;
EndPos: Integer;
sm, sv: string;
sm, sv: AnsiString;
Svt: Integer;
s: AnsiString;
Spos: integer;
x: Byte;
begin
Clear;
Result := False;
if Length(Buffer) < 2 then
Exit;
@ -180,11 +469,73 @@ begin
if Length(Buffer) < (EndPos + 2) then
Exit;
Self.FVersion := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FCommunity := ASNItem(Pos, Buffer, Svt);
Self.FPDUType := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
if FVersion = 3 then
begin
ASNItem(Pos, Buffer, Svt); //header data seq
ASNItem(Pos, Buffer, Svt); //ID
FMaxSize := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
s := ASNItem(Pos, Buffer, Svt);
x := 0;
if s <> '' then
x := Ord(s[1]);
FFlagReportable := (x and 4) > 0;
x := x and 3;
case x of
1:
FFlags := AuthNoPriv;
3:
FFlags := AuthPriv;
else
FFlags := NoAuthNoPriv;
end;
x := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
s := ASNItem(Pos, Buffer, Svt); //SecurityParameters
//if SecurityModel is USM, then try to decode SecurityParameters
if (x = 3) and (s <> '') then
begin
spos := 1;
ASNItem(SPos, s, Svt);
FAuthEngineID := ASNItem(SPos, s, Svt);
FAuthEngineBoots := StrToIntDef(ASNItem(SPos, s, Svt), 0);
FAuthEngineTime := StrToIntDef(ASNItem(SPos, s, Svt), 0);
FAuthEngineTimeStamp := GetTick;
FUserName := ASNItem(SPos, s, Svt);
FAuthKey := ASNItem(SPos, s, Svt);
FPrivKey := ASNItem(SPos, s, Svt);
end;
//scopedPDU
s := ASNItem(Pos, Buffer, Svt);
if Svt = ASN1_OCTSTR then
begin
//decrypt!
end;
FContextEngineID := ASNItem(Pos, Buffer, Svt);
FContextName := ASNItem(Pos, Buffer, Svt);
end
else
begin
//old packet
Self.FCommunity := ASNItem(Pos, Buffer, Svt);
end;
ASNItem(Pos, Buffer, Svt);
Self.FPDUType := Svt;
if Self.FPDUType = PDUTrap then
begin
FOldTrapEnterprise := ASNItem(Pos, Buffer, Svt);
FOldTrapHost := ASNItem(Pos, Buffer, Svt);
FOldTrapGen := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
FOldTrapSpec := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
FOldTrapTimeTicks := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
end
else
begin
Self.FID := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FErrorStatus := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
Self.FErrorIndex := StrToIntDef(ASNItem(Pos, Buffer, Svt), 0);
end;
ASNItem(Pos, Buffer, Svt);
while Pos < EndPos do
begin
@ -196,16 +547,18 @@ begin
Result := True;
end;
function TSNMPRec.EncodeBuf: string;
function TSNMPRec.EncodeBuf: AnsiString;
var
data, s: string;
s: AnsiString;
SNMPMib: TSNMPMib;
n: Integer;
pdu, head, auth, authbeg: AnsiString;
x: Byte;
begin
data := '';
pdu := '';
for n := 0 to FSNMPMibList.Count - 1 do
begin
SNMPMib := FSNMPMibList[n];
SNMPMib := TSNMPMib(FSNMPMibList[n]);
case SNMPMib.ValueType of
ASN1_INT:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
@ -226,35 +579,141 @@ begin
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(SNMPMib.Value, SNMPMib.ValueType);
end;
data := data + ASNObject(s, ASN1_SEQ);
pdu := pdu + ASNObject(s, ASN1_SEQ);
end;
pdu := ASNObject(pdu, ASN1_SEQ);
if Self.FPDUType = PDUTrap then
pdu := ASNObject(MibToID(FOldTrapEnterprise), ASN1_OBJID) +
ASNObject(IPToID(FOldTrapHost), ASN1_IPADDR) +
ASNObject(ASNEncInt(FOldTrapGen), ASN1_INT) +
ASNObject(ASNEncInt(FOldTrapSpec), ASN1_INT) +
ASNObject(ASNEncUInt(FOldTrapTimeTicks), ASN1_TIMETICKS) +
pdu
else
pdu := ASNObject(ASNEncInt(Self.FID), ASN1_INT) +
ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) +
ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) +
pdu;
pdu := ASNObject(pdu, Self.FPDUType);
if FVersion = 3 then
begin
if FContextEngineID = '' then
FContextEngineID := FAuthEngineID;
//complete PDUv3...
pdu := ASNObject(FContextEngineID, ASN1_OCTSTR)
+ ASNObject(FContextName, ASN1_OCTSTR)
+ pdu;
//maybe encrypt pdu... in future
pdu := ASNObject(pdu, ASN1_SEQ);
//prepare flags
case FFlags of
AuthNoPriv:
x := 1;
AuthPriv:
x := 3;
else
x := 0;
end;
if FFlagReportable then
x := x or 4;
head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT);
s := ASNObject(ASNEncInt(FID), ASN1_INT)
+ ASNObject(ASNEncInt(FMaxSize), ASN1_INT)
+ ASNObject(AnsiChar(x), ASN1_OCTSTR)
//encode security model USM
+ ASNObject(ASNEncInt(3), ASN1_INT);
head := head + ASNObject(s, ASN1_SEQ);
//compute engine time difference
x := TickDelta(FAuthEngineTimeStamp, GetTick) div 1000;
authbeg := ASNObject(FAuthEngineID, ASN1_OCTSTR)
+ ASNObject(ASNEncInt(FAuthEngineBoots), ASN1_INT)
+ ASNObject(ASNEncInt(FAuthEngineTime + x), ASN1_INT)
+ ASNObject(FUserName, ASN1_OCTSTR);
case FFlags of
AuthNoPriv,
AuthPriv:
begin
s := authbeg + ASNObject(StringOfChar(#0, 12), ASN1_OCTSTR)
+ ASNObject(FPrivKey, ASN1_OCTSTR);
s := ASNObject(s, ASN1_SEQ);
s := head + ASNObject(s, ASN1_OCTSTR);
s := ASNObject(s + pdu, ASN1_SEQ);
//in s is entire packet without auth info...
case FAuthMode of
AuthMD5:
begin
s := HMAC_MD5(s, Pass2Key(FPassword) + StringOfChar(#0, 48));
//strip to HMAC-MD5-96
delete(s, 13, 4);
end;
AuthSHA1:
begin
s := HMAC_SHA1(s, Pass2Key(FPassword) + StringOfChar(#0, 44));
//strip to HMAC-SHA-96
delete(s, 13, 8);
end;
else
s := '';
end;
FAuthKey := s;
end;
end;
auth := authbeg + ASNObject(FAuthKey, ASN1_OCTSTR)
+ ASNObject(FPrivKey, ASN1_OCTSTR);
auth := ASNObject(auth, ASN1_SEQ);
head := head + ASNObject(auth, ASN1_OCTSTR);
Result := ASNObject(head + pdu, ASN1_SEQ);
end
else
begin
head := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) +
ASNObject(Self.FCommunity, ASN1_OCTSTR);
Result := ASNObject(head + pdu, ASN1_SEQ);
end;
data := ASNObject(data, ASN1_SEQ);
data := ASNObject(ASNEncInt(Self.FID), ASN1_INT) +
ASNObject(ASNEncInt(Self.FErrorStatus), ASN1_INT) +
ASNObject(ASNEncInt(Self.FErrorIndex), ASN1_INT) +
data;
data := ASNObject(ASNEncInt(Self.FVersion), ASN1_INT) +
ASNObject(Self.FCommunity, ASN1_OCTSTR) +
ASNObject(data, Self.FPDUType);
data := ASNObject(data, ASN1_SEQ);
Result := data;
end;
procedure TSNMPRec.Clear;
var
i: Integer;
begin
FVersion := 0;
FCommunity := '';
FVersion := SNMP_V1;
FCommunity := 'public';
FUserName := '';
FPassword := '';
FPDUType := 0;
FErrorStatus := 0;
FErrorIndex := 0;
for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Clear;
FOldTrapEnterprise := '';
FOldTrapHost := '';
FOldTrapGen := 0;
FOldTrapSpec := 0;
FOldTrapTimeTicks := 0;
FFlags := NoAuthNoPriv;
FFlagReportable := false;
FContextEngineID := '';
FContextName := '';
FAuthMode := AuthMD5;
FAuthEngineID := '';
FAuthEngineBoots := 0;
FAuthEngineTime := 0;
FAuthEngineTimeStamp := 0;
FAuthKey := '';
FPrivKey := '';
end;
procedure TSNMPRec.MIBAdd(const MIB, Value: string; ValueType: Integer);
procedure TSNMPRec.MIBAdd(const MIB, Value: AnsiString; ValueType: Integer);
var
SNMPMib: TSNMPMib;
begin
@ -286,7 +745,7 @@ begin
Result := TSNMPMib(FSNMPMibList[Index]);
end;
function TSNMPRec.MIBGet(const MIB: string): string;
function TSNMPRec.MIBGet(const MIB: AnsiString): AnsiString;
var
i: Integer;
begin
@ -324,27 +783,125 @@ begin
inherited Destroy;
end;
function TSNMPSend.DoIt: Boolean;
function TSNMPSend.InternalSendSnmp(const Value: TSNMPRec): Boolean;
begin
FReply.Clear;
FBuffer := FQuery.EncodeBuf;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FHostIP := cAnyHost;
FBuffer := Value.EncodeBuf;
FSock.SendString(FBuffer);
Result := FSock.LastError = 0;
end;
function TSNMPSend.InternalRecvSnmp(const Value: TSNMPRec): Boolean;
begin
Result := False;
FReply.Clear;
FHostIP := cAnyHost;
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
FHostIP := FSock.GetRemoteSinIP;
Result := FReply.DecodeBuf(FBuffer);
end
else
Result := False;
Result := Value.DecodeBuf(FBuffer);
end;
end;
function TSNMPSend.InternalSendRequest(const QValue, RValue: TSNMPRec): Boolean;
begin
Result := False;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
if InternalSendSnmp(QValue) then
Result := InternalRecvSnmp(RValue);
end;
function TSNMPSend.SendRequest: Boolean;
var
sync: TV3Sync;
begin
Result := False;
if FQuery.FVersion = 3 then
begin
sync := GetV3Sync;
FQuery.AuthEngineBoots := Sync.EngineBoots;
FQuery.AuthEngineTime := Sync.EngineTime;
FQuery.AuthEngineTimeStamp := Sync.EngineStamp;
FQuery.AuthEngineID := Sync.EngineID;
end;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
if InternalSendSnmp(FQuery) then
Result := InternalRecvSnmp(FReply);
end;
function TSNMPSend.SendTrap: Boolean;
begin
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := InternalSendSnmp(FQuery);
end;
function TSNMPSend.RecvTrap: Boolean;
begin
FSock.Bind(FIPInterface, FTargetPort);
Result := InternalRecvSnmp(FReply);
end;
function TSNMPSend.DoIt: Boolean;
begin
Result := SendRequest;
end;
function TSNMPSend.GetV3EngineID: AnsiString;
var
DisQuery: TSNMPRec;
begin
Result := '';
DisQuery := TSNMPRec.Create;
try
DisQuery.Version := 3;
DisQuery.UserName := '';
DisQuery.FlagReportable := True;
DisQuery.PDUType := PDUGetRequest;
if InternalSendRequest(DisQuery, FReply) then
Result := FReply.FAuthEngineID;
finally
DisQuery.Free;
end;
end;
function TSNMPSend.GetV3Sync: TV3Sync;
var
SyncQuery: TSNMPRec;
begin
Result.EngineID := GetV3EngineID;
Result.EngineBoots := FReply.AuthEngineBoots;
Result.EngineTime := FReply.AuthEngineTime;
Result.EngineStamp := FReply.AuthEngineTimeStamp;
if Result.EngineTime = 0 then
begin
//still not have sync...
SyncQuery := TSNMPRec.Create;
try
SyncQuery.Version := 3;
SyncQuery.UserName := FQuery.UserName;
SyncQuery.Password := FQuery.Password;
SyncQuery.FlagReportable := True;
SyncQuery.Flags := FQuery.Flags;
SyncQuery.PDUType := PDUGetRequest;
SyncQuery.AuthEngineID := FReply.FAuthEngineID;
if InternalSendRequest(SyncQuery, FReply) then
begin
Result.EngineBoots := FReply.AuthEngineBoots;
Result.EngineTime := FReply.AuthEngineTime;
Result.EngineStamp := FReply.AuthEngineTimeStamp;
end;
finally
SyncQuery.Free;
end;
end;
end;
{==============================================================================}
function SNMPGet(const OID, Community, SNMPHost: string; var Value: string): Boolean;
function SNMPGet(const OID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
var
SNMPSend: TSNMPSend;
begin
@ -355,7 +912,7 @@ begin
SNMPSend.Query.PDUType := PDUGetRequest;
SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
SNMPSend.TargetHost := SNMPHost;
Result := SNMPSend.DoIt;
Result := SNMPSend.SendRequest;
Value := '';
if Result then
Value := SNMPSend.Reply.MIBGet(OID);
@ -364,7 +921,7 @@ begin
end;
end;
function SNMPSet(const OID, Community, SNMPHost, Value: string; ValueType: Integer): Boolean;
function SNMPSet(const OID, Community, SNMPHost, Value: AnsiString; ValueType: Integer): Boolean;
var
SNMPSend: TSNMPSend;
begin
@ -375,21 +932,21 @@ begin
SNMPSend.Query.PDUType := PDUSetRequest;
SNMPSend.Query.MIBAdd(OID, Value, ValueType);
SNMPSend.TargetHost := SNMPHost;
Result := SNMPSend.DoIt = True;
Result := SNMPSend.Sendrequest = True;
finally
SNMPSend.Free;
end;
end;
function InternalGetNext(const SNMPSend: TSNMPSend; var OID: string;
const Community: string; var Value: string): Boolean;
function InternalGetNext(const SNMPSend: TSNMPSend; var OID: AnsiString;
const Community: AnsiString; var Value: AnsiString): Boolean;
begin
SNMPSend.Query.Clear;
SNMPSend.Query.ID := SNMPSend.Query.ID + 1;
SNMPSend.Query.Community := Community;
SNMPSend.Query.PDUType := PDUGetNextRequest;
SNMPSend.Query.MIBAdd(OID, '', ASN1_NULL);
Result := SNMPSend.DoIt;
Result := SNMPSend.Sendrequest;
Value := '';
if Result then
if SNMPSend.Reply.SNMPMibList.Count > 0 then
@ -399,7 +956,7 @@ begin
end;
end;
function SNMPGetNext(var OID: string; const Community, SNMPHost: string; var Value: string): Boolean;
function SNMPGetNext(var OID: AnsiString; const Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
var
SNMPSend: TSNMPSend;
begin
@ -412,11 +969,11 @@ begin
end;
end;
function SNMPGetTable(const BaseOID, Community, SNMPHost: string; const Value: TStrings): Boolean;
function SNMPGetTable(const BaseOID, Community, SNMPHost: AnsiString; const Value: TStrings): Boolean;
var
OID: string;
s: string;
col,row: string;
OID: AnsiString;
s: AnsiString;
col,row: String;
x: integer;
SNMPSend: TSNMPSend;
RowList: TStringList;
@ -452,14 +1009,73 @@ begin
end;
end;
function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: string; var Value: String): Boolean;
function SNMPGetTableElement(const BaseOID, RowID, ColID, Community, SNMPHost: AnsiString; var Value: AnsiString): Boolean;
var
s: string;
s: AnsiString;
begin
s := BaseOID + '.' + ColID + '.' + RowID;
Result := SnmpGet(s, Community, SNMPHost, Value);
end;
function SendTrap(const Dest, Source, Enterprise, Community: AnsiString;
Generic, Specific, Seconds: Integer; const MIBName, MIBValue: AnsiString;
MIBtype: Integer): Integer;
var
SNMPSend: TSNMPSend;
begin
SNMPSend := TSNMPSend.Create;
try
SNMPSend.TargetHost := Dest;
SNMPSend.TargetPort := cSnmpTrapProtocol;
SNMPSend.Query.Community := Community;
SNMPSend.Query.Version := SNMP_V1;
SNMPSend.Query.PDUType := PDUTrap;
SNMPSend.Query.OldTrapHost := Source;
SNMPSend.Query.OldTrapEnterprise := Enterprise;
SNMPSend.Query.OldTrapGen := Generic;
SNMPSend.Query.OldTrapSpec := Specific;
SNMPSend.Query.OldTrapTimeTicks := Seconds;
SNMPSend.Query.MIBAdd(MIBName, MIBValue, MIBType);
Result := Ord(SNMPSend.SendTrap);
finally
SNMPSend.Free;
end;
end;
function RecvTrap(var Dest, Source, Enterprise, Community: AnsiString;
var Generic, Specific, Seconds: Integer;
const MIBName, MIBValue: TStringList): Integer;
var
SNMPSend: TSNMPSend;
i: Integer;
begin
SNMPSend := TSNMPSend.Create;
try
Result := 0;
SNMPSend.TargetPort := cSnmpTrapProtocol;
if SNMPSend.RecvTrap then
begin
Dest := SNMPSend.HostIP;
Community := SNMPSend.Reply.Community;
Source := SNMPSend.Reply.OldTrapHost;
Enterprise := SNMPSend.Reply.OldTrapEnterprise;
Generic := SNMPSend.Reply.OldTrapGen;
Specific := SNMPSend.Reply.OldTrapSpec;
Seconds := SNMPSend.Reply.OldTrapTimeTicks;
MIBName.Clear;
MIBValue.Clear;
for i := 0 to SNMPSend.Reply.SNMPMibList.Count - 1 do
begin
MIBName.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).OID);
MIBValue.Add(TSNMPMib(SNMPSend.Reply.SNMPMibList[i]).Value);
end;
end;
finally
SNMPSend.Free;
end;
end;
end.

361
snmptrap.pas
View File

@ -1,361 +0,0 @@
{==============================================================================|
| Project : Ararat Synapse | 002.003.004 |
|==============================================================================|
| Content: SNMP traps |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Hernan Sanchez are Copyright (c)2000-2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Hernan Sanchez (hernan.sanchez@iname.com) |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit snmptrap;
interface
uses
Classes, SysUtils,
blcksock, synautil, asn1util, snmpsend;
const
cSnmpTrapProtocol = '162';
SNMP_VERSION = 0;
PDU_GET = $A0;
PDU_GETN = $A1;
PDU_RESP = $A2;
PDU_SET = $A3;
PDU_TRAP = $A4;
type
TTrapPDU = class(TObject)
private
FBuffer: string;
FVersion: Integer;
FPDUType: Integer;
FCommunity: string;
FEnterprise: string;
FTrapHost: string;
FGenTrap: Integer;
FSpecTrap: Integer;
FTimeTicks: Integer;
FSNMPMibList: TList;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure MIBAdd(const MIB, Value: string; ValueType: Integer);
procedure MIBDelete(Index: Integer);
function MIBGet(const MIB: string): string;
function EncodeTrap: Integer;
function DecodeTrap: Boolean;
published
property Version: Integer read FVersion Write FVersion;
property Community: string read FCommunity Write FCommunity;
property PDUType: Integer read FPDUType Write FPDUType;
property Enterprise: string read FEnterprise Write FEnterprise;
property TrapHost: string read FTrapHost Write FTrapHost;
property GenTrap: Integer read FGenTrap Write FGenTrap;
property SpecTrap: Integer read FSpecTrap Write FSpecTrap;
property TimeTicks: Integer read FTimeTicks Write FTimeTicks;
property SNMPMibList: TList read FSNMPMibList;
end;
TTrapSNMP = class(TSynaClient)
private
FSock: TUDPBlockSocket;
FTrap: TTrapPDU;
public
constructor Create;
destructor Destroy; override;
function Send: Integer;
function Recv: Integer;
published
property Trap: TTrapPDU read FTrap;
property Sock: TUDPBlockSocket read FSock;
end;
function SendTrap(const Dest, Source, Enterprise, Community: string;
Generic, Specific, Seconds: Integer; const MIBName, MIBValue: string;
MIBtype: Integer): Integer;
function RecvTrap(var Dest, Source, Enterprise, Community: string;
var Generic, Specific, Seconds: Integer; const MIBName,
MIBValue: TStringList): Integer;
implementation
constructor TTrapPDU.Create;
begin
inherited Create;
FSNMPMibList := TList.Create;
FVersion := SNMP_VERSION;
FPDUType := PDU_TRAP;
FCommunity := 'public';
end;
destructor TTrapPDU.Destroy;
var
i: Integer;
begin
for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Free;
inherited Destroy;
end;
procedure TTrapPDU.Clear;
var
i: Integer;
begin
for i := 0 to FSNMPMibList.Count - 1 do
TSNMPMib(FSNMPMibList[i]).Free;
FSNMPMibList.Clear;
FVersion := SNMP_VERSION;
FPDUType := PDU_TRAP;
FCommunity := 'public';
end;
procedure TTrapPDU.MIBAdd(const MIB, Value: string; ValueType: Integer);
var
SNMPMib: TSNMPMib;
begin
SNMPMib := TSNMPMib.Create;
SNMPMib.OID := MIB;
SNMPMib.Value := Value;
SNMPMib.ValueType := ValueType;
FSNMPMibList.Add(SNMPMib);
end;
procedure TTrapPDU.MIBDelete(Index: Integer);
begin
if (Index >= 0) and (Index < FSNMPMibList.Count) then
begin
TSNMPMib(FSNMPMibList[Index]).Free;
FSNMPMibList.Delete(Index);
end;
end;
function TTrapPDU.MIBGet(const MIB: string): string;
var
i: Integer;
begin
Result := '';
for i := 0 to FSNMPMibList.Count - 1 do
begin
if TSNMPMib(FSNMPMibList[i]).OID = MIB then
begin
Result := TSNMPMib(FSNMPMibList[i]).Value;
Break;
end;
end;
end;
function TTrapPDU.EncodeTrap: Integer;
var
s: string;
n: Integer;
SNMPMib: TSNMPMib;
begin
FBuffer := '';
for n := 0 to FSNMPMibList.Count - 1 do
begin
SNMPMib := FSNMPMibList[n];
case SNMPMib.ValueType of
ASN1_INT:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(ASNEncUInt(StrToIntDef(SNMPMib.Value, 0)), SNMPMib.ValueType);
ASN1_OBJID:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(MibToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_IPADDR:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(IPToID(SNMPMib.Value), SNMPMib.ValueType);
ASN1_NULL:
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject('', ASN1_NULL);
else
s := ASNObject(MibToID(SNMPMib.OID), ASN1_OBJID) +
ASNObject(SNMPMib.Value, SNMPMib.ValueType);
end;
FBuffer := FBuffer + ASNObject(s, ASN1_SEQ);
end;
FBuffer := ASNObject(FBuffer, ASN1_SEQ);
FBuffer := ASNObject(ASNEncInt(FGenTrap), ASN1_INT) +
ASNObject(ASNEncInt(FSpecTrap), ASN1_INT) +
ASNObject(ASNEncUInt(FTimeTicks), ASN1_TIMETICKS) +
FBuffer;
FBuffer := ASNObject(MibToID(FEnterprise), ASN1_OBJID) +
ASNObject(IPToID(FTrapHost), ASN1_IPADDR) +
FBuffer;
FBuffer := ASNObject(ASNEncInt(FVersion), ASN1_INT) +
ASNObject(FCommunity, ASN1_OCTSTR) +
ASNObject(FBuffer, Self.FPDUType);
FBuffer := ASNObject(FBuffer, ASN1_SEQ);
Result := 1;
end;
function TTrapPDU.DecodeTrap: Boolean;
var
Pos, EndPos: Integer;
Sm, Sv: string;
Svt: Integer;
begin
Clear;
Result := False;
if Length(FBuffer) < 2 then
Exit;
if (Ord(FBuffer[1]) and $20) = 0 then
Exit;
Pos := 2;
EndPos := ASNDecLen(Pos, FBuffer);
FVersion := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
FCommunity := ASNItem(Pos, FBuffer, Svt);
FPDUType := StrToIntDef(ASNItem(Pos, FBuffer, Svt), PDU_TRAP);
FEnterprise := ASNItem(Pos, FBuffer, Svt);
FTrapHost := ASNItem(Pos, FBuffer, Svt);
FGenTrap := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
FSpecTrap := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
FTimeTicks := StrToIntDef(ASNItem(Pos, FBuffer, Svt), 0);
ASNItem(Pos, FBuffer, Svt);
while Pos < EndPos do
begin
ASNItem(Pos, FBuffer, Svt);
Sm := ASNItem(Pos, FBuffer, Svt);
Sv := ASNItem(Pos, FBuffer, Svt);
MIBAdd(Sm, Sv, Svt);
end;
Result := True;
end;
constructor TTrapSNMP.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FTrap := TTrapPDU.Create;
FTimeout := 5000;
FTargetPort := cSnmpTrapProtocol;
end;
destructor TTrapSNMP.Destroy;
begin
FTrap.Free;
FSock.Free;
inherited Destroy;
end;
function TTrapSNMP.Send: Integer;
begin
FTrap.EncodeTrap;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(FTrap.FBuffer);
Result := 1;
end;
function TTrapSNMP.Recv: Integer;
begin
Result := 0;
FSock.Bind(FIPInterface, FTargetPort);
FTrap.FBuffer := FSock.RecvPacket(FTimeout);
if Fsock.Lasterror = 0 then
if FTrap.DecodeTrap then
Result := 1;
end;
function SendTrap(const Dest, Source, Enterprise, Community: string;
Generic, Specific, Seconds: Integer; const MIBName, MIBValue: string;
MIBtype: Integer): Integer;
begin
with TTrapSNMP.Create do
try
TargetHost := Dest;
Trap.TrapHost := Source;
Trap.Enterprise := Enterprise;
Trap.Community := Community;
Trap.GenTrap := Generic;
Trap.SpecTrap := Specific;
Trap.TimeTicks := Seconds;
Trap.MIBAdd(MIBName, MIBValue, MIBType);
Result := Send;
finally
Free;
end;
end;
function RecvTrap(var Dest, Source, Enterprise, Community: string;
var Generic, Specific, Seconds: Integer;
const MIBName, MIBValue: TStringList): Integer;
var
i: Integer;
begin
with TTrapSNMP.Create do
try
TargetHost := Dest;
Result := Recv;
if Result <> 0 then
begin
Dest := TargetHost;
Source := Trap.TrapHost;
Enterprise := Trap.Enterprise;
Community := Trap.Community;
Generic := Trap.GenTrap;
Specific := Trap.SpecTrap;
Seconds := Trap.TimeTicks;
MIBName.Clear;
MIBValue.Clear;
for i := 0 to Trap.SNMPMibList.Count - 1 do
begin
MIBName.Add(TSNMPMib(Trap.SNMPMibList[i]).OID);
MIBValue.Add(TSNMPMib(Trap.SNMPMibList[i]).Value);
end;
end;
finally
Free;
end;
end;
end.

139
sntpsend.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 002.002.007 |
| Project : Ararat Synapse | 003.000.000 |
|==============================================================================|
| Content: SNTP client |
|==============================================================================|
@ -43,6 +43,11 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract( NTP and SNTP client)
Used RFC: RFC-1305, RFC-2030
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
@ -61,7 +66,8 @@ const
cNtpProtocol = 'ntp';
type
PNtp = ^TNtp;
{:@abstract(Record containing the NTP packet.)}
TNtp = packed record
mode: Byte;
stratum: Byte;
@ -80,6 +86,12 @@ type
Xmit2: Longint;
end;
{:@abstract(Implementation of NTP and SNTP client protocol),
include time synchronisation. It can send NTP or SNTP time queries, or it
can receive NTP broadcasts too.
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSNTPSend = class(TSynaClient)
private
FNTPReply: TNtp;
@ -91,21 +103,56 @@ type
FSock: TUDPBlockSocket;
FBuffer: string;
FLi, FVn, Fmode : byte;
function StrToNTP(const Value: AnsiString): TNtp;
function NTPtoStr(const Value: Tntp): AnsiString;
procedure ClearNTP(var Value: Tntp);
public
constructor Create;
destructor Destroy; override;
{:Decode 128 bit timestamp used in NTP packet to TDateTime type.}
function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
{:Decode TDateTime type to 128 bit timestamp used in NTP packet.}
procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
valid.}
function GetSNTP: Boolean;
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
valid. Result time is after all needed corrections.}
function GetNTP: Boolean;
{:Wait for broadcast NTP packet. If all OK, result is @true and
@link(NTPReply) and @link(NTPTime) are valid.}
function GetBroadcastNTP: Boolean;
{:Holds last received NTP packet.}
property NTPReply: TNtp read FNTPReply;
published
{:Date and time of remote NTP or SNTP server. (UTC time!!!)}
property NTPTime: TDateTime read FNTPTime;
{:Offset between your computer and remote NTP or SNTP server.}
property NTPOffset: Double read FNTPOffset;
{:Delay between your computer and remote NTP or SNTP server.}
property NTPDelay: Double read FNTPDelay;
{:Define allowed maximum difference between your time and remote time for
synchronising time. If difference is bigger, your system time is not
changed!}
property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
{:If @true, after successfull getting time is local computer clock
synchronised to given time.
For synchronising time you must have proper rights! (Usually Administrator)}
property SyncTime: Boolean read FSyncTime write FSyncTime;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TUDPBlockSocket read FSock;
end;
@ -127,14 +174,74 @@ begin
inherited Destroy;
end;
function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp;
begin
if length(FBuffer) >= SizeOf(Result) then
begin
Result.mode := ord(Value[1]);
Result.stratum := ord(Value[2]);
Result.poll := ord(Value[3]);
Result.Precision := ord(Value[4]);
Result.RootDelay := DecodeLongInt(value, 5);
Result.RootDisperson := DecodeLongInt(value, 9);
Result.RefID := DecodeLongInt(value, 13);
Result.Ref1 := DecodeLongInt(value, 17);
Result.Ref2 := DecodeLongInt(value, 21);
Result.Org1 := DecodeLongInt(value, 25);
Result.Org2 := DecodeLongInt(value, 29);
Result.Rcv1 := DecodeLongInt(value, 33);
Result.Rcv2 := DecodeLongInt(value, 37);
Result.Xmit1 := DecodeLongInt(value, 41);
Result.Xmit2 := DecodeLongInt(value, 45);
end;
end;
function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString;
begin
SetLength(Result, 4);
Result[1] := AnsiChar(Value.mode);
Result[2] := AnsiChar(Value.stratum);
Result[3] := AnsiChar(Value.poll);
Result[4] := AnsiChar(Value.precision);
Result := Result + CodeLongInt(Value.RootDelay);
Result := Result + CodeLongInt(Value.RootDisperson);
Result := Result + CodeLongInt(Value.RefID);
Result := Result + CodeLongInt(Value.Ref1);
Result := Result + CodeLongInt(Value.Ref2);
Result := Result + CodeLongInt(Value.Org1);
Result := Result + CodeLongInt(Value.Org2);
Result := Result + CodeLongInt(Value.Rcv1);
Result := Result + CodeLongInt(Value.Rcv2);
Result := Result + CodeLongInt(Value.Xmit1);
Result := Result + CodeLongInt(Value.Xmit2);
end;
procedure TSNTPSend.ClearNTP(var Value: Tntp);
begin
Value.mode := 0;
Value.stratum := 0;
Value.poll := 0;
Value.Precision := 0;
Value.RootDelay := 0;
Value.RootDisperson := 0;
Value.RefID := 0;
Value.Ref1 := 0;
Value.Ref2 := 0;
Value.Org1 := 0;
Value.Org2 := 0;
Value.Rcv1 := 0;
Value.Rcv2 := 0;
Value.Xmit1 := 0;
Value.Xmit2 := 0;
end;
function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
const
maxi = 4294967295.0;
var
d, d1: Double;
begin
Nsec := synsock.htonl(Nsec);
Nfrac := synsock.htonl(Nfrac);
d := Nsec;
if d < 0 then
d := maxi + d + 1;
@ -165,13 +272,10 @@ begin
d1 := d1 - maxi - 1;
Nsec:=trunc(d);
Nfrac:=trunc(d1);
Nsec := synsock.htonl(Nsec);
Nfrac := synsock.htonl(Nfrac);
end;
function TSNTPSend.GetBroadcastNTP: Boolean;
var
NtpPtr: PNtp;
x: Integer;
begin
Result := False;
@ -183,8 +287,7 @@ begin
if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
if x >= SizeOf(NTPReply) then
begin
NtpPtr := Pointer(FBuffer);
FNTPReply := NtpPtr^;
FNTPReply := StrToNTP(FBuffer);
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime);
@ -196,23 +299,22 @@ end;
function TSNTPSend.GetSNTP: Boolean;
var
q: TNtp;
NtpPtr: PNtp;
x: Integer;
begin
Result := False;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FillChar(q, SizeOf(q), 0);
ClearNtp(q);
q.mode := $1B;
FSock.SendBuffer(@q, SizeOf(q));
FBuffer := NTPtoStr(q);
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
if x >= SizeOf(NTPReply) then
begin
NtpPtr := Pointer(FBuffer);
FNTPReply := NtpPtr^;
FNTPReply := StrToNTP(FBuffer);
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime);
@ -224,18 +326,18 @@ end;
function TSNTPSend.GetNTP: Boolean;
var
q: TNtp;
NtpPtr: PNtp;
x: Integer;
t1, t2, t3, t4 : TDateTime;
begin
Result := False;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
FillChar(q, SizeOf(q), 0);
ClearNtp(q);
q.mode := $1B;
t1 := GetUTTime;
EncodeTs(t1, q.org1, q.org2);
FSock.SendBuffer(@q, SizeOf(q));
FBuffer := NTPtoStr(q);
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
@ -243,8 +345,7 @@ begin
t4 := GetUTTime;
if x >= SizeOf(NTPReply) then
begin
NtpPtr := Pointer(FBuffer);
FNTPReply := NtpPtr^;
FNTPReply := StrToNTP(FBuffer);
FLi := (NTPReply.mode and $C0) shr 6;
FVn := (NTPReply.mode and $38) shr 3;
Fmode := NTPReply.mode and $07;

1013
ssdotnet.pas Normal file
View File

File diff suppressed because it is too large Load Diff

963
sslinux.pas Normal file
View File

@ -0,0 +1,963 @@
{==============================================================================|
| Project : Ararat Synapse | 002.000.002 |
|==============================================================================|
| Content: Socket Independent Platform Layer - Linux definition include |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
{$IFDEF LINUX}
//{$DEFINE FORCEOLDAPI}
{Note about define FORCEOLDAPI:
If you activate this compiler directive, then is allways used old socket API
for name resolution. If you leave this directive inactive, then the new API
is used, when running system allows it.
For IPv6 support you must have new API!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
interface
uses
SyncObjs, SysUtils,
{$IFDEF FPC}
synafpc,
{$ENDIF}
Libc;
function InitSocketInterface(stack: string): Boolean;
function DestroySocketInterface: Boolean;
const
WinsockLevel = $0202;
type
u_char = Char;
u_short = Word;
u_int = Integer;
u_long = Longint;
pu_long = ^u_long;
pu_short = ^u_short;
TSocket = u_int;
TMemory = pointer;
const
DLLStackName = 'libc.so.6';
type
DWORD = Integer;
__fd_mask = LongWord;
const
__FD_SETSIZE = 1024;
__NFDBITS = 8 * sizeof(__fd_mask);
type
__fd_set = {packed} record
fds_bits: packed array[0..(__FD_SETSIZE div __NFDBITS)-1] of __fd_mask;
end;
TFDSet = __fd_set;
PFDSet = ^TFDSet;
const
FIONREAD = $541B;
FIONBIO = $5421;
FIOASYNC = $5452;
type
PTimeVal = ^TTimeVal;
TTimeVal = packed record
tv_sec: Longint;
tv_usec: Longint;
end;
const
IPPROTO_IP = 0; { Dummy }
IPPROTO_ICMP = 1; { Internet Control Message Protocol }
IPPROTO_IGMP = 2; { Internet Group Management Protocol}
IPPROTO_TCP = 6; { TCP }
IPPROTO_UDP = 17; { User Datagram Protocol }
IPPROTO_IPV6 = 41;
IPPROTO_ICMPV6 = 58;
IPPROTO_RAW = 255;
IPPROTO_MAX = 256;
type
SunB = packed record
s_b1, s_b2, s_b3, s_b4: u_char;
end;
SunW = packed record
s_w1, s_w2: u_short;
end;
PInAddr = ^TInAddr;
TInAddr = packed record
case integer of
0: (S_un_b: SunB);
1: (S_un_w: SunW);
2: (S_addr: u_long);
end;
PSockAddrIn = ^TSockAddrIn;
TSockAddrIn = packed record
case Integer of
0: (sin_family: u_short;
sin_port: u_short;
sin_addr: TInAddr;
sin_zero: array[0..7] of Char);
1: (sa_family: u_short;
sa_data: array[0..13] of Char)
end;
TIP_mreq = record
imr_multiaddr: TInAddr; { IP multicast address of group }
imr_interface: TInAddr; { local IP address of interface }
end;
SunB6 = packed record
s_b1, s_b2, s_b3, s_b4,
s_b5, s_b6, s_b7, s_b8,
s_b9, s_b10, s_b11, s_b12,
s_b13, s_b14, s_b15, s_b16: u_char;
end;
SunW6 = packed record
s_w1, s_w2, s_w3, s_w4,
s_w5, s_w6, s_w7, s_w8: u_short;
end;
SunDW6 = packed record
s_dw1, s_dw2, s_dw3, s_dw4: longint;
end;
S6_Bytes = SunB6;
S6_Words = SunW6;
S6_DWords = SunDW6;
S6_Addr = SunB6;
PInAddr6 = ^TInAddr6;
TInAddr6 = packed record
case integer of
0: (S_un_b: SunB6);
1: (S_un_w: SunW6);
2: (S_un_dw: SunDW6);
end;
PSockAddrIn6 = ^TSockAddrIn6;
TSockAddrIn6 = packed record
sin6_family: u_short; // AF_INET6
sin6_port: u_short; // Transport level port number
sin6_flowinfo: u_long; // IPv6 flow information
sin6_addr: TInAddr6; // IPv6 address
sin6_scope_id: u_long; // Scope Id: IF number for link-local
// SITE id for site-local
end;
TIPv6_mreq = record
ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
ipv6mr_interface: u_long; // Interface index.
padding: u_long;
end;
hostent = record
h_name: PChar;
h_aliases: PPChar;
h_addrtype: Integer;
h_length: Cardinal;
case Byte of
0: (h_addr_list: PPChar);
1: (h_addr: PPChar);
end;
PNetEnt = ^TNetEnt;
TNetEnt = record
n_name: PChar;
n_aliases: PPChar;
n_addrtype: Integer;
n_net: uint32_t;
end;
PServEnt = ^TServEnt;
TServEnt = record
s_name: PChar;
s_aliases: PPChar;
s_port: Integer;
s_proto: PChar;
end;
PProtoEnt = ^TProtoEnt;
TProtoEnt = record
p_name: PChar;
p_aliases: ^PChar;
p_proto: u_short;
end;
const
INADDR_ANY = $00000000;
INADDR_LOOPBACK = $7F000001;
INADDR_BROADCAST = $FFFFFFFF;
INADDR_NONE = $FFFFFFFF;
ADDR_ANY = INADDR_ANY;
INVALID_SOCKET = TSocket(NOT(0));
SOCKET_ERROR = -1;
Const
IP_TOS = 1; { int; IP type of service and precedence. }
IP_TTL = 2; { int; IP time to live. }
IP_HDRINCL = 3; { int; Header is included with data. }
IP_OPTIONS = 4; { ip_opts; IP per-packet options. }
IP_ROUTER_ALERT = 5; { bool }
IP_RECVOPTS = 6; { bool }
IP_RETOPTS = 7; { bool }
IP_PKTINFO = 8; { bool }
IP_PKTOPTIONS = 9;
IP_PMTUDISC = 10; { obsolete name? }
IP_MTU_DISCOVER = 10; { int; see below }
IP_RECVERR = 11; { bool }
IP_RECVTTL = 12; { bool }
IP_RECVTOS = 13; { bool }
IP_MULTICAST_IF = 32; { in_addr; set/get IP multicast i/f }
IP_MULTICAST_TTL = 33; { u_char; set/get IP multicast ttl }
IP_MULTICAST_LOOP = 34; { i_char; set/get IP multicast loopback }
IP_ADD_MEMBERSHIP = 35; { ip_mreq; add an IP group membership }
IP_DROP_MEMBERSHIP = 36; { ip_mreq; drop an IP group membership }
SOL_SOCKET = 1;
SO_DEBUG = 1;
SO_REUSEADDR = 2;
SO_TYPE = 3;
SO_ERROR = 4;
SO_DONTROUTE = 5;
SO_BROADCAST = 6;
SO_SNDBUF = 7;
SO_RCVBUF = 8;
SO_KEEPALIVE = 9;
SO_OOBINLINE = 10;
SO_NO_CHECK = 11;
SO_PRIORITY = 12;
SO_LINGER = 13;
SO_BSDCOMPAT = 14;
SO_REUSEPORT = 15;
SO_PASSCRED = 16;
SO_PEERCRED = 17;
SO_RCVLOWAT = 18;
SO_SNDLOWAT = 19;
SO_RCVTIMEO = 20;
SO_SNDTIMEO = 21;
{ Security levels - as per NRL IPv6 - don't actually do anything }
SO_SECURITY_AUTHENTICATION = 22;
SO_SECURITY_ENCRYPTION_TRANSPORT = 23;
SO_SECURITY_ENCRYPTION_NETWORK = 24;
SO_BINDTODEVICE = 25;
{ Socket filtering }
SO_ATTACH_FILTER = 26;
SO_DETACH_FILTER = 27;
SOMAXCONN = 128;
IPV6_UNICAST_HOPS = 16;
IPV6_MULTICAST_IF = 17;
IPV6_MULTICAST_HOPS = 18;
IPV6_MULTICAST_LOOP = 19;
IPV6_JOIN_GROUP = 20;
IPV6_LEAVE_GROUP = 21;
MSG_NOSIGNAL = $4000; // Do not generate SIGPIPE.
// getnameinfo constants
NI_MAXHOST = 1025;
NI_MAXSERV = 32;
NI_NOFQDN = $4;
NI_NUMERICHOST = $1;
NI_NAMEREQD = $8;
NI_NUMERICSERV = $2;
NI_DGRAM = $10;
const
SOCK_STREAM = 1; { stream socket }
SOCK_DGRAM = 2; { datagram socket }
SOCK_RAW = 3; { raw-protocol interface }
SOCK_RDM = 4; { reliably-delivered message }
SOCK_SEQPACKET = 5; { sequenced packet stream }
{ TCP options. }
TCP_NODELAY = $0001;
{ Address families. }
AF_UNSPEC = 0; { unspecified }
AF_INET = 2; { internetwork: UDP, TCP, etc. }
AF_INET6 = 10; { Internetwork Version 6 }
AF_MAX = 24;
{ Protocol families, same as address families for now. }
PF_UNSPEC = AF_UNSPEC;
PF_INET = AF_INET;
PF_INET6 = AF_INET6;
PF_MAX = AF_MAX;
type
{ Structure used by kernel to store most addresses. }
PSockAddr = ^TSockAddr;
TSockAddr = TSockAddrIn;
{ Structure used by kernel to pass protocol information in raw sockets. }
PSockProto = ^TSockProto;
TSockProto = packed record
sp_family: u_short;
sp_protocol: u_short;
end;
type
PAddrInfo = ^TAddrInfo;
TAddrInfo = record
ai_flags: integer; // AI_PASSIVE, AI_CANONNAME, AI_NUMERICHOST.
ai_family: integer; // PF_xxx.
ai_socktype: integer; // SOCK_xxx.
ai_protocol: integer; // 0 or IPPROTO_xxx for IPv4 and IPv6.
ai_addrlen: u_int; // Length of ai_addr.
ai_addr: PSockAddr; // Binary address.
ai_canonname: PChar; // Canonical name for nodename.
ai_next: PAddrInfo; // Next structure in linked list.
end;
const
// Flags used in "hints" argument to getaddrinfo().
AI_PASSIVE = $1; // Socket address will be used in bind() call.
AI_CANONNAME = $2; // Return canonical name in first ai_canonname.
AI_NUMERICHOST = $4; // Nodename must be a numeric address string.
type
{ Structure used for manipulating linger option. }
PLinger = ^TLinger;
TLinger = packed record
l_onoff: u_short;
l_linger: u_short;
end;
const
MSG_OOB = $01; // Process out-of-band data.
MSG_PEEK = $02; // Peek at incoming messages.
const
WSAEINTR = EINTR;
WSAEBADF = EBADF;
WSAEACCES = EACCES;
WSAEFAULT = EFAULT;
WSAEINVAL = EINVAL;
WSAEMFILE = EMFILE;
WSAEWOULDBLOCK = EWOULDBLOCK;
WSAEINPROGRESS = EINPROGRESS;
WSAEALREADY = EALREADY;
WSAENOTSOCK = ENOTSOCK;
WSAEDESTADDRREQ = EDESTADDRREQ;
WSAEMSGSIZE = EMSGSIZE;
WSAEPROTOTYPE = EPROTOTYPE;
WSAENOPROTOOPT = ENOPROTOOPT;
WSAEPROTONOSUPPORT = EPROTONOSUPPORT;
WSAESOCKTNOSUPPORT = ESOCKTNOSUPPORT;
WSAEOPNOTSUPP = EOPNOTSUPP;
WSAEPFNOSUPPORT = EPFNOSUPPORT;
WSAEAFNOSUPPORT = EAFNOSUPPORT;
WSAEADDRINUSE = EADDRINUSE;
WSAEADDRNOTAVAIL = EADDRNOTAVAIL;
WSAENETDOWN = ENETDOWN;
WSAENETUNREACH = ENETUNREACH;
WSAENETRESET = ENETRESET;
WSAECONNABORTED = ECONNABORTED;
WSAECONNRESET = ECONNRESET;
WSAENOBUFS = ENOBUFS;
WSAEISCONN = EISCONN;
WSAENOTCONN = ENOTCONN;
WSAESHUTDOWN = ESHUTDOWN;
WSAETOOMANYREFS = ETOOMANYREFS;
WSAETIMEDOUT = ETIMEDOUT;
WSAECONNREFUSED = ECONNREFUSED;
WSAELOOP = ELOOP;
WSAENAMETOOLONG = ENAMETOOLONG;
WSAEHOSTDOWN = EHOSTDOWN;
WSAEHOSTUNREACH = EHOSTUNREACH;
WSAENOTEMPTY = ENOTEMPTY;
WSAEPROCLIM = -1;
WSAEUSERS = EUSERS;
WSAEDQUOT = EDQUOT;
WSAESTALE = ESTALE;
WSAEREMOTE = EREMOTE;
WSASYSNOTREADY = -2;
WSAVERNOTSUPPORTED = -3;
WSANOTINITIALISED = -4;
WSAEDISCON = -5;
WSAHOST_NOT_FOUND = HOST_NOT_FOUND;
WSATRY_AGAIN = TRY_AGAIN;
WSANO_RECOVERY = NO_RECOVERY;
WSANO_DATA = -6;
EAI_BADFLAGS = -1; { Invalid value for `ai_flags' field. }
EAI_NONAME = -2; { NAME or SERVICE is unknown. }
EAI_AGAIN = -3; { Temporary failure in name resolution. }
EAI_FAIL = -4; { Non-recoverable failure in name res. }
EAI_NODATA = -5; { No address associated with NAME. }
EAI_FAMILY = -6; { `ai_family' not supported. }
EAI_SOCKTYPE = -7; { `ai_socktype' not supported. }
EAI_SERVICE = -8; { SERVICE not supported for `ai_socktype'. }
EAI_ADDRFAMILY = -9; { Address family for NAME not supported. }
EAI_MEMORY = -10; { Memory allocation failure. }
EAI_SYSTEM = -11; { System error returned in `errno'. }
const
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
TWSAData = packed record
wVersion: Word;
wHighVersion: Word;
szDescription: array[0..WSADESCRIPTION_LEN] of Char;
szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
var
in6addr_any, in6addr_loopback : TInAddr6;
procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
procedure FD_ZERO(var FDSet: TFDSet);
{=============================================================================}
type
TWSAStartup = function(wVersionRequired: Word; var WSData: TWSAData): Integer;
cdecl;
TWSACleanup = function: Integer;
cdecl;
TWSAGetLastError = function: Integer;
cdecl;
TGetServByName = function(name, proto: PChar): PServEnt;
cdecl;
TGetServByPort = function(port: Integer; proto: PChar): PServEnt;
cdecl;
TGetProtoByName = function(name: PChar): PProtoEnt;
cdecl;
TGetProtoByNumber = function(proto: Integer): PProtoEnt;
cdecl;
TGetHostByName = function(name: PChar): PHostEnt;
cdecl;
TGetHostByAddr = function(addr: Pointer; len, Struc: Integer): PHostEnt;
cdecl;
TGetHostName = function(name: PChar; len: Integer): Integer;
cdecl;
TShutdown = function(s: TSocket; how: Integer): Integer;
cdecl;
TSetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar;
optlen: Integer): Integer;
cdecl;
TGetSockOpt = function(s: TSocket; level, optname: Integer; optval: PChar;
var optlen: Integer): Integer;
cdecl;
TSendTo = function(s: TSocket; const Buf; len, flags: Integer; addrto: PSockAddr;
tolen: Integer): Integer;
cdecl;
TSend = function(s: TSocket; const Buf; len, flags: Integer): Integer;
cdecl;
TRecv = function(s: TSocket; var Buf; len, flags: Integer): Integer;
cdecl;
TRecvFrom = function(s: TSocket; var Buf; len, flags: Integer; from: PSockAddr;
var fromlen: Integer): Integer;
cdecl;
Tntohs = function(netshort: u_short): u_short;
cdecl;
Tntohl = function(netlong: u_long): u_long;
cdecl;
TListen = function(s: TSocket; backlog: Integer): Integer;
cdecl;
TIoctlSocket = function(s: TSocket; cmd: DWORD; var arg: u_long): Integer;
cdecl;
TInet_ntoa = function(inaddr: TInAddr): PChar;
cdecl;
TInet_addr = function(cp: PChar): u_long;
cdecl;
Thtons = function(hostshort: u_short): u_short;
cdecl;
Thtonl = function(hostlong: u_long): u_long;
cdecl;
TGetSockName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
cdecl;
TGetPeerName = function(s: TSocket; name: PSockAddr; var namelen: Integer): Integer;
cdecl;
TConnect = function(s: TSocket; name: PSockAddr; namelen: Integer): Integer;
cdecl;
TCloseSocket = function(s: TSocket): Integer;
cdecl;
TBind = function(s: TSocket; addr: PSockAddr; namelen: Integer): Integer;
cdecl;
TAccept = function(s: TSocket; addr: PSockAddr; var addrlen: Integer): TSocket;
cdecl;
TTSocket = function(af, Struc, Protocol: Integer): TSocket;
cdecl;
TSelect = function(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint;
cdecl;
TGetAddrInfo = function(NodeName: PChar; ServName: PChar; Hints: PAddrInfo;
var Addrinfo: PAddrInfo): integer;
cdecl;
TFreeAddrInfo = procedure(ai: PAddrInfo);
cdecl;
TGetNameInfo = function( addr: PSockAddr; namelen: Integer; host: PChar;
hostlen: DWORD; serv: PChar; servlen: DWORD; flags: integer): integer;
cdecl;
var
WSAStartup: TWSAStartup = nil;
WSACleanup: TWSACleanup = nil;
WSAGetLastError: TWSAGetLastError = nil;
GetServByName: TGetServByName = nil;
GetServByPort: TGetServByPort = nil;
GetProtoByName: TGetProtoByName = nil;
GetProtoByNumber: TGetProtoByNumber = nil;
GetHostByName: TGetHostByName = nil;
GetHostByAddr: TGetHostByAddr = nil;
ssGetHostName: TGetHostName = nil;
Shutdown: TShutdown = nil;
SetSockOpt: TSetSockOpt = nil;
GetSockOpt: TGetSockOpt = nil;
ssSendTo: TSendTo = nil;
ssSend: TSend = nil;
ssRecv: TRecv = nil;
ssRecvFrom: TRecvFrom = nil;
ntohs: Tntohs = nil;
ntohl: Tntohl = nil;
Listen: TListen = nil;
IoctlSocket: TIoctlSocket = nil;
Inet_ntoa: TInet_ntoa = nil;
Inet_addr: TInet_addr = nil;
htons: Thtons = nil;
htonl: Thtonl = nil;
ssGetSockName: TGetSockName = nil;
ssGetPeerName: TGetPeerName = nil;
ssConnect: TConnect = nil;
CloseSocket: TCloseSocket = nil;
ssBind: TBind = nil;
ssAccept: TAccept = nil;
Socket: TTSocket = nil;
Select: TSelect = nil;
GetAddrInfo: TGetAddrInfo = nil;
FreeAddrInfo: TFreeAddrInfo = nil;
GetNameInfo: TGetNameInfo = nil;
function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer; cdecl;
function LSWSACleanup: Integer; cdecl;
function LSWSAGetLastError: Integer; cdecl;
var
SynSockCS: SyncObjs.TCriticalSection;
SockEnhancedApi: Boolean;
SockWship6Api: Boolean;
type
TVarSin = packed record
case integer of
0: (AddressFamily: u_short);
1: (
case sin_family: u_short of
AF_INET: (sin_port: u_short;
sin_addr: TInAddr;
sin_zero: array[0..7] of Char);
AF_INET6: (sin6_port: u_short;
sin6_flowinfo: u_long;
sin6_addr: TInAddr6;
sin6_scope_id: u_long);
);
end;
function SizeOfVarSin(sin: TVarSin): integer;
function Bind(s: TSocket; const addr: TVarSin): Integer;
function Connect(s: TSocket; const name: TVarSin): Integer;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
function GetHostName: string;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
{==============================================================================}
implementation
var
SynSockCount: Integer = 0;
LibHandle: THandle = 0;
Libwship6Handle: THandle = 0;
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
begin
Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and
(a^.s_un_dw.s_dw3 = 0) and (a^.s_un_dw.s_dw4 = 0));
end;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
begin
Result := ((a^.s_un_dw.s_dw1 = 0) and (a^.s_un_dw.s_dw2 = 0) and
(a^.s_un_dw.s_dw3 = 0) and
(a^.s_un_b.s_b13 = char(0)) and (a^.s_un_b.s_b14 = char(0)) and
(a^.s_un_b.s_b15 = char(0)) and (a^.s_un_b.s_b16 = char(1)));
end;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($80)));
end;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.s_un_b.s_b1 = u_char($FE)) and (a^.s_un_b.s_b2 = u_char($C0)));
end;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
begin
Result := (a^.s_un_b.s_b1 = char($FF));
end;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
begin
Result := (CompareMem( a, b, sizeof(TInAddr6)));
end;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
end;
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
a^.s_un_b.s_b16 := char(1);
end;
{=============================================================================}
var
{$IFNDEF FPC}
errno_loc: function: PInteger cdecl = nil;
{$ELSE}
errno_loc: function: PInteger = nil; cdecl;
{$ENDIF}
function LSWSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
begin
with WSData do
begin
wVersion := wVersionRequired;
wHighVersion := $202;
szDescription := 'Synsock - Synapse Platform Independent Socket Layer';
szSystemStatus := 'Running on Linux';
iMaxSockets := 32768;
iMaxUdpDg := 8192;
end;
Result := 0;
end;
function LSWSACleanup: Integer;
begin
Result := 0;
end;
function LSWSAGetLastError: Integer;
var
p: PInteger;
begin
p := errno_loc;
Result := p^;
end;
function __FDELT(Socket: TSocket): Integer;
begin
Result := Socket div __NFDBITS;
end;
function __FDMASK(Socket: TSocket): __fd_mask;
begin
Result := 1 shl (Socket mod __NFDBITS);
end;
function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean;
begin
Result := (fdset.fds_bits[__FDELT(Socket)] and __FDMASK(Socket)) <> 0;
end;
procedure FD_SET(Socket: TSocket; var fdset: TFDSet);
begin
fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] or __FDMASK(Socket);
end;
procedure FD_CLR(Socket: TSocket; var fdset: TFDSet);
begin
fdset.fds_bits[__FDELT(Socket)] := fdset.fds_bits[__FDELT(Socket)] and (not __FDMASK(Socket));
end;
procedure FD_ZERO(var fdset: TFDSet);
var
I: Integer;
begin
with fdset do
for I := Low(fds_bits) to High(fds_bits) do
fds_bits[I] := 0;
end;
{=============================================================================}
function SizeOfVarSin(sin: TVarSin): integer;
begin
case sin.sin_family of
AF_INET:
Result := SizeOf(TSockAddrIn);
AF_INET6:
Result := SizeOf(TSockAddrIn6);
else
Result := 0;
end;
end;
{=============================================================================}
function Bind(s: TSocket; const addr: TVarSin): Integer;
begin
Result := ssBind(s, @addr, SizeOfVarSin(addr));
end;
function Connect(s: TSocket; const name: TVarSin): Integer;
begin
Result := ssConnect(s, @name, SizeOfVarSin(name));
end;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
var
len: integer;
begin
len := SizeOf(name);
FillChar(name, len, 0);
Result := ssGetSockName(s, @name, Len);
end;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
var
len: integer;
begin
len := SizeOf(name);
FillChar(name, len, 0);
Result := ssGetPeerName(s, @name, Len);
end;
function GetHostName: string;
var
s: string;
begin
Result := '';
setlength(s, 255);
ssGetHostName(pchar(s), Length(s) - 1);
Result := Pchar(s);
end;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
begin
Result := ssSend(s, Buf^, len, flags);
end;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
begin
Result := ssRecv(s, Buf^, len, flags);
end;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
begin
Result := ssSendTo(s, Buf^, len, flags, @addrto, SizeOfVarSin(addrto));
end;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
var
x: integer;
begin
x := SizeOf(from);
Result := ssRecvFrom(s, Buf^, len, flags, @from, x);
end;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
var
x: integer;
begin
x := SizeOf(addr);
Result := ssAccept(s, @addr, x);
end;
{=============================================================================}
function InitSocketInterface(stack: string): Boolean;
begin
Result := False;
SockEnhancedApi := False;
if stack = '' then
stack := DLLStackName;
SynSockCS.Enter;
try
if SynSockCount = 0 then
begin
SockEnhancedApi := False;
SockWship6Api := False;
Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN));
LibHandle := LoadLibrary(PChar(Stack));
if LibHandle <> 0 then
begin
errno_loc := GetProcAddress(LibHandle, PChar('__errno_location'));
CloseSocket := GetProcAddress(LibHandle, PChar('close'));
IoctlSocket := GetProcAddress(LibHandle, PChar('ioctl'));
WSAGetLastError := LSWSAGetLastError;
WSAStartup := LSWSAStartup;
WSACleanup := LSWSACleanup;
ssAccept := GetProcAddress(LibHandle, PChar('accept'));
ssBind := GetProcAddress(LibHandle, PChar('bind'));
ssConnect := GetProcAddress(LibHandle, PChar('connect'));
ssGetPeerName := GetProcAddress(LibHandle, PChar('getpeername'));
ssGetSockName := GetProcAddress(LibHandle, PChar('getsockname'));
GetSockOpt := GetProcAddress(LibHandle, PChar('getsockopt'));
Htonl := GetProcAddress(LibHandle, PChar('htonl'));
Htons := GetProcAddress(LibHandle, PChar('htons'));
Inet_Addr := GetProcAddress(LibHandle, PChar('inet_addr'));
Inet_Ntoa := GetProcAddress(LibHandle, PChar('inet_ntoa'));
Listen := GetProcAddress(LibHandle, PChar('listen'));
Ntohl := GetProcAddress(LibHandle, PChar('ntohl'));
Ntohs := GetProcAddress(LibHandle, PChar('ntohs'));
ssRecv := GetProcAddress(LibHandle, PChar('recv'));
ssRecvFrom := GetProcAddress(LibHandle, PChar('recvfrom'));
Select := GetProcAddress(LibHandle, PChar('select'));
ssSend := GetProcAddress(LibHandle, PChar('send'));
ssSendTo := GetProcAddress(LibHandle, PChar('sendto'));
SetSockOpt := GetProcAddress(LibHandle, PChar('setsockopt'));
ShutDown := GetProcAddress(LibHandle, PChar('shutdown'));
Socket := GetProcAddress(LibHandle, PChar('socket'));
GetHostByAddr := GetProcAddress(LibHandle, PChar('gethostbyaddr'));
GetHostByName := GetProcAddress(LibHandle, PChar('gethostbyname'));
GetProtoByName := GetProcAddress(LibHandle, PChar('getprotobyname'));
GetProtoByNumber := GetProcAddress(LibHandle, PChar('getprotobynumber'));
GetServByName := GetProcAddress(LibHandle, PChar('getservbyname'));
GetServByPort := GetProcAddress(LibHandle, PChar('getservbyport'));
ssGetHostName := GetProcAddress(LibHandle, PChar('gethostname'));
{$IFNDEF FORCEOLDAPI}
GetAddrInfo := GetProcAddress(LibHandle, PChar('getaddrinfo'));
FreeAddrInfo := GetProcAddress(LibHandle, PChar('freeaddrinfo'));
GetNameInfo := GetProcAddress(LibHandle, PChar('getnameinfo'));
SockEnhancedApi := Assigned(GetAddrInfo) and Assigned(FreeAddrInfo)
and Assigned(GetNameInfo);
{$ENDIF}
Result := True;
end;
end
else Result := True;
if Result then
Inc(SynSockCount);
finally
SynSockCS.Leave;
end;
end;
function DestroySocketInterface: Boolean;
begin
SynSockCS.Enter;
try
Dec(SynSockCount);
if SynSockCount < 0 then
SynSockCount := 0;
if SynSockCount = 0 then
begin
if LibHandle <> 0 then
begin
FreeLibrary(libHandle);
LibHandle := 0;
end;
if LibWship6Handle <> 0 then
begin
FreeLibrary(LibWship6Handle);
LibWship6Handle := 0;
end;
end;
finally
SynSockCS.Leave;
end;
Result := True;
end;
initialization
begin
SynSockCS := SyncObjs.TCriticalSection.Create;
SET_IN6_IF_ADDR_ANY (@in6addr_any);
SET_LOOPBACK_ADDR6 (@in6addr_loopback);
end;
finalization
begin
SynSockCS.Free;
end;
{$ENDIF}

1234
sswin32.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1367
synachar.pas
View File

File diff suppressed because it is too large Load Diff

723
synacode.pas
View File

File diff suppressed because it is too large Load Diff

2
synafpc.pas
View File

@ -42,6 +42,8 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}

351
synaicnv.pas Normal file
View File

@ -0,0 +1,351 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.000 |
|==============================================================================|
| Content: ICONV support for Win32, Linux and .NET |
|==============================================================================|
| Copyright (c)2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2004. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{:@exclude}
unit synaicnv;
interface
uses
{$IFDEF CIL}
System.Runtime.InteropServices,
System.Text,
{$ENDIF}
{$IFDEF LINUX}
{$IFDEF FPC}
synafpc,
{$ENDIF}
Libc, SysUtils;
{$ELSE}
Windows;
{$ENDIF}
const
{$IFDEF LINUX}
DLLIconvName = 'libiconv.so';
{$ELSE}
DLLIconvName = 'iconv.dll';
{$ENDIF}
type
size_t = Cardinal;
{$IFDEF CIL}
iconv_t = IntPtr;
{$ELSE}
iconv_t = Pointer;
{$ENDIF}
argptr = iconv_t;
var
iconvLibHandle: Integer = 0;
function SynaIconvOpen(const tocode, fromcode: string): iconv_t;
function SynaIconvOpenTranslit(const tocode, fromcode: string): iconv_t;
function SynaIconvOpenIgnore(const tocode, fromcode: string): iconv_t;
function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
function SynaIconvClose(var cd: iconv_t): integer;
function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer;
function IsIconvloaded: Boolean;
function InitIconvInterface: Boolean;
function DestroyIconvInterface: Boolean;
const
ICONV_TRIVIALP = 0; // int *argument
ICONV_GET_TRANSLITERATE = 1; // int *argument
ICONV_SET_TRANSLITERATE = 2; // const int *argument
ICONV_GET_DISCARD_ILSEQ = 3; // int *argument
ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument
implementation
uses SyncObjs;
{$IFDEF CIL}
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconv_open')]
function _iconv_open(tocode: string; fromcode: string): iconv_t; external;
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconv')]
function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t;
var outbuf: IntPtr; var outbytesleft: size_t): size_t; external;
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconv_close')]
function _iconv_close(cd: iconv_t): integer; external;
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconvctl')]
function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external;
{$ELSE}
type
Ticonv_open = function(tocode: pchar; fromcode: pchar): iconv_t; cdecl;
Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t;
var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl;
Ticonv_close = function(cd: iconv_t): integer; cdecl;
Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl;
var
_iconv_open: Ticonv_open = nil;
_iconv: Ticonv = nil;
_iconv_close: Ticonv_close = nil;
_iconvctl: Ticonvctl = nil;
{$ENDIF}
var
IconvCS: TCriticalSection;
Iconvloaded: boolean = false;
function SynaIconvOpen (const tocode, fromcode: string): iconv_t;
begin
{$IFDEF CIL}
try
Result := _iconv_open(tocode, fromcode);
except
on Exception do
Result := iconv_t(-1);
end;
{$ELSE}
if InitIconvInterface and Assigned(_iconv_open) then
Result := _iconv_open(PChar(tocode), PChar(fromcode))
else
Result := iconv_t(-1);
{$ENDIF}
end;
function SynaIconvOpenTranslit (const tocode, fromcode: string): iconv_t;
begin
Result := SynaIconvOpen(tocode + '//TRANSLIT', fromcode);
end;
function SynaIconvOpenIgnore (const tocode, fromcode: string): iconv_t;
begin
Result := SynaIconvOpen(tocode + '//IGNORE', fromcode);
end;
function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
var
{$IFDEF CIL}
ib, ob: IntPtr;
ibsave, obsave: IntPtr;
l: integer;
{$ELSE}
ib, ob: Pointer;
{$ENDIF}
ix, ox: size_t;
begin
{$IFDEF CIL}
l := Length(inbuf) * 4;
ibsave := IntPtr.Zero;
obsave := IntPtr.Zero;
try
ibsave := Marshal.StringToHGlobalAnsi(inbuf);
obsave := Marshal.AllocHGlobal(l);
ib := ibsave;
ob := obsave;
ix := Length(inbuf);
ox := l;
_iconv(cd, ib, ix, ob, ox);
Outbuf := Marshal.PtrToStringAnsi(obsave, l);
setlength(Outbuf, l - ox);
Result := Length(inbuf) - ix;
finally
Marshal.FreeCoTaskMem(ibsave);
Marshal.FreeHGlobal(obsave);
end;
{$ELSE}
if InitIconvInterface and Assigned(_iconv) then
begin
setlength(Outbuf, Length(inbuf) * 4);
ib := Pointer(inbuf);
ob := Pointer(Outbuf);
ix := Length(inbuf);
ox := Length(Outbuf);
_iconv(cd, ib, ix, ob, ox);
setlength(Outbuf, Length(Outbuf) - ox);
Result := Length(inbuf) - ix;
end
else
begin
Outbuf := '';
Result := 0;
end;
{$ENDIF}
end;
function SynaIconvClose(var cd: iconv_t): integer;
begin
if cd = iconv_t(-1) then
begin
Result := 0;
Exit;
end;
{$IFDEF CIL}
try;
Result := _iconv_close(cd)
except
on Exception do
Result := -1;
end;
cd := iconv_t(-1);
{$ELSE}
if InitIconvInterface and Assigned(_iconv_close) then
Result := _iconv_close(cd)
else
Result := -1;
cd := iconv_t(-1);
{$ENDIF}
end;
function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer;
begin
{$IFDEF CIL}
Result := _iconvctl(cd, request, argument)
{$ELSE}
if InitIconvInterface and Assigned(_iconvctl) then
Result := _iconvctl(cd, request, argument)
else
Result := 0;
{$ENDIF}
end;
function InitIconvInterface: Boolean;
begin
IconvCS.Enter;
try
if not IsIconvloaded then
begin
{$IFDEF CIL}
IconvLibHandle := 1;
{$ELSE}
IconvLibHandle := LoadLibrary(PChar(DLLIconvName));
{$ENDIF}
if (IconvLibHandle <> 0) then
begin
{$IFNDEF CIL}
_iconv_open := GetProcAddress(IconvLibHandle, Pchar('libiconv_open'));
_iconv := GetProcAddress(IconvLibHandle, Pchar('libiconv'));
_iconv_close := GetProcAddress(IconvLibHandle, Pchar('libiconv_close'));
_iconvctl := GetProcAddress(IconvLibHandle, Pchar('libiconvctl'));
{$ENDIF}
Result := True;
Iconvloaded := True;
end
else
begin
//load failed!
if IconvLibHandle <> 0 then
begin
{$IFNDEF CIL}
FreeLibrary(IconvLibHandle);
{$ENDIF}
IconvLibHandle := 0;
end;
Result := False;
end;
end
else
//loaded before...
Result := true;
finally
IconvCS.Leave;
end;
end;
function DestroyIconvInterface: Boolean;
begin
IconvCS.Enter;
try
Iconvloaded := false;
if IconvLibHandle <> 0 then
begin
{$IFNDEF CIL}
FreeLibrary(IconvLibHandle);
{$ENDIF}
IconvLibHandle := 0;
end;
{$IFNDEF CIL}
_iconv_open := nil;
_iconv := nil;
_iconv_close := nil;
_iconvctl := nil;
{$ENDIF}
finally
IconvCS.Leave;
end;
Result := True;
end;
function IsIconvloaded: Boolean;
begin
Result := IconvLoaded;
end;
initialization
begin
IconvCS:= TCriticalSection.Create;
end;
finalization
begin
{$IFNDEF CIL}
DestroyIconvInterface;
{$ENDIF}
IconvCS.Free;
end;
end.

111
synamisc.pas
View File

@ -1,5 +1,5 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.002 |
| Project : Ararat Synapse | 001.001.003 |
|==============================================================================|
| Content: misc. procedures and functions |
|==============================================================================|
@ -42,6 +42,8 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Misc. network based utilities)}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
@ -67,21 +69,33 @@ uses
{$ELSE}
{$IFDEF FPC}
winver,
{$ELSE}
Wininet,
{$ENDIF}
Windows;
{$ENDIF}
Type
{:@abstract(This record contains information about proxy setting.)}
TProxySetting = record
Host: string;
Port: string;
Bypass: string;
end;
{:By this function you can turn-on computer on network, if this computer
supporting Wake-on-lan feature. You need MAC number (network card indentifier)
of computer for turn-on. You can also assign target IP addres. If you not
specify it, then is used broadcast for delivery magic wake-on packet. However
broadcasts workinh only on your local network. When you need to wake-up
computer on another network, you must specify any existing IP addres on same
network segment as targeting computer.}
procedure WakeOnLan(MAC, IP: string);
{:Autodetect current DNS servers used by system. If is defined more then one DNS
server, then result is comma-delimited.}
function GetDNS: string;
{:Autodetect InternetExplorer proxy setting for given protocol. This function
working only on windows!}
function GetIEProxy(protocol: string): TProxySetting;
implementation
@ -267,14 +281,19 @@ begin
Result.Bypass := '';
end;
{$ELSE}
{$IFDEF FPC}
begin
Result.Host := '';
Result.Port := '';
Result.Bypass := '';
end;
{$ELSE}
type
PInternetProxyInfo = ^TInternetProxyInfo;
TInternetProxyInfo = packed record
dwAccessType: DWORD;
lpszProxy: LPCSTR;
lpszProxyBypass: LPCSTR;
end;
const
INTERNET_OPTION_PROXY = 38;
INTERNET_OPEN_TYPE_PROXY = 3;
WininetDLL = 'WININET.DLL';
var
WininetModule: THandle;
ProxyInfo: PInternetProxyInfo;
Err: Boolean;
Len: DWORD;
@ -282,49 +301,61 @@ var
DefProxy: string;
ProxyList: TStringList;
n: integer;
InternetQueryOption: function (hInet: Pointer; dwOption: DWORD;
lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall;
begin
Result.Host := '';
Result.Port := '';
Result.Bypass := '';
if protocol = '' then
protocol := 'http';
Len := 4096;
GetMem(ProxyInfo, Len);
ProxyList := TStringList.Create;
WininetModule := LoadLibrary(WininetDLL);
if WininetModule = 0 then
exit;
try
Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
if Err then
if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
begin
ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
Proxy := '';
DefProxy := '';
for n := 0 to ProxyList.Count -1 do
InternetQueryOption := GetProcAddress(WininetModule,'InternetQueryOptionA');
if @InternetQueryOption = nil then
Exit;
if protocol = '' then
protocol := 'http';
Len := 4096;
GetMem(ProxyInfo, Len);
ProxyList := TStringList.Create;
try
Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
if Err then
if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
begin
if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then
ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
Proxy := '';
DefProxy := '';
for n := 0 to ProxyList.Count -1 do
begin
Proxy := SeparateRight(ProxyList[n], '=');
break;
if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then
begin
Proxy := SeparateRight(ProxyList[n], '=');
break;
end;
if Pos('=', ProxyList[n]) < 1 then
DefProxy := ProxyList[n];
end;
if Pos('=', ProxyList[n]) < 1 then
DefProxy := ProxyList[n];
if Proxy = '' then
Proxy := DefProxy;
if Proxy <> '' then
begin
Result.Host := Trim(SeparateLeft(Proxy, ':'));
Result.Port := Trim(SeparateRight(Proxy, ':'));
end;
Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
end;
if Proxy = '' then
Proxy := DefProxy;
if Proxy <> '' then
begin
Result.Host := SeparateLeft(Proxy, ':');
Result.Port := SeparateRight(Proxy, ':');
end;
Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
end;
finally
ProxyList.Free;
FreeMem(ProxyInfo);
end;
finally
ProxyList.Free;
FreeMem(ProxyInfo);
FreeLibrary(WininetModule);
end;
end;
{$ENDIF}
{$ENDIF}
{==============================================================================}

702
synassl.pas
View File

File diff suppressed because it is too large Load Diff

554
synautil.pas
View File

@ -1,9 +1,9 @@
{==============================================================================|
| Project : Ararat Synapse | 004.000.002 |
| Project : Ararat Synapse | 004.006.004 |
|==============================================================================|
| Content: support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| Copyright (c)1999-2004, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
@ -33,7 +33,7 @@
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003. |
| Portions created by Lukas Gebauer are Copyright (c) 1999-2004. |
| Portions created by Hernan Sanchez are Copyright (c) 2000. |
| All Rights Reserved. |
|==============================================================================|
@ -44,6 +44,8 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Support procedures and functions)}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
@ -56,73 +58,275 @@ unit synautil;
interface
uses
SysUtils, Classes,
{$IFDEF LINUX}
Libc;
Libc,
{$ELSE}
Windows;
Windows,
{$ENDIF}
SysUtils, Classes;
{:Return your timezone bias from UTC time in minutes.}
function TimeZoneBias: integer;
{:Return your timezone bias from UTC time in string representation like "+0200".}
function TimeZone: string;
{:Returns current time in format defined in RFC-822. Useful for SMTP messages,
but other protocols use this time format as well. Results contains the timezone
specification. Four digit year is used to break any Y2K concerns. (Example
'Fri, 15 Oct 1999 21:14:56 +0200')}
function Rfc822DateTime(t: TDateTime): string;
{:Returns date and time in format defined in C compilers in format "mmm dd hh:nn:ss"}
function CDateTime(t: TDateTime): string;
{:Returns date and time in format defined in format 'yymmdd hhnnss'}
function SimpleDateTime(t: TDateTime): string;
{:Returns date and time in format defined in ANSI C compilers in format
"ddd mmm d hh:nn:ss yyyy" }
function AnsiCDateTime(t: TDateTime): string;
function GetMonthNumber(Value: string): integer;
{:Decode three-letter string with name of month to their month number. If string
not match any month name, then is returned 0. For parsing are used predefined
names for English, French and German and names from system locale too.}
function GetMonthNumber(Value: AnsiString): integer;
{:Return decoded time from given string. Time must be witch separator ':'. You
can use "hh:mm" or "hh:mm:ss".}
function GetTimeFromStr(Value: string): TDateTime;
{:Decode string in format "m-d-y" to TDateTime type.}
function GetDateMDYFromStr(Value: string): TDateTime;
{:Decode various string representations of date and time to Tdatetime type.
This function do all timezone corrections too! This function can decode lot of
formats like:
@longcode(#
ddd, d mmm yyyy hh:mm:ss
ddd, d mmm yy hh:mm:ss
ddd, mmm d yyyy hh:mm:ss
ddd mmm dd hh:mm:ss yyyy #)
and more with lot of modifications, include:
@longcode(#
Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123
Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036
Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() Format
#)
Timezone corrections known lot of symbolic timezone names (like CEST, EDT, etc.)
or numeric representation (like +0200). By convention defined in RFC timezone
+0000 is GMT and -0000 is current your system timezone.}
function DecodeRfcDateTime(Value: string): TDateTime;
{:Return current system date and time in UTC timezone.}
function GetUTTime: TDateTime;
{:Set Newdt as current system date and time in UTC timezone. This function work
only if you have administrator rights!}
function SetUTTime(Newdt: TDateTime): Boolean;
{:Return current value of system timer with precizion 1 millisecond. Good for
measure time difference.}
function GetTick: ULong;
{:Return difference between two timestamps. It working fine only for differences
smaller then maxint. (difference must be smaller then 24 days.)}
function TickDelta(TickOld, TickNew: ULong): ULong;
function CodeInt(Value: Word): string;
function DecodeInt(const Value: string; Index: Integer): Word;
{:Return two characters, which ordinal values represents the value in byte
format. (High-endian)}
function CodeInt(Value: Word): Ansistring;
{:Decodes two characters located at "Index" offset position of the "Value"
string to Word values.}
function DecodeInt(const Value: Ansistring; Index: Integer): Word;
{:Return four characters, which ordinal values represents the value in byte
format. (High-endian)}
function CodeLongInt(Value: LongInt): Ansistring;
{:Decodes four characters located at "Index" offset position of the "Value"
string to LongInt values.}
function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt;
{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
function IsIP(const Value: string): Boolean;
{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
function IsIP6(const Value: string): Boolean;
{:Returns a string with the "Host" ip address converted to binary form.}
function IPToID(Host: string): string;
function DumpStr(const Buffer: string): string;
function DumpExStr(const Buffer: string): string;
procedure Dump(const Buffer, DumpFile: string);
procedure DumpEx(const Buffer, DumpFile: string);
{:Dump binary buffer stored in a string to a result string.}
function DumpStr(const Buffer: Ansistring): string;
{:Dump binary buffer stored in a string to a result string. All bytes with code
of character is written as character, not as hexadecimal value.}
function DumpExStr(const Buffer: Ansistring): string;
{:Dump binary buffer stored in a string to a file with DumpFile filename.}
procedure Dump(const Buffer: AnsiString; DumpFile: string);
{:Dump binary buffer stored in a string to a file with DumpFile filename. All
bytes with code of character is written as character, not as hexadecimal value.}
procedure DumpEx(const Buffer: AnsiString; DumpFile: string);
{:Like TrimLeft, but remove only spaces, not control characters!}
function TrimSPLeft(const S: string): string;
{:Like TrimRight, but remove only spaces, not control characters!}
function TrimSPRight(const S: string): string;
{:Like Trim, but remove only spaces, not control characters!}
function TrimSP(const S: string): string;
{:Returns a portion of the "Value" string located to the left of the "Delimiter"
string. If a delimiter is not found, results is original string.}
function SeparateLeft(const Value, Delimiter: string): string;
{:Returns the portion of the "Value" string located to the right of the
"Delimiter" string. If a delimiter is not found, results is original string.}
function SeparateRight(const Value, Delimiter: string): string;
{:Returns parameter value from string in format:
parameter1="value1"; parameter2=value2}
function GetParameter(const Value, Parameter: string): string;
{:parse value string with elements differed by Delimiter into stringlist.}
procedure ParseParametersEx(Value, Delimiter: string; const Parameters: TStrings);
{:parse value string with elements differed by ';' into stringlist.}
procedure ParseParameters(Value: string; const Parameters: TStrings);
{:Index of string in stringlist with same beginning as Value is returned.}
function IndexByBegin(Value: string; const List: TStrings): integer;
{:Returns only the e-mail portion of an address from the full address format.
i.e. returns 'nobody@@somewhere.com' from '"someone" <nobody@@somewhere.com>'}
function GetEmailAddr(const Value: string): string;
{:Returns only the description part from a full address format. i.e. returns
'someone' from '"someone" <nobody@@somewhere.com>'}
function GetEmailDesc(Value: string): string;
function StrToHex(const Value: string): string;
{:Returns a string with hexadecimal digits representing the corresponding values
of the bytes found in "Value" string.}
function StrToHex(const Value: Ansistring): string;
{:Returns a string of binary "Digits" representing "Value".}
function IntToBin(Value: Integer; Digits: Byte): string;
{:Returns an integer equivalent of the binary string in "Value".
(i.e. ('10001010') returns 138)}
function BinToInt(const Value: string): Integer;
{:Parses a URL to its various components.}
function ParseURL(URL: string; var Prot, User, Pass, Host, Port, Path,
Para: string): string;
{:Replaces all "Search" string values found within "Value" string, with the
"Replace" string value.}
function ReplaceString(Value, Search, Replace: string): string;
{:It is like RPos, but search is from specified possition.}
function RPosEx(const Sub, Value: string; From: integer): Integer;
{:It is like POS function, but from right side of Value string.}
function RPos(const Sub, Value: String): Integer;
{:Like @link(fetch), but working with binary strings, not with text.}
function FetchBin(var Value: string; const Delimiter: string): string;
{:Fetch string from left of Value string.}
function Fetch(var Value: string; const Delimiter: string): string;
{:Fetch string from left of Value string. This function ignore delimitesr inside
quotations.}
function FetchEx(var Value: string; const Delimiter, Quotation: string): string;
{:If string is binary string (contains non-printable characters), then is
returned true.}
function IsBinaryString(const Value: string): Boolean;
function PosCRLF(const Value: string; var Terminator: string): integer;
{:return position of string terminator in string. If terminator found, then is
returned in terminator parameter.
Possible line terminators are: CRLF, LFCR, CR, LF}
function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer;
{:Delete empty strings from end of stringlist.}
Procedure StringsTrim(const value: TStrings);
{:Like Pos function, buf from given string possition.}
function PosFrom(const SubStr, Value: String; From: integer): integer;
{$IFNDEF CIL}
{:Increase pointer by value.}
function IncPoint(const p: pointer; Value: integer): pointer;
{$ENDIF}
{:Get string between PairBegin and PairEnd. This function respect nesting.
For example:
@longcode(#
Value is: 'Hi! (hello(yes!))'
pairbegin is: '('
pairend is: ')'
In this case result is: 'hello(yes!)'#)}
function GetBetween(const PairBegin, PairEnd, Value: string): string;
{:Return count of Chr in Value string.}
function CountOfChar(const Value: string; Chr: char): integer;
function UnquoteStr(const Value: string; Quote: Char): string;
{:Remove quotation from Value string. If Value is not quoted, then return same
string without any modification. }
function UnquoteStr(Value: string; Quote: Char): string;
{:Convert lines in stringlist from 'name: value' form to 'name=value' form.}
procedure HeadersToList(const Value: TStrings);
{:Convert lines in stringlist from 'name=value' form to 'name: value' form.}
procedure ListToHeaders(const Value: TStrings);
{:swap bytes in integer.}
function SwapBytes(Value: integer): integer;
{:read string with requested length form stream.}
function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;
{:write string to stream.}
procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
var
{:can be used for your own months strings for @link(getmonthnumber)}
CustomMonthNames: array[1..12] of string;
implementation
{==============================================================================}
const
MyDayNames: array[1..7] of string =
MyDayNames: array[1..7] of AnsiString =
('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
MyMonthNames: array[1..12] of string =
('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
var
MyMonthNames: array[0..6, 1..12] of AnsiString =
(
('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //rewrited by system locales
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', //English
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'),
('jan', 'fév', 'mar', 'avr', 'mai', 'jun', //French
'jul', 'aoû', 'sep', 'oct', 'nov', 'déc'),
('jan', 'fev', 'mar', 'avr', 'mai', 'jun', //French#2
'jul', 'aou', 'sep', 'oct', 'nov', 'dec'),
('Jan', 'Feb', 'Mar', 'Apr', 'Mai', 'Jun', //German
'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
('Jan', 'Feb', 'Mär', 'Apr', 'Mai', 'Jun', //German#2
'Jul', 'Aug', 'Sep', 'Okt', 'Nov', 'Dez'),
('Led', 'Úno', 'Bøe', 'Dub', 'Kvì', 'Èen', //Czech
'Èec', 'Srp', 'Záø', 'Øíj', 'Lis', 'Pro')
);
{==============================================================================}
@ -183,7 +387,7 @@ var
begin
DecodeDate(t, wYear, wMonth, wDay);
Result := Format('%s, %d %s %s %s', [MyDayNames[DayOfWeek(t)], wDay,
MyMonthNames[wMonth], FormatDateTime('yyyy hh:nn:ss', t), TimeZone]);
MyMonthNames[1, wMonth], FormatDateTime('yyyy hh:nn:ss', t), TimeZone]);
end;
{==============================================================================}
@ -193,7 +397,7 @@ var
wYear, wMonth, wDay: word;
begin
DecodeDate(t, wYear, wMonth, wDay);
Result:= Format('%s %2d %s', [MyMonthNames[wMonth], wDay,
Result:= Format('%s %2d %s', [MyMonthNames[1, wMonth], wDay,
FormatDateTime('hh:nn:ss', t)]);
end;
@ -211,7 +415,7 @@ var
wYear, wMonth, wDay: word;
begin
DecodeDate(t, wYear, wMonth, wDay);
Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[wMonth],
Result := Format('%s %s %d %s', [MyDayNames[DayOfWeek(t)], MyMonthNames[1, wMonth],
wDay, FormatDateTime('hh:nn:ss yyyy ', t)]);
end;
@ -304,14 +508,26 @@ end;
{==============================================================================}
function GetMonthNumber(Value: string): integer;
function GetMonthNumber(Value: AnsiString): integer;
var
n: integer;
function TestMonth(Value: AnsiString; Index: Integer): Boolean;
var
n: integer;
begin
Result := False;
for n := 0 to 6 do
if Value = AnsiUppercase(MyMonthNames[n, Index]) then
begin
Result := True;
Break;
end;
end;
begin
Result := 0;
Value := Uppercase(Value);
Value := AnsiUppercase(Value);
for n := 1 to 12 do
if Value = uppercase(MyMonthNames[n]) then
if TestMonth(Value, n) or (Value = AnsiUppercase(CustomMonthNames[n])) then
begin
Result := n;
Break;
@ -328,7 +544,7 @@ begin
if (x > 0) and ((Length(Value) - x) > 2) then
Value := Copy(Value, 1, x + 2);
Value := ReplaceString(Value, ':', TimeSeparator);
Result := 0;
Result := -1;
try
Result := StrToTime(Value);
except
@ -423,7 +639,7 @@ begin
if rpos(':', s) > Pos(':', s) then
begin
t := GetTimeFromStr(s);
if t <> 0 then
if t <> -1 then
Result := t;
continue;
end;
@ -574,14 +790,17 @@ end;
{==============================================================================}
function CodeInt(Value: Word): string;
function CodeInt(Value: Word): Ansistring;
begin
Result := Chr(Hi(Value)) + Chr(Lo(Value))
setlength(result, 2);
result[1] := AnsiChar(Value div 256);
result[2] := AnsiChar(Value mod 256);
// Result := AnsiChar(Value div 256) + AnsiChar(Value mod 256)
end;
{==============================================================================}
function DecodeInt(const Value: string; Index: Integer): Word;
function DecodeInt(const Value: Ansistring; Index: Integer): Word;
var
x, y: Byte;
begin
@ -598,6 +817,48 @@ end;
{==============================================================================}
function CodeLongInt(Value: Longint): Ansistring;
var
x, y: word;
begin
// this is fix for negative numbers on systems where longint = integer
x := (Value shr 16) and integer($ffff);
y := Value and integer($ffff);
setlength(result, 4);
result[1] := AnsiChar(x div 256);
result[2] := AnsiChar(x mod 256);
result[3] := AnsiChar(y div 256);
result[4] := AnsiChar(y mod 256);
end;
{==============================================================================}
function DecodeLongInt(const Value: Ansistring; Index: Integer): LongInt;
var
x, y: Byte;
xl, yl: Byte;
begin
if Length(Value) > Index then
x := Ord(Value[Index])
else
x := 0;
if Length(Value) >= (Index + 1) then
y := Ord(Value[Index + 1])
else
y := 0;
if Length(Value) >= (Index + 2) then
xl := Ord(Value[Index + 2])
else
xl := 0;
if Length(Value) >= (Index + 3) then
yl := Ord(Value[Index + 3])
else
yl := 0;
Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
end;
{==============================================================================}
function IsIP(const Value: string): Boolean;
var
TempIP: string;
@ -686,10 +947,8 @@ begin
for x := 1 to 3 do
begin
t := '';
s := StrScan(PChar(Host), '.');
t := Copy(Host, 1, (Length(Host) - Length(s)));
Delete(Host, 1, (Length(Host) - Length(s) + 1));
i := StrToIntDef(t, 0);
s := Fetch(Host, '.');
i := StrToIntDef(s, 0);
Result := Result + Chr(i);
end;
i := StrToIntDef(Host, 0);
@ -698,7 +957,7 @@ end;
{==============================================================================}
function DumpStr(const Buffer: string): string;
function DumpStr(const Buffer: Ansistring): string;
var
n: Integer;
begin
@ -709,7 +968,7 @@ end;
{==============================================================================}
function DumpExStr(const Buffer: string): string;
function DumpExStr(const Buffer: Ansistring): string;
var
n: Integer;
x: Byte;
@ -727,13 +986,13 @@ end;
{==============================================================================}
procedure Dump(const Buffer, DumpFile: string);
procedure Dump(const Buffer: AnsiString; DumpFile: string);
var
f: Text;
begin
AssignFile(f, DumpFile);
if FileExists(DumpFile) then
DeleteFile(PChar(DumpFile));
DeleteFile(DumpFile);
Rewrite(f);
try
Writeln(f, DumpStr(Buffer));
@ -744,13 +1003,13 @@ end;
{==============================================================================}
procedure DumpEx(const Buffer, DumpFile: string);
procedure DumpEx(const Buffer: AnsiString; DumpFile: string);
var
f: Text;
begin
AssignFile(f, DumpFile);
if FileExists(DumpFile) then
DeleteFile(PChar(DumpFile));
DeleteFile(DumpFile);
Rewrite(f);
try
Writeln(f, DumpExStr(Buffer));
@ -761,15 +1020,48 @@ end;
{==============================================================================}
function TrimSPLeft(const S: string): string;
var
I, L: Integer;
begin
L := Length(S);
I := 1;
while (I <= L) and (S[I] = ' ') do
Inc(I);
Result := Copy(S, I, Maxint);
end;
{==============================================================================}
function TrimSPRight(const S: string): string;
var
I: Integer;
begin
I := Length(S);
while (I > 0) and (S[I] = ' ') do
Dec(I);
Result := Copy(S, 1, I);
end;
{==============================================================================}
function TrimSP(const S: string): string;
begin
Result := TrimSPLeft(s);
Result := TrimSPRight(Result);
end;
{==============================================================================}
function SeparateLeft(const Value, Delimiter: string): string;
var
x: Integer;
begin
x := Pos(Delimiter, Value);
if x < 1 then
Result := Trim(Value)
Result := Value
else
Result := Trim(Copy(Value, 1, x - 1));
Result := Copy(Value, 1, x - 1);
end;
{==============================================================================}
@ -781,29 +1073,33 @@ begin
x := Pos(Delimiter, Value);
if x > 0 then
x := x + Length(Delimiter) - 1;
Result := Trim(Copy(Value, x + 1, Length(Value) - x));
Result := Copy(Value, x + 1, Length(Value) - x);
end;
{==============================================================================}
function GetParameter(const Value, Parameter: string): string;
var
x: Integer;
s: string;
v: string;
begin
x := Pos(UpperCase(Parameter), UpperCase(Value));
Result := '';
if x > 0 then
v := Value;
while v <> '' do
begin
s := Copy(Value, x + Length(Parameter), Length(Value)
- (x + Length(Parameter)) + 1);
s := Trim(s);
if Length(s) > 1 then
s := Trim(FetchEx(v, ';', '"'));
if Pos(Uppercase(parameter), Uppercase(s)) = 1 then
begin
x := pos(';', s);
if x > 0 then
s := Copy(s, 1, x - 1);
Result := UnquoteStr(s, '"');
Delete(s, 1, Length(Parameter));
s := Trim(s);
if s = '' then
Break;
if s[1] = '=' then
begin
Result := Trim(SeparateRight(s, '='));
Result := UnquoteStr(Result, '"');
break;
end;
end;
end;
end;
@ -817,7 +1113,7 @@ begin
Parameters.Clear;
while Value <> '' do
begin
s := Fetch(Value, Delimiter);
s := Trim(FetchEx(Value, Delimiter, '"'));
Parameters.Add(s);
end;
end;
@ -887,7 +1183,7 @@ end;
{==============================================================================}
function StrToHex(const Value: string): string;
function StrToHex(const Value: Ansistring): string;
var
n: Integer;
begin
@ -1040,14 +1336,20 @@ begin
x := Pos(Search, Value);
while x > 0 do
begin
{$IFNDEF CIL}
l := Length(Result);
SetLength(Result, l + x - 1);
Move(Pointer(Value)^, Pointer(@Result[l + 1])^, x - 1);
// Result:=Result+Copy(Value,1,x-1);
{$ELSE}
Result:=Result+Copy(Value,1,x-1);
{$ENDIF}
{$IFNDEF CIL}
l := Length(Result);
SetLength(Result, l + lr);
Move(Pointer(Replace)^, Pointer(@Result[l + 1])^, lr);
// Result:=Result+Replace;
{$ELSE}
Result:=Result+Replace;
{$ENDIF}
Delete(Value, 1, x - 1 + ls);
x := Pos(Search, Value);
end;
@ -1082,7 +1384,7 @@ end;
{==============================================================================}
function Fetch(var Value: string; const Delimiter: string): string;
function FetchBin(var Value: string; const Delimiter: string): string;
var
s: string;
begin
@ -1091,8 +1393,16 @@ begin
if s = Value then
Value := ''
else
Value := Trim(s);
Result := Trim(Result);
Value := s;
end;
{==============================================================================}
function Fetch(var Value: string; const Delimiter: string): string;
begin
Result := FetchBin(Value, Delimiter);
Result := TrimSP(Result);
Value := TrimSP(Value);
end;
{==============================================================================}
@ -1126,7 +1436,7 @@ begin
Delete(Value, 1, 1);
end;
end;
Result := Trim(Result);
Result := Result;
end;
{==============================================================================}
@ -1146,7 +1456,7 @@ end;
{==============================================================================}
function PosCRLF(const Value: string; var Terminator: string): integer;
function PosCRLF(const Value: AnsiString; var Terminator: AnsiString): integer;
var
p1, p2, p3, p4: integer;
const
@ -1211,7 +1521,11 @@ begin
From := 1;
while (ls + from - 1) <= (lv) do
begin
{$IFNDEF CIL}
if CompareMem(@SubStr[1],@Value[from],ls) then
{$ELSE}
if SubStr = copy(Value, from, ls) then
{$ENDIF}
begin
result := from;
break;
@ -1223,10 +1537,12 @@ end;
{==============================================================================}
{$IFNDEF CIL}
function IncPoint(const p: pointer; Value: integer): pointer;
begin
Result := pointer(integer(p) + Value);
end;
{$ENDIF}
{==============================================================================}
@ -1267,16 +1583,124 @@ end;
{==============================================================================}
function UnquoteStr(const Value: string; Quote: Char): string;
function UnquoteStr(Value: string; Quote: Char): string;
{$IFNDEF CIL}
var
LText: PChar;
{$ENDIF}
begin
//workaround for bug in AnsiExtractQuotedStr
//...if string begin by Quote, but not ending by Quote, then it eat last char.
if length(Value) > 1 then
if (Value[1] = Quote) and (Value[Length(value)] <> Quote) then
Value := Value + Quote;
{$IFNDEF CIL}
LText := PChar(Value);
Result := AnsiExtractQuotedStr(LText, Quote);
{$ELSE}
Result := DequotedStr(Value, Quote);
{$ENDIF}
if Result = '' then
Result := Value;
end;
{==============================================================================}
procedure HeadersToList(const Value: TStrings);
var
n, x: integer;
s: string;
begin
for n := 0 to Value.Count -1 do
begin
s := Value[n];
x := Pos(':', s);
if x > 0 then
begin
s[x] := '=';
Value[n] := s;
end;
end;
end;
{==============================================================================}
procedure ListToHeaders(const Value: TStrings);
var
n, x: integer;
s: string;
begin
for n := 0 to Value.Count -1 do
begin
s := Value[n];
x := Pos('=', s);
if x > 0 then
begin
s[x] := ':';
Value[n] := s;
end;
end;
end;
{==============================================================================}
function SwapBytes(Value: integer): integer;
var
s: string;
x, y, xl, yl: Byte;
begin
s := CodeLongInt(Value);
x := Ord(s[4]);
y := Ord(s[3]);
xl := Ord(s[2]);
yl := Ord(s[1]);
Result := ((x * 256 + y) * 65536) + (xl * 256 + yl);
end;
{==============================================================================}
function ReadStrFromStream(const Stream: TStream; len: integer): AnsiString;
var
x: integer;
{$IFDEF CIL}
buf: Array of Byte;
{$ENDIF}
begin
{$IFDEF CIL}
Setlength(buf, Len);
x := Stream.read(buf, Len);
SetLength(buf, x);
Result := StringOf(Buf);
{$ELSE}
Setlength(Result, Len);
x := Stream.read(Pchar(Result)^, Len);
SetLength(Result, x);
{$ENDIF}
end;
{==============================================================================}
procedure WriteStrToStream(const Stream: TStream; Value: AnsiString);
{$IFDEF CIL}
var
buf: Array of Byte;
{$ENDIF}
begin
{$IFDEF CIL}
buf := BytesOf(Value);
Stream.Write(buf,length(Value));
{$ELSE}
Stream.Write(PChar(Value)^, Length(Value));
{$ENDIF}
end;
{==============================================================================}
var
n: integer;
begin
for n := 1 to 12 do
begin
CustomMonthNames[n] := ShortMonthNames[n];
MyMonthNames[0, n] := ShortMonthNames[n];
end;
end.

1421
synsock.pas
View File

File diff suppressed because it is too large Load Diff

29
tlntsend.pas
View File

@ -42,7 +42,10 @@
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//RFC-854
{:@abstract(Telnet script client)
Used RFC: RFC-854
}
{$IFDEF FPC}
{$MODE DELPHI}
@ -79,9 +82,14 @@ const
TLNT_IAC = #255;
type
{:@abstract(State of telnet protocol). Used internaly by TTelnetSend.}
TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
{:@abstract(Class with implementation of Telnet script client.)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TTelnetSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
@ -97,15 +105,34 @@ type
public
constructor Create;
destructor Destroy; override;
{:Connects to Telnet server.}
function Login: Boolean;
{:Logout from telnet server.}
procedure Logout;
{:Send this data to telnet server.}
procedure Send(const Value: string);
{:Reading data from telnet server until Value is readed. If it is not readed
until timeout, result is @false. Otherwise result is @true.}
function WaitFor(const Value: string): Boolean;
{:Read data terminated by terminator from telnet server.}
function RecvTerminated(const Terminator: string): string;
{:Read string from telnet server.}
function RecvString: string;
published
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{:all readed datas in this session (from connect) is stored in this large
string.}
property SessionLog: string read FSessionLog write FSessionLog;
{:Terminal type indentification. By default is 'SYNAPSE'.}
property TermType: string read FTermType write FTermType;
end;