moparisthebest
/
Simba
mirror of https://github.com/moparisthebest/Simba
1
0
Fork 0
Code Issues Releases Wiki Activity

Nothing's changed? First git commit =D

This commit is contained in:
unknown 2010-03-13 16:33:04 +01:00
parent 25fbd55694
commit 5f49c2129c
46 changed files with 39036 additions and 39036 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
Tests/PS/plugintest.txt
View File

@ -1,64 +1,64 @@
program new; program new;
{.LoadDLL libsmart} {.LoadDLL libsmart}
function IsKeyDown(C:Char): Boolean; function IsKeyDown(C:Char): Boolean;
begin begin
Result := SmartIsKeyDown(ord(c)); Result := SmartIsKeyDown(ord(c));
end; end;
procedure MoveMouse(x, y: Integer); procedure MoveMouse(x, y: Integer);
begin begin
SmartMoveMouse(x, y); SmartMoveMouse(x, y);
end; end;
procedure HoldMouse(x, y: Integer; left: Boolean); procedure HoldMouse(x, y: Integer; left: Boolean);
begin begin
SmartHoldMouse(x, y, left); SmartHoldMouse(x, y, left);
end; end;
procedure ReleaseMouse(x, y: Integer; left: Boolean); procedure ReleaseMouse(x, y: Integer; left: Boolean);
begin begin
SmartReleaseMouse(x, y, left); SmartReleaseMouse(x, y, left);
end; end;
procedure KeyUp(key: Byte); procedure KeyUp(key: Byte);
begin begin
If Key = 13 Then If Key = 13 Then
Key := 10; Key := 10;
SmartReleaseKey(key); SmartReleaseKey(key);
end; end;
procedure KeyDown(key: Byte); procedure KeyDown(key: Byte);
begin begin
If Key = 13 Then If Key = 13 Then
Key := 10; Key := 10;
SmartHoldKey(key); SmartHoldKey(key);
end; end;
procedure SendKeys(S: String); procedure SendKeys(S: String);
begin begin
SmartSendKeys(S); SmartSendKeys(S);
end; end;
procedure GetMousePos(var x, y: Integer); procedure GetMousePos(var x, y: Integer);
begin begin
SmartGetMousePos(x, y); SmartGetMousePos(x, y);
end; end;
function GetColor(x, y: Integer): Integer; function GetColor(x, y: Integer): Integer;
begin begin
result:= SmartGetColor(x, y); result:= SmartGetColor(x, y);
end; end;
var var
w,h:integer; w,h:integer;
begin begin
SmartSetup('http://world19.runescape.com/', 'plugin.js?param=o0,a1,m0', 765, 503); SmartSetup('http://world19.runescape.com/', 'plugin.js?param=o0,a1,m0', 765, 503);
SetTargetArray(SmartImageArray, 765,503); SetTargetArray(SmartImageArray, 765,503);
getclientdimensions(w,h); getclientdimensions(w,h);
writeln(inttostr(w) + ' , ' + inttostr(h)); writeln(inttostr(w) + ' , ' + inttostr(h));
if findcolortolerance(w,h,clwhite,0,0,764,502,300) then if findcolortolerance(w,h,clwhite,0,0,764,502,300) then
smartmovemouse(w,h); smartmovemouse(w,h);
savescreenshot('/tmp/smart.bmp'); savescreenshot('/tmp/smart.bmp');
//Wait(5000); //Wait(5000);
end. end.

132
Units/MMLAddon/PSInc/Wrappers/tpa.inc
View File

@ -1,66 +1,66 @@
procedure SplitTPAExWrap(arr: TPointArray; w, h: Integer; out res : T2DPointArray); procedure SplitTPAExWrap(arr: TPointArray; w, h: Integer; out res : T2DPointArray);
begin begin
res := SplitTPAEx(arr,w,h); res := SplitTPAEx(arr,w,h);
end; end;
procedure SplitTPAWrap(arr: TPointArray; Dist: Integer; out res: T2DPointArray); procedure SplitTPAWrap(arr: TPointArray; Dist: Integer; out res: T2DPointArray);
begin begin
res := SplitTPA(arr,dist); res := SplitTPA(arr,dist);
end; end;
procedure FindGapsTPAWrap(TPA: TPointArray; MinPixels: Integer; out Res : T2DPointArray); extdecl; procedure FindGapsTPAWrap(TPA: TPointArray; MinPixels: Integer; out Res : T2DPointArray); extdecl;
begin begin
Res := FindGapsTPA(TPA,MinPixels); Res := FindGapsTPA(TPA,MinPixels);
end; end;
procedure RemoveDistTPointArrayWrap(x, y, dist: Integer; ThePoints: TPointArray; RemoveHigher: Boolean; out Res : TPointArray);extdecl; procedure RemoveDistTPointArrayWrap(x, y, dist: Integer; ThePoints: TPointArray; RemoveHigher: Boolean; out Res : TPointArray);extdecl;
begin begin
Res := RemoveDistTPointArray(x,y,dist,thepoints,removehigher); Res := RemoveDistTPointArray(x,y,dist,thepoints,removehigher);
end; end;
procedure CombineTPAWrap(Ar1, Ar2: TPointArray; out Res : TPointArray);extdecl; procedure CombineTPAWrap(Ar1, Ar2: TPointArray; out Res : TPointArray);extdecl;
begin begin
Res := CombineTPA(Ar1,Ar2); Res := CombineTPA(Ar1,Ar2);
end; end;
procedure ReArrangeandShortenArrayExWrap(a: TPointArray; w, h: Integer; out Res : TPointArray);extdecl; procedure ReArrangeandShortenArrayExWrap(a: TPointArray; w, h: Integer; out Res : TPointArray);extdecl;
begin begin
Res := ReArrangeandShortenArrayEx(a,w,h); Res := ReArrangeandShortenArrayEx(a,w,h);
end; end;
procedure ReArrangeandShortenArrayWrap(a: TPointArray; Dist: Integer; out Res : TPointArray);extdecl; procedure ReArrangeandShortenArrayWrap(a: TPointArray; Dist: Integer; out Res : TPointArray);extdecl;
begin begin
Res := ReArrangeandShortenArray(a,dist); Res := ReArrangeandShortenArray(a,dist);
end; end;
procedure TPAtoATPAExWrap(TPA: TPointArray; w, h: Integer; out Res : T2DPointArray);extdecl; procedure TPAtoATPAExWrap(TPA: TPointArray; w, h: Integer; out Res : T2DPointArray);extdecl;
begin begin
Res := TPAtoATPAEx(TPA,w,h); Res := TPAtoATPAEx(TPA,w,h);
end; end;
procedure TPAtoATPAWrap(TPA: TPointArray; Dist: Integer; out Res : T2DPointArray);extdecl; procedure TPAtoATPAWrap(TPA: TPointArray; Dist: Integer; out Res : T2DPointArray);extdecl;
begin begin
Res := TPAtoATPA(TPA,Dist); Res := TPAtoATPA(TPA,Dist);
end; end;
procedure CombineIntArrayWrap(Ar1, Ar2: TIntegerArray; out Res : TIntegerArray);extdecl; procedure CombineIntArrayWrap(Ar1, Ar2: TIntegerArray; out Res : TIntegerArray);extdecl;
begin begin
Res := CombineIntArray(Ar1,Ar2); Res := CombineIntArray(Ar1,Ar2);
end; end;
procedure MergeATPAWrap(ATPA : T2DPointArray; out Res: TPointArray); extdecl; procedure MergeATPAWrap(ATPA : T2DPointArray; out Res: TPointArray); extdecl;
begin begin
Res := MergeATPA(ATPA); Res := MergeATPA(ATPA);
end; end;
procedure TPAFromBoxWrap(const Box : TBox; out Res : TPointArray);extdecl; procedure TPAFromBoxWrap(const Box : TBox; out Res : TPointArray);extdecl;
begin begin
Res := TPAFromBox(Box); Res := TPAFromBox(Box);
end; end;
procedure RotatePointsWrap(Const P: TPointArray; A, cx, cy: Extended; out Res : TPointArray);extdecl; procedure RotatePointsWrap(Const P: TPointArray; A, cx, cy: Extended; out Res : TPointArray);extdecl;
begin begin
Res := RotatePoints(P,a,cx,cy); Res := RotatePoints(P,a,cx,cy);
end; end;
procedure FindTPAEdgesWrap(p: TPointArray; out Res : TPointArray);extdecl; procedure FindTPAEdgesWrap(p: TPointArray; out Res : TPointArray);extdecl;
begin begin
Res := FindTPAEdges(p); Res := FindTPAEdges(p);
end; end;
procedure ClearTPAFromTPAWrap(arP, ClearPoints: TPointArray; out Res : TPointArray);extdecl; procedure ClearTPAFromTPAWrap(arP, ClearPoints: TPointArray; out Res : TPointArray);extdecl;
begin begin
Res := ClearTPAFromTPA(arP, clearpoints); Res := ClearTPAFromTPA(arP, clearpoints);
end; end;
procedure ReturnPointsNotInTPAWrap(Const TotalTPA: TPointArray; const Box: TBox; out Res : TPointArray);extdecl; procedure ReturnPointsNotInTPAWrap(Const TotalTPA: TPointArray; const Box: TBox; out Res : TPointArray);extdecl;
begin begin
Res := ReturnPointsNotInTPA(TotalTPA,box); Res := ReturnPointsNotInTPA(TotalTPA,box);
end; end;

228
Units/MMLAddon/stringutil.pas
View File

@ -1,114 +1,114 @@
unit stringutil; unit stringutil;
{$mode objfpc} {$mode objfpc}
interface interface
uses uses
Classes, SysUtils,mufasatypes; Classes, SysUtils,mufasatypes;
type type
StrExtr =(Numbers, Letters, Others); StrExtr =(Numbers, Letters, Others);
function ExtractFromStr( Str : string; Extract : StrExtr) : string; function ExtractFromStr( Str : string; Extract : StrExtr) : string;
function Capitalize(str : string) : string; function Capitalize(str : string) : string;
function Implode(Glue : string; Pieces: TStringArray): string; function Implode(Glue : string; Pieces: TStringArray): string;
function Explode(del, str: string): TStringArray; function Explode(del, str: string): TStringArray;
implementation implementation
function Implode(Glue: string;Pieces: TStringArray): string; function Implode(Glue: string;Pieces: TStringArray): string;
var var
I, Len : integer; I, Len : integer;
begin begin
Len := high(Pieces); Len := high(Pieces);
if (Len < 0) then if (Len < 0) then
exit; exit;
Result := Pieces[0]; Result := Pieces[0];
for i := 1 to len do for i := 1 to len do
result := result + Glue + Pieces[i]; result := result + Glue + Pieces[i];
end; end;
function Explode(del, str: string): TStringArray; function Explode(del, str: string): TStringArray;
var var
i,ii : integer; i,ii : integer;
lastpos : integer; lastpos : integer;
lenstr : integer; lenstr : integer;
lendel : integer; lendel : integer;
lenres : integer; lenres : integer;
matches : boolean; matches : boolean;
begin; begin;
lastpos := 1; lastpos := 1;
lenres := 0; lenres := 0;
setlength(result,lenres); setlength(result,lenres);
lendel := length(del); lendel := length(del);
lenstr := length(str); lenstr := length(str);
// for i := 1 to lenstr do // for i := 1 to lenstr do
i := 1; i := 1;
while i <= lenstr do while i <= lenstr do
begin; begin;
if not ((i + lendel - 1) > lenstr) then if not ((i + lendel - 1) > lenstr) then
begin begin
matches := true; matches := true;
for ii := 1 to lendel do for ii := 1 to lendel do
if str[i + ii - 1] <> del[ii] then if str[i + ii - 1] <> del[ii] then
begin begin
matches := false; matches := false;
break; break;
end; end;
if matches then if matches then
begin; begin;
inc(lenres); inc(lenres);
setlength(result,lenres); setlength(result,lenres);
result[lenres-1] := Copy(str,lastpos,i-lastpos); result[lenres-1] := Copy(str,lastpos,i-lastpos);
lastpos := i+lendel; lastpos := i+lendel;
i := i + lendel-1;//Dirty i := i + lendel-1;//Dirty
if i = lenstr then //This was the trailing delimiter if i = lenstr then //This was the trailing delimiter
exit; exit;
end; end;
end else //We cannot possibly find a delimiter anymore, thus copy the rest of the string and exit end else //We cannot possibly find a delimiter anymore, thus copy the rest of the string and exit
Break; Break;
inc(i); inc(i);
end; end;
//Copy the rest of the string (if it's not a delimiter) //Copy the rest of the string (if it's not a delimiter)
inc(lenres); inc(lenres);
setlength(result,lenres); setlength(result,lenres);
result[lenres-1] := Copy(str,lastpos,lenstr - lastpos + 1); result[lenres-1] := Copy(str,lastpos,lenstr - lastpos + 1);
end; end;
function Capitalize(str : string) : string; function Capitalize(str : string) : string;
var var
i , l : integer; i , l : integer;
cap : boolean; cap : boolean;
Range : set of char; Range : set of char;
begin; begin;
result := str; result := str;
l := length(str); l := length(str);
cap := true; cap := true;
Range := ['a'..'z','A'..'Z']; Range := ['a'..'z','A'..'Z'];
for i := 1 to l do for i := 1 to l do
if cap and (str[i] in Range) then if cap and (str[i] in Range) then
begin; begin;
result[i] := UpperCase(str[i])[1]; result[i] := UpperCase(str[i])[1];
cap := false; cap := false;
end else if not (str[i] in Range) then end else if not (str[i] in Range) then
cap := true; cap := true;
end; end;
function ExtractFromStr( Str : string; Extract : StrExtr) : string; function ExtractFromStr( Str : string; Extract : StrExtr) : string;
var var
Range : set of char; Range : set of char;
i : integer; i : integer;
begin; begin;
case Extract of case Extract of
Numbers : Range := ['0'..'9']; Numbers : Range := ['0'..'9'];
Letters : Range := ['A'..'Z','a'..'z']; Letters : Range := ['A'..'Z','a'..'z'];
Others : Range := [#0..#255] - ['0'..'9','A'..'Z','a'..'z']; Others : Range := [#0..#255] - ['0'..'9','A'..'Z','a'..'z'];
end; end;
Result := ''; Result := '';
for i := length(str) downto 1 do for i := length(str) downto 1 do
if str[i] in Range then if str[i] in Range then
result := str[i] + result; result := str[i] + result;
end; end;
end. end.

100
Units/MMLCore/mufasabase.pas
View File

@ -1,50 +1,50 @@
unit mufasabase; unit mufasabase;
{$mode objfpc} {$mode objfpc}
interface interface
uses uses
files, Classes, SysUtils{$ifdef MSWindows},windows{$endif}; files, Classes, SysUtils{$ifdef MSWindows},windows{$endif};
procedure mDebugLn( s : string);overload; procedure mDebugLn( s : string);overload;
procedure mDebugLn( s : string; f : array of const);overload; procedure mDebugLn( s : string; f : array of const);overload;
procedure InitmDebug; procedure InitmDebug;
procedure FreemDebug; procedure FreemDebug;
implementation implementation
uses uses
TestUnit; TestUnit;
var var
CanDebug : boolean = false; CanDebug : boolean = false;
procedure mDebugLn(s: string); procedure mDebugLn(s: string);
begin begin
if CanDebug then if CanDebug then
Writeln(s); Writeln(s);
end; end;
procedure mDebugLn(s: string; f: array of const); overload; procedure mDebugLn(s: string; f: array of const); overload;
begin begin
mDebugLn(format(s,f)); mDebugLn(format(s,f));
end; end;
procedure InitmDebug; procedure InitmDebug;
begin begin
CanDebug := true; CanDebug := true;
{$ifdef MSWindows} {$ifdef MSWindows}
IsConsole:= True; IsConsole:= True;
SysInitStdIO; SysInitStdIO;
{$endif} {$endif}
end; end;
procedure FreemDebug; procedure FreemDebug;
begin begin
CanDebug := false; CanDebug := false;
{$ifdef MSWindows} {$ifdef MSWindows}
IsConsole := false; IsConsole := false;
{$endif} {$endif}
end; end;
end. end.

84
Units/MMLCore/web.pas
View File

@ -1,42 +1,42 @@
unit web; unit web;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
uses uses
Classes, SysUtils,LazHelpHTML,UTF8Process; Classes, SysUtils,LazHelpHTML,UTF8Process;
procedure OpenWebPage(URL: string); procedure OpenWebPage(URL: string);
implementation implementation
procedure OpenWebPage(URL: string); procedure OpenWebPage(URL: string);
var var
v: THTMLBrowserHelpViewer; v: THTMLBrowserHelpViewer;
BrowserPath, BrowserParams: string; BrowserPath, BrowserParams: string;
p: LongInt; p: LongInt;
BrowserProcess: TProcessUTF8; BrowserProcess: TProcessUTF8;
begin begin
v:=THTMLBrowserHelpViewer.Create(nil); v:=THTMLBrowserHelpViewer.Create(nil);
try try
v.FindDefaultBrowser(BrowserPath,BrowserParams); v.FindDefaultBrowser(BrowserPath,BrowserParams);
p:=System.Pos('%s', BrowserParams); p:=System.Pos('%s', BrowserParams);
System.Delete(BrowserParams,p,2); System.Delete(BrowserParams,p,2);
System.Insert(URL,BrowserParams,p); System.Insert(URL,BrowserParams,p);
// start browser // start browser
BrowserProcess:=TProcessUTF8.Create(nil); BrowserProcess:=TProcessUTF8.Create(nil);
try try
BrowserProcess.CommandLine:=BrowserPath+' '+BrowserParams; BrowserProcess.CommandLine:=BrowserPath+' '+BrowserParams;
BrowserProcess.Execute; BrowserProcess.Execute;
finally finally
BrowserProcess.Free; BrowserProcess.Free;
end; end;
finally finally
v.Free; v.Free;
end; end;
end; end;
end. end.

280
Units/Misc/dcpbase64.pas
View File

@ -1,140 +1,140 @@
{******************************************************************************} {******************************************************************************}
{* DCPcrypt v2.0 written by David Barton (crypto@cityinthesky.co.uk) **********} {* DCPcrypt v2.0 written by David Barton (crypto@cityinthesky.co.uk) **********}
{******************************************************************************} {******************************************************************************}
{* A Base64 encoding/decoding unit ********************************************} {* A Base64 encoding/decoding unit ********************************************}
{******************************************************************************} {******************************************************************************}
{* Copyright (c) 1999-2002 David Barton *} {* Copyright (c) 1999-2002 David Barton *}
{* Permission is hereby granted, free of charge, to any person obtaining a *} {* Permission is hereby granted, free of charge, to any person obtaining a *}
{* copy of this software and associated documentation files (the "Software"), *} {* copy of this software and associated documentation files (the "Software"), *}
{* to deal in the Software without restriction, including without limitation *} {* to deal in the Software without restriction, including without limitation *}
{* the rights to use, copy, modify, merge, publish, distribute, sublicense, *} {* the rights to use, copy, modify, merge, publish, distribute, sublicense, *}
{* and/or sell copies of the Software, and to permit persons to whom the *} {* and/or sell copies of the Software, and to permit persons to whom the *}
{* Software is furnished to do so, subject to the following conditions: *} {* Software is furnished to do so, subject to the following conditions: *}
{* *} {* *}
{* The above copyright notice and this permission notice shall be included in *} {* The above copyright notice and this permission notice shall be included in *}
{* all copies or substantial portions of the Software. *} {* all copies or substantial portions of the Software. *}
{* *} {* *}
{* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *} {* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *}
{* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *} {* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *}
{* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *} {* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *}
{* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *} {* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *}
{* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *} {* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *}
{* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *} {* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *}
{* DEALINGS IN THE SOFTWARE. *} {* DEALINGS IN THE SOFTWARE. *}
{******************************************************************************} {******************************************************************************}
unit DCPbase64; unit DCPbase64;
{$mode delphi} {$mode delphi}
interface interface
uses uses
Sysutils; Sysutils;
function Base64EncodeStr(const Value: string): string; function Base64EncodeStr(const Value: string): string;
{ Encode a string into Base64 format } { Encode a string into Base64 format }
function Base64DecodeStr(const Value: string): string; function Base64DecodeStr(const Value: string): string;
{ Decode a Base64 format string } { Decode a Base64 format string }
function Base64Encode(pInput: pointer; pOutput: pointer; Size: longint): longint; function Base64Encode(pInput: pointer; pOutput: pointer; Size: longint): longint;
{ Encode a lump of raw data (output is (4/3) times bigger than input) } { Encode a lump of raw data (output is (4/3) times bigger than input) }
function Base64Decode(pInput: pointer; pOutput: pointer; Size: longint): longint; function Base64Decode(pInput: pointer; pOutput: pointer; Size: longint): longint;
{ Decode a lump of raw data } { Decode a lump of raw data }
{******************************************************************************} {******************************************************************************}
{******************************************************************************} {******************************************************************************}
implementation implementation
const const
B64: array[0..63] of byte= (65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80, B64: array[0..63] of byte= (65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
81,82,83,84,85,86,87,88,89,90,97,98,99,100,101,102,103,104,105,106,107,108, 81,82,83,84,85,86,87,88,89,90,97,98,99,100,101,102,103,104,105,106,107,108,
109,110,111,112,113,114,115,116,117,118,119,120,121,122,48,49,50,51,52,53, 109,110,111,112,113,114,115,116,117,118,119,120,121,122,48,49,50,51,52,53,
54,55,56,57,43,47); 54,55,56,57,43,47);
function Base64Encode(pInput: pointer; pOutput: pointer; Size: longint): longint; function Base64Encode(pInput: pointer; pOutput: pointer; Size: longint): longint;
var var
i, iptr, optr: integer; i, iptr, optr: integer;
Input, Output: PByteArray; Input, Output: PByteArray;
begin begin
Input:= PByteArray(pInput); Output:= PByteArray(pOutput); Input:= PByteArray(pInput); Output:= PByteArray(pOutput);
iptr:= 0; optr:= 0; iptr:= 0; optr:= 0;
for i:= 1 to (Size div 3) do for i:= 1 to (Size div 3) do
begin begin
Output^[optr+0]:= B64[Input^[iptr] shr 2]; Output^[optr+0]:= B64[Input^[iptr] shr 2];
Output^[optr+1]:= B64[((Input^[iptr] and 3) shl 4) + (Input^[iptr+1] shr 4)]; Output^[optr+1]:= B64[((Input^[iptr] and 3) shl 4) + (Input^[iptr+1] shr 4)];
Output^[optr+2]:= B64[((Input^[iptr+1] and 15) shl 2) + (Input^[iptr+2] shr 6)]; Output^[optr+2]:= B64[((Input^[iptr+1] and 15) shl 2) + (Input^[iptr+2] shr 6)];
Output^[optr+3]:= B64[Input^[iptr+2] and 63]; Output^[optr+3]:= B64[Input^[iptr+2] and 63];
Inc(optr,4); Inc(iptr,3); Inc(optr,4); Inc(iptr,3);
end; end;
case (Size mod 3) of case (Size mod 3) of
1: begin 1: begin
Output^[optr+0]:= B64[Input^[iptr] shr 2]; Output^[optr+0]:= B64[Input^[iptr] shr 2];
Output^[optr+1]:= B64[(Input^[iptr] and 3) shl 4]; Output^[optr+1]:= B64[(Input^[iptr] and 3) shl 4];
Output^[optr+2]:= byte('='); Output^[optr+2]:= byte('=');
Output^[optr+3]:= byte('='); Output^[optr+3]:= byte('=');
end; end;
2: begin 2: begin
Output^[optr+0]:= B64[Input^[iptr] shr 2]; Output^[optr+0]:= B64[Input^[iptr] shr 2];
Output^[optr+1]:= B64[((Input^[iptr] and 3) shl 4) + (Input^[iptr+1] shr 4)]; Output^[optr+1]:= B64[((Input^[iptr] and 3) shl 4) + (Input^[iptr+1] shr 4)];
Output^[optr+2]:= B64[(Input^[iptr+1] and 15) shl 2]; Output^[optr+2]:= B64[(Input^[iptr+1] and 15) shl 2];
Output^[optr+3]:= byte('='); Output^[optr+3]:= byte('=');
end; end;
end; end;
Result:= ((Size+2) div 3) * 4; Result:= ((Size+2) div 3) * 4;
end; end;
function Base64EncodeStr(const Value: string): string; function Base64EncodeStr(const Value: string): string;
begin begin
SetLength(Result,((Length(Value)+2) div 3) * 4); SetLength(Result,((Length(Value)+2) div 3) * 4);
Base64Encode(@Value[1],@Result[1],Length(Value)); Base64Encode(@Value[1],@Result[1],Length(Value));
end; end;
function Base64Decode(pInput: pointer; pOutput: pointer; Size: longint): longint; function Base64Decode(pInput: pointer; pOutput: pointer; Size: longint): longint;
var var
i, j, iptr, optr: integer; i, j, iptr, optr: integer;
Temp: array[0..3] of byte; Temp: array[0..3] of byte;
Input, Output: PByteArray; Input, Output: PByteArray;
begin begin
Input:= PByteArray(pInput); Output:= PByteArray(pOutput); Input:= PByteArray(pInput); Output:= PByteArray(pOutput);
iptr:= 0; optr:= 0; iptr:= 0; optr:= 0;
Result:= 0; Result:= 0;
for i:= 1 to (Size div 4) do for i:= 1 to (Size div 4) do
begin begin
for j:= 0 to 3 do for j:= 0 to 3 do
begin begin
case Input^[iptr] of case Input^[iptr] of
65..90 : Temp[j]:= Input^[iptr] - Ord('A'); 65..90 : Temp[j]:= Input^[iptr] - Ord('A');
97..122: Temp[j]:= Input^[iptr] - Ord('a') + 26; 97..122: Temp[j]:= Input^[iptr] - Ord('a') + 26;
48..57 : Temp[j]:= Input^[iptr] - Ord('0') + 52; 48..57 : Temp[j]:= Input^[iptr] - Ord('0') + 52;
43 : Temp[j]:= 62; 43 : Temp[j]:= 62;
47 : Temp[j]:= 63; 47 : Temp[j]:= 63;
61 : Temp[j]:= $FF; 61 : Temp[j]:= $FF;
end; end;
Inc(iptr); Inc(iptr);
end; end;
Output^[optr]:= (Temp[0] shl 2) or (Temp[1] shr 4); Output^[optr]:= (Temp[0] shl 2) or (Temp[1] shr 4);
Result:= optr+1; Result:= optr+1;
if (Temp[2]<> $FF) and (Temp[3]= $FF) then if (Temp[2]<> $FF) and (Temp[3]= $FF) then
begin begin
Output^[optr+1]:= (Temp[1] shl 4) or (Temp[2] shr 2); Output^[optr+1]:= (Temp[1] shl 4) or (Temp[2] shr 2);
Result:= optr+2; Result:= optr+2;
Inc(optr) Inc(optr)
end end
else if (Temp[2]<> $FF) then else if (Temp[2]<> $FF) then
begin begin
Output^[optr+1]:= (Temp[1] shl 4) or (Temp[2] shr 2); Output^[optr+1]:= (Temp[1] shl 4) or (Temp[2] shr 2);
Output^[optr+2]:= (Temp[2] shl 6) or Temp[3]; Output^[optr+2]:= (Temp[2] shl 6) or Temp[3];
Result:= optr+3; Result:= optr+3;
Inc(optr,2); Inc(optr,2);
end; end;
Inc(optr); Inc(optr);
end; end;
end; end;
function Base64DecodeStr(const Value: string): string; function Base64DecodeStr(const Value: string): string;
begin begin
SetLength(Result,(Length(Value) div 4) * 3); SetLength(Result,(Length(Value) div 4) * 3);
SetLength(Result,Base64Decode(@Value[1],@Result[1],Length(Value))); SetLength(Result,Base64Decode(@Value[1],@Result[1],Length(Value)));
end; end;
end. end.

3228
Units/Misc/mPasLex.pas
View File

File diff suppressed because it is too large Load Diff

1020
Units/Synapse/asn1util.pas
View File

File diff suppressed because it is too large Load Diff

8522
Units/Synapse/blcksock.pas
View File

File diff suppressed because it is too large Load Diff

554
Units/Synapse/clamsend.pas
View File

@ -1,277 +1,277 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.001.001 | | Project : Ararat Synapse | 001.001.001 |
|==============================================================================| |==============================================================================|
| Content: ClamAV-daemon client | | Content: ClamAV-daemon client |
|==============================================================================| |==============================================================================|
| Copyright (c)2005-2010, Lukas Gebauer | | Copyright (c)2005-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005-2010. | | Portions created by Lukas Gebauer are Copyright (c)2005-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@abstract( ClamAV-daemon client) {:@abstract( ClamAV-daemon client)
This unit is capable to do antivirus scan of your data by TCP channel to ClamD This unit is capable to do antivirus scan of your data by TCP channel to ClamD
daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net) daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net)
} }
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$Q-} {$Q-}
{$H+} {$H+}
{$IFDEF UNICODE} {$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF} {$ENDIF}
unit clamsend; unit clamsend;
interface interface
uses uses
SysUtils, Classes, SysUtils, Classes,
synsock, blcksock, synautil; synsock, blcksock, synautil;
const const
cClamProtocol = '3310'; cClamProtocol = '3310';
type type
{:@abstract(Implementation of ClamAV-daemon client protocol) {:@abstract(Implementation of ClamAV-daemon client protocol)
By this class you can scan any your data by ClamAV opensource antivirus. By this class you can scan any your data by ClamAV opensource antivirus.
This class can connect to ClamD by TCP channel, send your data to ClamD This class can connect to ClamD by TCP channel, send your data to ClamD
and read result.} and read result.}
TClamSend = class(TSynaClient) TClamSend = class(TSynaClient)
private private
FSock: TTCPBlockSocket; FSock: TTCPBlockSocket;
FDSock: TTCPBlockSocket; FDSock: TTCPBlockSocket;
FSession: boolean; FSession: boolean;
function Login: boolean; virtual; function Login: boolean; virtual;
function Logout: Boolean; virtual; function Logout: Boolean; virtual;
function OpenStream: Boolean; virtual; function OpenStream: Boolean; virtual;
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
{:Call any command to ClamD. Used internally by other methods.} {:Call any command to ClamD. Used internally by other methods.}
function DoCommand(const Value: AnsiString): AnsiString; virtual; function DoCommand(const Value: AnsiString): AnsiString; virtual;
{:Return ClamAV version and version of loaded databases.} {:Return ClamAV version and version of loaded databases.}
function GetVersion: AnsiString; virtual; function GetVersion: AnsiString; virtual;
{:Scan content of TStrings.} {:Scan content of TStrings.}
function ScanStrings(const Value: TStrings): AnsiString; virtual; function ScanStrings(const Value: TStrings): AnsiString; virtual;
{:Scan content of TStream.} {:Scan content of TStream.}
function ScanStream(const Value: TStream): AnsiString; virtual; function ScanStream(const Value: TStream): AnsiString; virtual;
{:Scan content of TStrings by new 0.95 API.} {:Scan content of TStrings by new 0.95 API.}
function ScanStrings2(const Value: TStrings): AnsiString; virtual; function ScanStrings2(const Value: TStrings): AnsiString; virtual;
{:Scan content of TStream by new 0.95 API.} {:Scan content of TStream by new 0.95 API.}
function ScanStream2(const Value: TStream): AnsiString; virtual; function ScanStream2(const Value: TStream): AnsiString; virtual;
published published
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock; property Sock: TTCPBlockSocket read FSock;
{:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.} {:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.}
property DSock: TTCPBlockSocket read FDSock; property DSock: TTCPBlockSocket read FDSock;
{:Can turn-on session mode of communication with ClamD. Default is @false, {:Can turn-on session mode of communication with ClamD. Default is @false,
because ClamAV developers design their TCP code very badly and session mode because ClamAV developers design their TCP code very badly and session mode
is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs
and this mode will be possible in future.} and this mode will be possible in future.}
property Session: boolean read FSession write FSession; property Session: boolean read FSession write FSession;
end; end;
implementation implementation
constructor TClamSend.Create; constructor TClamSend.Create;
begin begin
inherited Create; inherited Create;
FSock := TTCPBlockSocket.Create; FSock := TTCPBlockSocket.Create;
FSock.Owner := self; FSock.Owner := self;
FDSock := TTCPBlockSocket.Create; FDSock := TTCPBlockSocket.Create;
FDSock.Owner := self; FDSock.Owner := self;
FTimeout := 60000; FTimeout := 60000;
FTargetPort := cClamProtocol; FTargetPort := cClamProtocol;
FSession := false; FSession := false;
end; end;
destructor TClamSend.Destroy; destructor TClamSend.Destroy;
begin begin
Logout; Logout;
FDSock.Free; FDSock.Free;
FSock.Free; FSock.Free;
inherited Destroy; inherited Destroy;
end; end;
function TClamSend.DoCommand(const Value: AnsiString): AnsiString; function TClamSend.DoCommand(const Value: AnsiString): AnsiString;
begin begin
Result := ''; Result := '';
if not FSession then if not FSession then
FSock.CloseSocket FSock.CloseSocket
else else
FSock.SendString(Value + LF); FSock.SendString(Value + LF);
if not FSession or (FSock.LastError <> 0) then if not FSession or (FSock.LastError <> 0) then
begin begin
if Login then if Login then
FSock.SendString(Value + LF) FSock.SendString(Value + LF)
else else
Exit; Exit;
end; end;
Result := FSock.RecvTerminated(FTimeout, LF); Result := FSock.RecvTerminated(FTimeout, LF);
end; end;
function TClamSend.Login: boolean; function TClamSend.Login: boolean;
begin begin
Result := False; Result := False;
Sock.CloseSocket; Sock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort); FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
Exit; Exit;
FSock.Connect(FTargetHost, FTargetPort); FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
Exit; Exit;
if FSession then if FSession then
FSock.SendString('SESSION' + LF); FSock.SendString('SESSION' + LF);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
function TClamSend.Logout: Boolean; function TClamSend.Logout: Boolean;
begin begin
FSock.SendString('END' + LF); FSock.SendString('END' + LF);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
FSock.CloseSocket; FSock.CloseSocket;
end; end;
function TClamSend.GetVersion: AnsiString; function TClamSend.GetVersion: AnsiString;
begin begin
Result := DoCommand('nVERSION'); Result := DoCommand('nVERSION');
end; end;
function TClamSend.OpenStream: Boolean; function TClamSend.OpenStream: Boolean;
var var
S: AnsiString; S: AnsiString;
begin begin
Result := False; Result := False;
s := DoCommand('nSTREAM'); s := DoCommand('nSTREAM');
if (s <> '') and (Copy(s, 1, 4) = 'PORT') then if (s <> '') and (Copy(s, 1, 4) = 'PORT') then
begin begin
s := SeparateRight(s, ' '); s := SeparateRight(s, ' ');
FDSock.CloseSocket; FDSock.CloseSocket;
FDSock.Bind(FIPInterface, cAnyPort); FDSock.Bind(FIPInterface, cAnyPort);
if FDSock.LastError <> 0 then if FDSock.LastError <> 0 then
Exit; Exit;
FDSock.Connect(FTargetHost, s); FDSock.Connect(FTargetHost, s);
if FDSock.LastError <> 0 then if FDSock.LastError <> 0 then
Exit; Exit;
Result := True; Result := True;
end; end;
end; end;
function TClamSend.ScanStrings(const Value: TStrings): AnsiString; function TClamSend.ScanStrings(const Value: TStrings): AnsiString;
begin begin
Result := ''; Result := '';
if OpenStream then if OpenStream then
begin begin
DSock.SendString(Value.Text); DSock.SendString(Value.Text);
DSock.CloseSocket; DSock.CloseSocket;
Result := FSock.RecvTerminated(FTimeout, LF); Result := FSock.RecvTerminated(FTimeout, LF);
end; end;
end; end;
function TClamSend.ScanStream(const Value: TStream): AnsiString; function TClamSend.ScanStream(const Value: TStream): AnsiString;
begin begin
Result := ''; Result := '';
if OpenStream then if OpenStream then
begin begin
DSock.SendStreamRaw(Value); DSock.SendStreamRaw(Value);
DSock.CloseSocket; DSock.CloseSocket;
Result := FSock.RecvTerminated(FTimeout, LF); Result := FSock.RecvTerminated(FTimeout, LF);
end; end;
end; end;
function TClamSend.ScanStrings2(const Value: TStrings): AnsiString; function TClamSend.ScanStrings2(const Value: TStrings): AnsiString;
var var
i: integer; i: integer;
s: AnsiString; s: AnsiString;
begin begin
Result := ''; Result := '';
if not FSession then if not FSession then
FSock.CloseSocket FSock.CloseSocket
else else
FSock.sendstring('nINSTREAM' + LF); FSock.sendstring('nINSTREAM' + LF);
if not FSession or (FSock.LastError <> 0) then if not FSession or (FSock.LastError <> 0) then
begin begin
if Login then if Login then
FSock.sendstring('nINSTREAM' + LF) FSock.sendstring('nINSTREAM' + LF)
else else
Exit; Exit;
end; end;
s := Value.text; s := Value.text;
i := length(s); i := length(s);
FSock.SendString(CodeLongint(i) + s + #0#0#0#0); FSock.SendString(CodeLongint(i) + s + #0#0#0#0);
Result := FSock.RecvTerminated(FTimeout, LF); Result := FSock.RecvTerminated(FTimeout, LF);
end; end;
function TClamSend.ScanStream2(const Value: TStream): AnsiString; function TClamSend.ScanStream2(const Value: TStream): AnsiString;
var var
i: integer; i: integer;
begin begin
Result := ''; Result := '';
if not FSession then if not FSession then
FSock.CloseSocket FSock.CloseSocket
else else
FSock.sendstring('nINSTREAM' + LF); FSock.sendstring('nINSTREAM' + LF);
if not FSession or (FSock.LastError <> 0) then if not FSession or (FSock.LastError <> 0) then
begin begin
if Login then if Login then
FSock.sendstring('nINSTREAM' + LF) FSock.sendstring('nINSTREAM' + LF)
else else
Exit; Exit;
end; end;
i := value.Size; i := value.Size;
FSock.SendString(CodeLongint(i)); FSock.SendString(CodeLongint(i));
FSock.SendStreamRaw(Value); FSock.SendStreamRaw(Value);
FSock.SendString(#0#0#0#0); FSock.SendString(#0#0#0#0);
Result := FSock.RecvTerminated(FTimeout, LF); Result := FSock.RecvTerminated(FTimeout, LF);
end; end;
end. end.

1206
Units/Synapse/dnssend.pas
View File

File diff suppressed because it is too large Load Diff

3898
Units/Synapse/ftpsend.pas
View File

File diff suppressed because it is too large Load Diff

806
Units/Synapse/ftptsend.pas
View File

@ -1,403 +1,403 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.001.001 | | Project : Ararat Synapse | 001.001.001 |
|==============================================================================| |==============================================================================|
| Content: Trivial FTP (TFTP) client and server | | Content: Trivial FTP (TFTP) client and server |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer | | Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. | | Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{: @abstract(TFTP client and server protocol) {: @abstract(TFTP client and server protocol)
Used RFC: RFC-1350 Used RFC: RFC-1350
} }
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$Q-} {$Q-}
{$H+} {$H+}
{$IFDEF UNICODE} {$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF} {$ENDIF}
unit ftptsend; unit ftptsend;
interface interface
uses uses
SysUtils, Classes, SysUtils, Classes,
blcksock, synautil; blcksock, synautil;
const const
cTFTPProtocol = '69'; cTFTPProtocol = '69';
cTFTP_RRQ = word(1); cTFTP_RRQ = word(1);
cTFTP_WRQ = word(2); cTFTP_WRQ = word(2);
cTFTP_DTA = word(3); cTFTP_DTA = word(3);
cTFTP_ACK = word(4); cTFTP_ACK = word(4);
cTFTP_ERR = word(5); cTFTP_ERR = word(5);
type type
{:@abstract(Implementation of TFTP client and server) {:@abstract(Implementation of TFTP client and server)
Note: Are you missing properties for specify server address and port? Look to Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!} parent @link(TSynaClient) too!}
TTFTPSend = class(TSynaClient) TTFTPSend = class(TSynaClient)
private private
FSock: TUDPBlockSocket; FSock: TUDPBlockSocket;
FErrorCode: integer; FErrorCode: integer;
FErrorString: string; FErrorString: string;
FData: TMemoryStream; FData: TMemoryStream;
FRequestIP: string; FRequestIP: string;
FRequestPort: string; FRequestPort: string;
function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
function RecvPacket(Serial: word; var Value: string): Boolean; function RecvPacket(Serial: word; var Value: string): Boolean;
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
{:Upload @link(data) as file to TFTP server.} {:Upload @link(data) as file to TFTP server.}
function SendFile(const Filename: string): Boolean; function SendFile(const Filename: string): Boolean;
{:Download file from TFTP server to @link(data).} {:Download file from TFTP server to @link(data).}
function RecvFile(const Filename: string): Boolean; function RecvFile(const Filename: string): Boolean;
{:Acts as TFTP server and wait for client request. When some request {:Acts as TFTP server and wait for client request. When some request
incoming within Timeout, result is @true and parametres is filled with incoming within Timeout, result is @true and parametres is filled with
information from request. You must handle this request, validate it, and information from request. You must handle this request, validate it, and
call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
to TFTP Client.} to TFTP Client.}
function WaitForRequest(var Req: word; var filename: string): Boolean; function WaitForRequest(var Req: word; var filename: string): Boolean;
{:send error to TFTP client, when you acts as TFTP server.} {:send error to TFTP client, when you acts as TFTP server.}
procedure ReplyError(Error: word; Description: string); procedure ReplyError(Error: word; Description: string);
{:Accept uploaded file from TFTP client to @link(data), when you acts as {:Accept uploaded file from TFTP client to @link(data), when you acts as
TFTP server.} TFTP server.}
function ReplyRecv: Boolean; function ReplyRecv: Boolean;
{:Accept download request file from TFTP client and send content of {:Accept download request file from TFTP client and send content of
@link(data), when you acts as TFTP server.} @link(data), when you acts as TFTP server.}
function ReplySend: Boolean; function ReplySend: Boolean;
published published
{:Code of TFTP error.} {:Code of TFTP error.}
property ErrorCode: integer read FErrorCode; property ErrorCode: integer read FErrorCode;
{:Human readable decription of TFTP error. (if is sended by remote side)} {:Human readable decription of TFTP error. (if is sended by remote side)}
property ErrorString: string read FErrorString; property ErrorString: string read FErrorString;
{:MemoryStream with datas for sending or receiving} {:MemoryStream with datas for sending or receiving}
property Data: TMemoryStream read FData; property Data: TMemoryStream read FData;
{:Address of TFTP remote side.} {:Address of TFTP remote side.}
property RequestIP: string read FRequestIP write FRequestIP; property RequestIP: string read FRequestIP write FRequestIP;
{:Port of TFTP remote side.} {:Port of TFTP remote side.}
property RequestPort: string read FRequestPort write FRequestPort; property RequestPort: string read FRequestPort write FRequestPort;
end; end;
implementation implementation
constructor TTFTPSend.Create; constructor TTFTPSend.Create;
begin begin
inherited Create; inherited Create;
FSock := TUDPBlockSocket.Create; FSock := TUDPBlockSocket.Create;
FSock.Owner := self; FSock.Owner := self;
FTargetPort := cTFTPProtocol; FTargetPort := cTFTPProtocol;
FData := TMemoryStream.Create; FData := TMemoryStream.Create;
FErrorCode := 0; FErrorCode := 0;
FErrorString := ''; FErrorString := '';
end; end;
destructor TTFTPSend.Destroy; destructor TTFTPSend.Destroy;
begin begin
FSock.Free; FSock.Free;
FData.Free; FData.Free;
inherited Destroy; inherited Destroy;
end; end;
function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
var var
s, sh: string; s, sh: string;
begin begin
FErrorCode := 0; FErrorCode := 0;
FErrorString := ''; FErrorString := '';
Result := false; Result := false;
if Cmd <> 2 then if Cmd <> 2 then
s := CodeInt(Cmd) + CodeInt(Serial) + Value s := CodeInt(Cmd) + CodeInt(Serial) + Value
else else
s := CodeInt(Cmd) + Value; s := CodeInt(Cmd) + Value;
FSock.SendString(s); FSock.SendString(s);
s := FSock.RecvPacket(FTimeout); s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then if FSock.LastError = 0 then
if length(s) >= 4 then if length(s) >= 4 then
begin begin
sh := CodeInt(4) + CodeInt(Serial); sh := CodeInt(4) + CodeInt(Serial);
if Pos(sh, s) = 1 then if Pos(sh, s) = 1 then
Result := True Result := True
else else
if s[1] = #5 then if s[1] = #5 then
begin begin
FErrorCode := DecodeInt(s, 3); FErrorCode := DecodeInt(s, 3);
Delete(s, 1, 4); Delete(s, 1, 4);
FErrorString := SeparateLeft(s, #0); FErrorString := SeparateLeft(s, #0);
end; end;
end; end;
end; end;
function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean; function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
var var
s: string; s: string;
ser: word; ser: word;
begin begin
FErrorCode := 0; FErrorCode := 0;
FErrorString := ''; FErrorString := '';
Result := False; Result := False;
Value := ''; Value := '';
s := FSock.RecvPacket(FTimeout); s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then if FSock.LastError = 0 then
if length(s) >= 4 then if length(s) >= 4 then
if DecodeInt(s, 1) = 3 then if DecodeInt(s, 1) = 3 then
begin begin
ser := DecodeInt(s, 3); ser := DecodeInt(s, 3);
if ser = Serial then if ser = Serial then
begin begin
Delete(s, 1, 4); Delete(s, 1, 4);
Value := s; Value := s;
S := CodeInt(4) + CodeInt(ser); S := CodeInt(4) + CodeInt(ser);
FSock.SendString(s); FSock.SendString(s);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end end
else else
begin begin
S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0; S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
FSock.SendString(s); FSock.SendString(s);
end; end;
end; end;
if DecodeInt(s, 1) = 5 then if DecodeInt(s, 1) = 5 then
begin begin
FErrorCode := DecodeInt(s, 3); FErrorCode := DecodeInt(s, 3);
Delete(s, 1, 4); Delete(s, 1, 4);
FErrorString := SeparateLeft(s, #0); FErrorString := SeparateLeft(s, #0);
end; end;
end; end;
function TTFTPSend.SendFile(const Filename: string): Boolean; function TTFTPSend.SendFile(const Filename: string): Boolean;
var var
s: string; s: string;
ser: word; ser: word;
n, n1, n2: integer; n, n1, n2: integer;
begin begin
Result := False; Result := False;
FErrorCode := 0; FErrorCode := 0;
FErrorString := ''; FErrorString := '';
FSock.CloseSocket; FSock.CloseSocket;
FSock.Connect(FTargetHost, FTargetPort); FSock.Connect(FTargetHost, FTargetPort);
try try
if FSock.LastError = 0 then if FSock.LastError = 0 then
begin begin
s := Filename + #0 + 'octet' + #0; s := Filename + #0 + 'octet' + #0;
if not Sendpacket(2, 0, s) then if not Sendpacket(2, 0, s) then
Exit; Exit;
ser := 1; ser := 1;
FData.Position := 0; FData.Position := 0;
n1 := FData.Size div 512; n1 := FData.Size div 512;
n2 := FData.Size mod 512; n2 := FData.Size mod 512;
for n := 1 to n1 do for n := 1 to n1 do
begin begin
s := ReadStrFromStream(FData, 512); s := ReadStrFromStream(FData, 512);
// SetLength(s, 512); // SetLength(s, 512);
// FData.Read(pointer(s)^, 512); // FData.Read(pointer(s)^, 512);
if not Sendpacket(3, ser, s) then if not Sendpacket(3, ser, s) then
Exit; Exit;
inc(ser); inc(ser);
end; end;
s := ReadStrFromStream(FData, n2); s := ReadStrFromStream(FData, n2);
// SetLength(s, n2); // SetLength(s, n2);
// FData.Read(pointer(s)^, n2); // FData.Read(pointer(s)^, n2);
if not Sendpacket(3, ser, s) then if not Sendpacket(3, ser, s) then
Exit; Exit;
Result := True; Result := True;
end; end;
finally finally
FSock.CloseSocket; FSock.CloseSocket;
end; end;
end; end;
function TTFTPSend.RecvFile(const Filename: string): Boolean; function TTFTPSend.RecvFile(const Filename: string): Boolean;
var var
s: string; s: string;
ser: word; ser: word;
begin begin
Result := False; Result := False;
FErrorCode := 0; FErrorCode := 0;
FErrorString := ''; FErrorString := '';
FSock.CloseSocket; FSock.CloseSocket;
FSock.Connect(FTargetHost, FTargetPort); FSock.Connect(FTargetHost, FTargetPort);
try try
if FSock.LastError = 0 then if FSock.LastError = 0 then
begin begin
s := CodeInt(1) + Filename + #0 + 'octet' + #0; s := CodeInt(1) + Filename + #0 + 'octet' + #0;
FSock.SendString(s); FSock.SendString(s);
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
Exit; Exit;
FData.Clear; FData.Clear;
ser := 1; ser := 1;
repeat repeat
if not RecvPacket(ser, s) then if not RecvPacket(ser, s) then
Exit; Exit;
inc(ser); inc(ser);
WriteStrToStream(FData, s); WriteStrToStream(FData, s);
// FData.Write(pointer(s)^, length(s)); // FData.Write(pointer(s)^, length(s));
until length(s) <> 512; until length(s) <> 512;
FData.Position := 0; FData.Position := 0;
Result := true; Result := true;
end; end;
finally finally
FSock.CloseSocket; FSock.CloseSocket;
end; end;
end; end;
function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean; function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
var var
s: string; s: string;
begin begin
Result := False; Result := False;
FErrorCode := 0; FErrorCode := 0;
FErrorString := ''; FErrorString := '';
FSock.CloseSocket; FSock.CloseSocket;
FSock.Bind('0.0.0.0', FTargetPort); FSock.Bind('0.0.0.0', FTargetPort);
if FSock.LastError = 0 then if FSock.LastError = 0 then
begin begin
s := FSock.RecvPacket(FTimeout); s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then if FSock.LastError = 0 then
if Length(s) >= 4 then if Length(s) >= 4 then
begin begin
FRequestIP := FSock.GetRemoteSinIP; FRequestIP := FSock.GetRemoteSinIP;
FRequestPort := IntToStr(FSock.GetRemoteSinPort); FRequestPort := IntToStr(FSock.GetRemoteSinPort);
Req := DecodeInt(s, 1); Req := DecodeInt(s, 1);
delete(s, 1, 2); delete(s, 1, 2);
filename := Trim(SeparateLeft(s, #0)); filename := Trim(SeparateLeft(s, #0));
s := SeparateRight(s, #0); s := SeparateRight(s, #0);
s := SeparateLeft(s, #0); s := SeparateLeft(s, #0);
Result := lowercase(trim(s)) = 'octet'; Result := lowercase(trim(s)) = 'octet';
end; end;
end; end;
end; end;
procedure TTFTPSend.ReplyError(Error: word; Description: string); procedure TTFTPSend.ReplyError(Error: word; Description: string);
var var
s: string; s: string;
begin begin
FSock.CloseSocket; FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort); FSock.Connect(FRequestIP, FRequestPort);
s := CodeInt(5) + CodeInt(Error) + Description + #0; s := CodeInt(5) + CodeInt(Error) + Description + #0;
FSock.SendString(s); FSock.SendString(s);
FSock.CloseSocket; FSock.CloseSocket;
end; end;
function TTFTPSend.ReplyRecv: Boolean; function TTFTPSend.ReplyRecv: Boolean;
var var
s: string; s: string;
ser: integer; ser: integer;
begin begin
Result := False; Result := False;
FErrorCode := 0; FErrorCode := 0;
FErrorString := ''; FErrorString := '';
FSock.CloseSocket; FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort); FSock.Connect(FRequestIP, FRequestPort);
try try
s := CodeInt(4) + CodeInt(0); s := CodeInt(4) + CodeInt(0);
FSock.SendString(s); FSock.SendString(s);
FData.Clear; FData.Clear;
ser := 1; ser := 1;
repeat repeat
if not RecvPacket(ser, s) then if not RecvPacket(ser, s) then
Exit; Exit;
inc(ser); inc(ser);
WriteStrToStream(FData, s); WriteStrToStream(FData, s);
// FData.Write(pointer(s)^, length(s)); // FData.Write(pointer(s)^, length(s));
until length(s) <> 512; until length(s) <> 512;
FData.Position := 0; FData.Position := 0;
Result := true; Result := true;
finally finally
FSock.CloseSocket; FSock.CloseSocket;
end; end;
end; end;
function TTFTPSend.ReplySend: Boolean; function TTFTPSend.ReplySend: Boolean;
var var
s: string; s: string;
ser: word; ser: word;
n, n1, n2: integer; n, n1, n2: integer;
begin begin
Result := False; Result := False;
FErrorCode := 0; FErrorCode := 0;
FErrorString := ''; FErrorString := '';
FSock.CloseSocket; FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort); FSock.Connect(FRequestIP, FRequestPort);
try try
ser := 1; ser := 1;
FData.Position := 0; FData.Position := 0;
n1 := FData.Size div 512; n1 := FData.Size div 512;
n2 := FData.Size mod 512; n2 := FData.Size mod 512;
for n := 1 to n1 do for n := 1 to n1 do
begin begin
s := ReadStrFromStream(FData, 512); s := ReadStrFromStream(FData, 512);
// SetLength(s, 512); // SetLength(s, 512);
// FData.Read(pointer(s)^, 512); // FData.Read(pointer(s)^, 512);
if not Sendpacket(3, ser, s) then if not Sendpacket(3, ser, s) then
Exit; Exit;
inc(ser); inc(ser);
end; end;
s := ReadStrFromStream(FData, n2); s := ReadStrFromStream(FData, n2);
// SetLength(s, n2); // SetLength(s, n2);
// FData.Read(pointer(s)^, n2); // FData.Read(pointer(s)^, n2);
if not Sendpacket(3, ser, s) then if not Sendpacket(3, ser, s) then
Exit; Exit;
Result := True; Result := True;
finally finally
FSock.CloseSocket; FSock.CloseSocket;
end; end;
end; end;
{==============================================================================} {==============================================================================}
end. end.

1680
Units/Synapse/httpsend.pas
View File

File diff suppressed because it is too large Load Diff

1738
Units/Synapse/imapsend.pas
View File

File diff suppressed because it is too large Load Diff

2416
Units/Synapse/ldapsend.pas
View File

File diff suppressed because it is too large Load Diff

526
Units/Synapse/mimeinln.pas
View File

@ -1,263 +1,263 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.001.011 | | Project : Ararat Synapse | 001.001.011 |
|==============================================================================| |==============================================================================|
| Content: Inline MIME support procedures and functions | | Content: Inline MIME support procedures and functions |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer | | Copyright (c)1999-2006, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2006. | | Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@abstract(Utilities for inline MIME) {:@abstract(Utilities for inline MIME)
Support for Inline MIME encoding and decoding. Support for Inline MIME encoding and decoding.
Used RFC: RFC-2047, RFC-2231 Used RFC: RFC-2047, RFC-2231
} }
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$H+} {$H+}
{$IFDEF UNICODE} {$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF} {$ENDIF}
unit mimeinln; unit mimeinln;
interface interface
uses uses
SysUtils, Classes, SysUtils, Classes,
synachar, synacode, synautil; synachar, synacode, synautil;
{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".} {:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".}
function InlineDecode(const Value: string; CP: TMimeChar): string; function InlineDecode(const Value: string; CP: TMimeChar): string;
{:Encodes string to MIME inline encoding. The source characterset is "CP", and {:Encodes string to MIME inline encoding. The source characterset is "CP", and
the target charset is "MimeP".} the target charset is "MimeP".}
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
{:Returns @true, if "Value" contains characters needed for inline coding.} {:Returns @true, if "Value" contains characters needed for inline coding.}
function NeedInline(const Value: AnsiString): boolean; function NeedInline(const Value: AnsiString): boolean;
{:Inline mime encoding similar to @link(InlineEncode), but you can specify {:Inline mime encoding similar to @link(InlineEncode), but you can specify
source charset, and the target characterset is automatically assigned.} source charset, and the target characterset is automatically assigned.}
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
{:Inline MIME encoding similar to @link(InlineEncode), but the source charset {:Inline MIME encoding similar to @link(InlineEncode), but the source charset
is automatically set to the system default charset, and the target charset is is automatically set to the system default charset, and the target charset is
automatically assigned from set of allowed encoding for MIME.} automatically assigned from set of allowed encoding for MIME.}
function InlineCode(const Value: string): string; function InlineCode(const Value: string): string;
{:Converts e-mail address to canonical mime form. You can specify source charset.} {:Converts e-mail address to canonical mime form. You can specify source charset.}
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
{:Converts e-mail address to canonical mime form. Source charser it system {:Converts e-mail address to canonical mime form. Source charser it system
default charset.} default charset.}
function InlineEmail(const Value: string): string; function InlineEmail(const Value: string): string;
implementation implementation
{==============================================================================} {==============================================================================}
function InlineDecode(const Value: string; CP: TMimeChar): string; function InlineDecode(const Value: string; CP: TMimeChar): string;
var var
s, su, v: string; s, su, v: string;
x, y, z, n: Integer; x, y, z, n: Integer;
ichar: TMimeChar; ichar: TMimeChar;
c: Char; c: Char;
function SearchEndInline(const Value: string; be: Integer): Integer; function SearchEndInline(const Value: string; be: Integer): Integer;
var var
n, q: Integer; n, q: Integer;
begin begin
q := 0; q := 0;
Result := 0; Result := 0;
for n := be + 2 to Length(Value) - 1 do for n := be + 2 to Length(Value) - 1 do
if Value[n] = '?' then if Value[n] = '?' then
begin begin
Inc(q); Inc(q);
if (q > 2) and (Value[n + 1] = '=') then if (q > 2) and (Value[n + 1] = '=') then
begin begin
Result := n; Result := n;
Break; Break;
end; end;
end; end;
end; end;
begin begin
Result := ''; Result := '';
v := Value; v := Value;
x := Pos('=?', v); x := Pos('=?', v);
y := SearchEndInline(v, x); y := SearchEndInline(v, x);
//fix for broken coding with begin, but not with end. //fix for broken coding with begin, but not with end.
if (x > 0) and (y <= 0) then if (x > 0) and (y <= 0) then
y := Length(Result); y := Length(Result);
while (y > x) and (x > 0) do while (y > x) and (x > 0) do
begin begin
s := Copy(v, 1, x - 1); s := Copy(v, 1, x - 1);
if Trim(s) <> '' then if Trim(s) <> '' then
Result := Result + s; Result := Result + s;
s := Copy(v, x, y - x + 2); s := Copy(v, x, y - x + 2);
Delete(v, 1, y + 1); Delete(v, 1, y + 1);
su := Copy(s, 3, Length(s) - 4); su := Copy(s, 3, Length(s) - 4);
z := Pos('?', su); z := Pos('?', su);
if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
begin begin
ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*')); ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*'));
c := UpperCase(su)[z + 1]; c := UpperCase(su)[z + 1];
su := Copy(su, z + 3, Length(su) - z - 2); su := Copy(su, z + 3, Length(su) - z - 2);
if c = 'B' then if c = 'B' then
begin begin
s := DecodeBase64(su); s := DecodeBase64(su);
s := CharsetConversion(s, ichar, CP); s := CharsetConversion(s, ichar, CP);
end; end;
if c = 'Q' then if c = 'Q' then
begin begin
s := ''; s := '';
for n := 1 to Length(su) do for n := 1 to Length(su) do
if su[n] = '_' then if su[n] = '_' then
s := s + ' ' s := s + ' '
else else
s := s + su[n]; s := s + su[n];
s := DecodeQuotedPrintable(s); s := DecodeQuotedPrintable(s);
s := CharsetConversion(s, ichar, CP); s := CharsetConversion(s, ichar, CP);
end; end;
end; end;
Result := Result + s; Result := Result + s;
x := Pos('=?', v); x := Pos('=?', v);
y := SearchEndInline(v, x); y := SearchEndInline(v, x);
end; end;
Result := Result + v; Result := Result + v;
end; end;
{==============================================================================} {==============================================================================}
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
var var
s, s1, e: string; s, s1, e: string;
n: Integer; n: Integer;
begin begin
s := CharsetConversion(Value, CP, MimeP); s := CharsetConversion(Value, CP, MimeP);
s := EncodeSafeQuotedPrintable(s); s := EncodeSafeQuotedPrintable(s);
e := GetIdFromCP(MimeP); e := GetIdFromCP(MimeP);
s1 := ''; s1 := '';
Result := ''; Result := '';
for n := 1 to Length(s) do for n := 1 to Length(s) do
if s[n] = ' ' then if s[n] = ' ' then
begin begin
// s1 := s1 + '=20'; // s1 := s1 + '=20';
s1 := s1 + '_'; s1 := s1 + '_';
if Length(s1) > 32 then if Length(s1) > 32 then
begin begin
if Result <> '' then if Result <> '' then
Result := Result + ' '; Result := Result + ' ';
Result := Result + '=?' + e + '?Q?' + s1 + '?='; Result := Result + '=?' + e + '?Q?' + s1 + '?=';
s1 := ''; s1 := '';
end; end;
end end
else else
s1 := s1 + s[n]; s1 := s1 + s[n];
if s1 <> '' then if s1 <> '' then
begin begin
if Result <> '' then if Result <> '' then
Result := Result + ' '; Result := Result + ' ';
Result := Result + '=?' + e + '?Q?' + s1 + '?='; Result := Result + '=?' + e + '?Q?' + s1 + '?=';
end; end;
end; end;
{==============================================================================} {==============================================================================}
function NeedInline(const Value: AnsiString): boolean; function NeedInline(const Value: AnsiString): boolean;
var var
n: Integer; n: Integer;
begin begin
Result := False; Result := False;
for n := 1 to Length(Value) do for n := 1 to Length(Value) do
if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then
begin begin
Result := True; Result := True;
Break; Break;
end; end;
end; end;
{==============================================================================} {==============================================================================}
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
var var
c: TMimeChar; c: TMimeChar;
begin begin
if NeedInline(Value) then if NeedInline(Value) then
begin begin
c := IdealCharsetCoding(Value, FromCP, IdealCharsets); c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
Result := InlineEncode(Value, FromCP, c); Result := InlineEncode(Value, FromCP, c);
end end
else else
Result := Value; Result := Value;
end; end;
{==============================================================================} {==============================================================================}
function InlineCode(const Value: string): string; function InlineCode(const Value: string): string;
begin begin
Result := InlineCodeEx(Value, GetCurCP); Result := InlineCodeEx(Value, GetCurCP);
end; end;
{==============================================================================} {==============================================================================}
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
var var
sd, se: string; sd, se: string;
begin begin
sd := GetEmailDesc(Value); sd := GetEmailDesc(Value);
se := GetEmailAddr(Value); se := GetEmailAddr(Value);
if sd = '' then if sd = '' then
Result := se Result := se
else else
Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>'; Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
end; end;
{==============================================================================} {==============================================================================}
function InlineEmail(const Value: string): string; function InlineEmail(const Value: string): string;
begin begin
Result := InlineEmailEx(Value, GetCurCP); Result := InlineEmailEx(Value, GetCurCP);
end; end;
end. end.

1648
Units/Synapse/mimemess.pas
View File

File diff suppressed because it is too large Load Diff

2188
Units/Synapse/mimepart.pas
View File

File diff suppressed because it is too large Load Diff

962
Units/Synapse/nntpsend.pas
View File

@ -1,481 +1,481 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.005.002 | | Project : Ararat Synapse | 001.005.002 |
|==============================================================================| |==============================================================================|
| Content: NNTP client | | Content: NNTP client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer | | Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. | | Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@abstract(NNTP client) {:@abstract(NNTP client)
NNTP (network news transfer protocol) NNTP (network news transfer protocol)
Used RFC: RFC-977, RFC-2980 Used RFC: RFC-977, RFC-2980
} }
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$H+} {$H+}
{$IFDEF UNICODE} {$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF} {$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF} {$ENDIF}
unit nntpsend; unit nntpsend;
interface interface
uses uses
SysUtils, Classes, SysUtils, Classes,
blcksock, synautil; blcksock, synautil;
const const
cNNTPProtocol = '119'; cNNTPProtocol = '119';
type type
{:abstract(Implementation of Network News Transfer Protocol. {:abstract(Implementation of Network News Transfer Protocol.
Note: Are you missing properties for setting Username and Password? Look to Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object! parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!} parent @link(TSynaClient) too!}
TNNTPSend = class(TSynaClient) TNNTPSend = class(TSynaClient)
private private
FSock: TTCPBlockSocket; FSock: TTCPBlockSocket;
FResultCode: Integer; FResultCode: Integer;
FResultString: string; FResultString: string;
FData: TStringList; FData: TStringList;
FDataToSend: TStringList; FDataToSend: TStringList;
FAutoTLS: Boolean; FAutoTLS: Boolean;
FFullSSL: Boolean; FFullSSL: Boolean;
FNNTPcap: TStringList; FNNTPcap: TStringList;
function ReadResult: Integer; function ReadResult: Integer;
function ReadData: boolean; function ReadData: boolean;
function SendData: boolean; function SendData: boolean;
function Connect: Boolean; function Connect: Boolean;
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
{:Connects to NNTP server and begin session.} {:Connects to NNTP server and begin session.}
function Login: Boolean; function Login: Boolean;
{:Logout from NNTP server and terminate session.} {:Logout from NNTP server and terminate session.}
function Logout: Boolean; function Logout: Boolean;
{:By this you can call any NNTP command.} {:By this you can call any NNTP command.}
function DoCommand(const Command: string): boolean; function DoCommand(const Command: string): boolean;
{:by this you can call any NNTP command. This variant is used for commands {:by this you can call any NNTP command. This variant is used for commands
for download information from server.} for download information from server.}
function DoCommandRead(const Command: string): boolean; function DoCommandRead(const Command: string): boolean;
{:by this you can call any NNTP command. This variant is used for commands {:by this you can call any NNTP command. This variant is used for commands
for upload information to server.} for upload information to server.}
function DoCommandWrite(const Command: string): boolean; function DoCommandWrite(const Command: string): boolean;
{:Download full message to @link(data) property. Value can be number of {:Download full message to @link(data) property. Value can be number of
message or message-id (in brackets).} message or message-id (in brackets).}
function GetArticle(const Value: string): Boolean; function GetArticle(const Value: string): Boolean;
{:Download only body of message to @link(data) property. Value can be number {:Download only body of message to @link(data) property. Value can be number
of message or message-id (in brackets).} of message or message-id (in brackets).}
function GetBody(const Value: string): Boolean; function GetBody(const Value: string): Boolean;
{:Download only headers of message to @link(data) property. Value can be {:Download only headers of message to @link(data) property. Value can be
number of message or message-id (in brackets).} number of message or message-id (in brackets).}
function GetHead(const Value: string): Boolean; function GetHead(const Value: string): Boolean;
{:Get message status. Value can be number of message or message-id {:Get message status. Value can be number of message or message-id
(in brackets).} (in brackets).}
function GetStat(const Value: string): Boolean; function GetStat(const Value: string): Boolean;
{:Select given group.} {:Select given group.}
function SelectGroup(const Value: string): Boolean; function SelectGroup(const Value: string): Boolean;
{:Tell to server 'I have mesage with given message-ID.' If server need this {:Tell to server 'I have mesage with given message-ID.' If server need this
message, message is uploaded to server.} message, message is uploaded to server.}
function IHave(const MessID: string): Boolean; function IHave(const MessID: string): Boolean;
{:Move message pointer to last item in group.} {:Move message pointer to last item in group.}
function GotoLast: Boolean; function GotoLast: Boolean;
{:Move message pointer to next item in group.} {:Move message pointer to next item in group.}
function GotoNext: Boolean; function GotoNext: Boolean;
{:Download to @link(data) property list of all groups on NNTP server.} {:Download to @link(data) property list of all groups on NNTP server.}
function ListGroups: Boolean; function ListGroups: Boolean;
{:Download to @link(data) property list of all groups created after given time.} {:Download to @link(data) property list of all groups created after given time.}
function ListNewGroups(Since: TDateTime): Boolean; function ListNewGroups(Since: TDateTime): Boolean;
{:Download to @link(data) property list of message-ids in given group since {:Download to @link(data) property list of message-ids in given group since
given time.} given time.}
function NewArticles(const Group: string; Since: TDateTime): Boolean; function NewArticles(const Group: string; Since: TDateTime): Boolean;
{:Upload new article to server. (for new messages by you)} {:Upload new article to server. (for new messages by you)}
function PostArticle: Boolean; function PostArticle: Boolean;
{:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP {:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP
server'.} server'.}
function SwitchToSlave: Boolean; function SwitchToSlave: Boolean;
{:Call NNTP XOVER command.} {:Call NNTP XOVER command.}
function Xover(xoStart, xoEnd: string): boolean; function Xover(xoStart, xoEnd: string): boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.} {:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean; function StartTLS: Boolean;
{:Try to find given capability in extension list. This list is getted after {:Try to find given capability in extension list. This list is getted after
successful login to NNTP server. If extension capability is not found, successful login to NNTP server. If extension capability is not found,
then return is empty string.} then return is empty string.}
function FindCap(const Value: string): string; function FindCap(const Value: string): string;
{:Try get list of server extensions. List is returned in @link(data) property.} {:Try get list of server extensions. List is returned in @link(data) property.}
function ListExtensions: Boolean; function ListExtensions: Boolean;
published published
{:Result code number of last operation.} {:Result code number of last operation.}
property ResultCode: Integer read FResultCode; property ResultCode: Integer read FResultCode;
{:String description of last result code from NNTP server.} {:String description of last result code from NNTP server.}
property ResultString: string read FResultString; property ResultString: string read FResultString;
{:Readed data. (message, etc.)} {:Readed data. (message, etc.)}
property Data: TStringList read FData; property Data: TStringList read FData;
{:If is set to @true, then upgrade to SSL/TLS mode after login if remote {:If is set to @true, then upgrade to SSL/TLS mode after login if remote
server support it.} server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full {:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!} SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL; property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock; property Sock: TTCPBlockSocket read FSock;
end; end;
implementation implementation
constructor TNNTPSend.Create; constructor TNNTPSend.Create;
begin begin
inherited Create; inherited Create;
FSock := TTCPBlockSocket.Create; FSock := TTCPBlockSocket.Create;
FSock.Owner := self; FSock.Owner := self;
FData := TStringList.Create; FData := TStringList.Create;
FDataToSend := TStringList.Create; FDataToSend := TStringList.Create;
FNNTPcap := TStringList.Create; FNNTPcap := TStringList.Create;
FSock.ConvertLineEnd := True; FSock.ConvertLineEnd := True;
FTimeout := 60000; FTimeout := 60000;
FTargetPort := cNNTPProtocol; FTargetPort := cNNTPProtocol;
FAutoTLS := False; FAutoTLS := False;
FFullSSL := False; FFullSSL := False;
end; end;
destructor TNNTPSend.Destroy; destructor TNNTPSend.Destroy;
begin begin
FSock.Free; FSock.Free;
FDataToSend.Free; FDataToSend.Free;
FData.Free; FData.Free;
FNNTPcap.Free; FNNTPcap.Free;
inherited Destroy; inherited Destroy;
end; end;
function TNNTPSend.ReadResult: Integer; function TNNTPSend.ReadResult: Integer;
var var
s: string; s: string;
begin begin
Result := 0; Result := 0;
FData.Clear; FData.Clear;
s := FSock.RecvString(FTimeout); s := FSock.RecvString(FTimeout);
FResultString := Copy(s, 5, Length(s) - 4); FResultString := Copy(s, 5, Length(s) - 4);
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
Exit; Exit;
if Length(s) >= 3 then if Length(s) >= 3 then
Result := StrToIntDef(Copy(s, 1, 3), 0); Result := StrToIntDef(Copy(s, 1, 3), 0);
FResultCode := Result; FResultCode := Result;
end; end;
function TNNTPSend.ReadData: boolean; function TNNTPSend.ReadData: boolean;
var var
s: string; s: string;
begin begin
repeat repeat
s := FSock.RecvString(FTimeout); s := FSock.RecvString(FTimeout);
if s = '.' then if s = '.' then
break; break;
if (s <> '') and (s[1] = '.') then if (s <> '') and (s[1] = '.') then
s := Copy(s, 2, Length(s) - 1); s := Copy(s, 2, Length(s) - 1);
FData.Add(s); FData.Add(s);
until FSock.LastError <> 0; until FSock.LastError <> 0;
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
function TNNTPSend.SendData: boolean; function TNNTPSend.SendData: boolean;
var var
s: string; s: string;
n: integer; n: integer;
begin begin
for n := 0 to FDataToSend.Count - 1 do for n := 0 to FDataToSend.Count - 1 do
begin begin
s := FDataToSend[n]; s := FDataToSend[n];
if (s <> '') and (s[1] = '.') then if (s <> '') and (s[1] = '.') then
s := s + '.'; s := s + '.';
FSock.SendString(s + CRLF); FSock.SendString(s + CRLF);
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
break; break;
end; end;
if FDataToSend.Count = 0 then if FDataToSend.Count = 0 then
FSock.SendString(CRLF); FSock.SendString(CRLF);
if FSock.LastError = 0 then if FSock.LastError = 0 then
FSock.SendString('.' + CRLF); FSock.SendString('.' + CRLF);
FDataToSend.Clear; FDataToSend.Clear;
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
function TNNTPSend.Connect: Boolean; function TNNTPSend.Connect: Boolean;
begin begin
FSock.CloseSocket; FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort); FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort); FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then if FSock.LastError = 0 then
if FFullSSL then if FFullSSL then
FSock.SSLDoConnect; FSock.SSLDoConnect;
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
function TNNTPSend.Login: Boolean; function TNNTPSend.Login: Boolean;
begin begin
Result := False; Result := False;
FNNTPcap.Clear; FNNTPcap.Clear;
if not Connect then if not Connect then
Exit; Exit;
Result := (ReadResult div 100) = 2; Result := (ReadResult div 100) = 2;
ListExtensions; ListExtensions;
FNNTPcap.Assign(Fdata); FNNTPcap.Assign(Fdata);
if Result then if Result then
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
Result := StartTLS; Result := StartTLS;
if (FUsername <> '') and Result then if (FUsername <> '') and Result then
begin begin
FSock.SendString('AUTHINFO USER ' + FUsername + CRLF); FSock.SendString('AUTHINFO USER ' + FUsername + CRLF);
if (ReadResult div 100) = 3 then if (ReadResult div 100) = 3 then
begin begin
FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF); FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF);
Result := (ReadResult div 100) = 2; Result := (ReadResult div 100) = 2;
end; end;
end; end;
end; end;
function TNNTPSend.Logout: Boolean; function TNNTPSend.Logout: Boolean;
begin begin
FSock.SendString('QUIT' + CRLF); FSock.SendString('QUIT' + CRLF);
Result := (ReadResult div 100) = 2; Result := (ReadResult div 100) = 2;
FSock.CloseSocket; FSock.CloseSocket;
end; end;
function TNNTPSend.DoCommand(const Command: string): Boolean; function TNNTPSend.DoCommand(const Command: string): Boolean;
begin begin
FSock.SendString(Command + CRLF); FSock.SendString(Command + CRLF);
Result := (ReadResult div 100) = 2; Result := (ReadResult div 100) = 2;
Result := Result and (FSock.LastError = 0); Result := Result and (FSock.LastError = 0);
end; end;
function TNNTPSend.DoCommandRead(const Command: string): Boolean; function TNNTPSend.DoCommandRead(const Command: string): Boolean;
begin begin
Result := DoCommand(Command); Result := DoCommand(Command);
if Result then if Result then
begin begin
Result := ReadData; Result := ReadData;
Result := Result and (FSock.LastError = 0); Result := Result and (FSock.LastError = 0);
end; end;
end; end;
function TNNTPSend.DoCommandWrite(const Command: string): Boolean; function TNNTPSend.DoCommandWrite(const Command: string): Boolean;
var var
x: integer; x: integer;
begin begin
FDataToSend.Assign(FData); FDataToSend.Assign(FData);
FSock.SendString(Command + CRLF); FSock.SendString(Command + CRLF);
x := (ReadResult div 100); x := (ReadResult div 100);
if x = 3 then if x = 3 then
begin begin
SendData; SendData;
x := (ReadResult div 100); x := (ReadResult div 100);
end; end;
Result := x = 2; Result := x = 2;
Result := Result and (FSock.LastError = 0); Result := Result and (FSock.LastError = 0);
end; end;
function TNNTPSend.GetArticle(const Value: string): Boolean; function TNNTPSend.GetArticle(const Value: string): Boolean;
var var
s: string; s: string;
begin begin
s := 'ARTICLE'; s := 'ARTICLE';
if Value <> '' then if Value <> '' then
s := s + ' ' + Value; s := s + ' ' + Value;
Result := DoCommandRead(s); Result := DoCommandRead(s);
end; end;
function TNNTPSend.GetBody(const Value: string): Boolean; function TNNTPSend.GetBody(const Value: string): Boolean;
var var
s: string; s: string;
begin begin
s := 'BODY'; s := 'BODY';
if Value <> '' then if Value <> '' then
s := s + ' ' + Value; s := s + ' ' + Value;
Result := DoCommandRead(s); Result := DoCommandRead(s);
end; end;
function TNNTPSend.GetHead(const Value: string): Boolean; function TNNTPSend.GetHead(const Value: string): Boolean;
var var
s: string; s: string;
begin begin
s := 'HEAD'; s := 'HEAD';
if Value <> '' then if Value <> '' then
s := s + ' ' + Value; s := s + ' ' + Value;
Result := DoCommandRead(s); Result := DoCommandRead(s);
end; end;
function TNNTPSend.GetStat(const Value: string): Boolean; function TNNTPSend.GetStat(const Value: string): Boolean;
var var
s: string; s: string;
begin begin
s := 'STAT'; s := 'STAT';
if Value <> '' then if Value <> '' then
s := s + ' ' + Value; s := s + ' ' + Value;
Result := DoCommand(s); Result := DoCommand(s);
end; end;
function TNNTPSend.SelectGroup(const Value: string): Boolean; function TNNTPSend.SelectGroup(const Value: string): Boolean;
begin begin
Result := DoCommand('GROUP ' + Value); Result := DoCommand('GROUP ' + Value);
end; end;
function TNNTPSend.IHave(const MessID: string): Boolean; function TNNTPSend.IHave(const MessID: string): Boolean;
begin begin
Result := DoCommandWrite('IHAVE ' + MessID); Result := DoCommandWrite('IHAVE ' + MessID);
end; end;
function TNNTPSend.GotoLast: Boolean; function TNNTPSend.GotoLast: Boolean;
begin begin
Result := DoCommand('LAST'); Result := DoCommand('LAST');
end; end;
function TNNTPSend.GotoNext: Boolean; function TNNTPSend.GotoNext: Boolean;
begin begin
Result := DoCommand('NEXT'); Result := DoCommand('NEXT');
end; end;
function TNNTPSend.ListGroups: Boolean; function TNNTPSend.ListGroups: Boolean;
begin begin
Result := DoCommandRead('LIST'); Result := DoCommandRead('LIST');
end; end;
function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean; function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean;
begin begin
Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT'); Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT');
end; end;
function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean; function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean;
begin begin
Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT'); Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT');
end; end;
function TNNTPSend.PostArticle: Boolean; function TNNTPSend.PostArticle: Boolean;
begin begin
Result := DoCommandWrite('POST'); Result := DoCommandWrite('POST');
end; end;
function TNNTPSend.SwitchToSlave: Boolean; function TNNTPSend.SwitchToSlave: Boolean;
begin begin
Result := DoCommand('SLAVE'); Result := DoCommand('SLAVE');
end; end;
function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean; function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean;
var var
s: string; s: string;
begin begin
s := 'XOVER ' + xoStart; s := 'XOVER ' + xoStart;
if xoEnd <> xoStart then if xoEnd <> xoStart then
s := s + '-' + xoEnd; s := s + '-' + xoEnd;
Result := DoCommandRead(s); Result := DoCommandRead(s);
end; end;
function TNNTPSend.StartTLS: Boolean; function TNNTPSend.StartTLS: Boolean;
begin begin
Result := False; Result := False;
if FindCap('STARTTLS') <> '' then if FindCap('STARTTLS') <> '' then
begin begin
if DoCommand('STARTTLS') then if DoCommand('STARTTLS') then
begin begin
Fsock.SSLDoConnect; Fsock.SSLDoConnect;
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
end; end;
end; end;
function TNNTPSend.ListExtensions: Boolean; function TNNTPSend.ListExtensions: Boolean;
begin begin
Result := DoCommandRead('LIST EXTENSIONS'); Result := DoCommandRead('LIST EXTENSIONS');
end; end;
function TNNTPSend.FindCap(const Value: string): string; function TNNTPSend.FindCap(const Value: string): string;
var var
n: Integer; n: Integer;
s: string; s: string;
begin begin
s := UpperCase(Value); s := UpperCase(Value);
Result := ''; Result := '';
for n := 0 to FNNTPcap.Count - 1 do for n := 0 to FNNTPcap.Count - 1 do
if Pos(s, UpperCase(FNNTPcap[n])) = 1 then if Pos(s, UpperCase(FNNTPcap[n])) = 1 then
begin begin
Result := FNNTPcap[n]; Result := FNNTPcap[n];
Break; Break;
end; end;
end; end;
{==============================================================================} {==============================================================================}
end. end.

1440
Units/Synapse/pingsend.pas
View File

File diff suppressed because it is too large Load Diff

966
Units/Synapse/pop3send.pas
View File

@ -1,483 +1,483 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 002.006.002 | | Project : Ararat Synapse | 002.006.002 |
|==============================================================================| |==============================================================================|
| Content: POP3 client | | Content: POP3 client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer | | Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. | | Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@abstract(POP3 protocol client) {:@abstract(POP3 protocol client)
Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595 Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
} }
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$H+} {$H+}
{$M+} {$M+}
{$IFDEF UNICODE} {$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF} {$ENDIF}
unit pop3send; unit pop3send;
interface interface
uses uses
SysUtils, Classes, SysUtils, Classes,
blcksock, synautil, synacode; blcksock, synautil, synacode;
const const
cPop3Protocol = '110'; cPop3Protocol = '110';
type type
{:The three types of possible authorization methods for "logging in" to a POP3 {:The three types of possible authorization methods for "logging in" to a POP3
server.} server.}
TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP); TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
{:@abstract(Implementation of POP3 client protocol.) {:@abstract(Implementation of POP3 client protocol.)
Note: Are you missing properties for setting Username and Password? Look to Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object! parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!} parent @link(TSynaClient) too!}
TPOP3Send = class(TSynaClient) TPOP3Send = class(TSynaClient)
private private
FSock: TTCPBlockSocket; FSock: TTCPBlockSocket;
FResultCode: Integer; FResultCode: Integer;
FResultString: string; FResultString: string;
FFullResult: TStringList; FFullResult: TStringList;
FStatCount: Integer; FStatCount: Integer;
FStatSize: Integer; FStatSize: Integer;
FListSize: Integer; FListSize: Integer;
FTimeStamp: string; FTimeStamp: string;
FAuthType: TPOP3AuthType; FAuthType: TPOP3AuthType;
FPOP3cap: TStringList; FPOP3cap: TStringList;
FAutoTLS: Boolean; FAutoTLS: Boolean;
FFullSSL: Boolean; FFullSSL: Boolean;
function ReadResult(Full: Boolean): Integer; function ReadResult(Full: Boolean): Integer;
function Connect: Boolean; function Connect: Boolean;
function AuthLogin: Boolean; function AuthLogin: Boolean;
function AuthApop: Boolean; function AuthApop: Boolean;
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
{:You can call any custom by this method. Call Command without trailing CRLF. {:You can call any custom by this method. Call Command without trailing CRLF.
If MultiLine parameter is @true, multilined response are expected. If MultiLine parameter is @true, multilined response are expected.
Result is @true on sucess.} Result is @true on sucess.}
function CustomCommand(const Command: string; MultiLine: Boolean): boolean; function CustomCommand(const Command: string; MultiLine: Boolean): boolean;
{:Call CAPA command for get POP3 server capabilites. {:Call CAPA command for get POP3 server capabilites.
note: not all servers support this command!} note: not all servers support this command!}
function Capability: Boolean; function Capability: Boolean;
{:Connect to remote POP3 host. If all OK, result is @true.} {:Connect to remote POP3 host. If all OK, result is @true.}
function Login: Boolean; function Login: Boolean;
{:Disconnects from POP3 server.} {:Disconnects from POP3 server.}
function Logout: Boolean; function Logout: Boolean;
{:Send RSET command. If all OK, result is @true.} {:Send RSET command. If all OK, result is @true.}
function Reset: Boolean; function Reset: Boolean;
{:Send NOOP command. If all OK, result is @true.} {:Send NOOP command. If all OK, result is @true.}
function NoOp: Boolean; function NoOp: Boolean;
{:Send STAT command and fill @link(StatCount) and @link(StatSize) property. {:Send STAT command and fill @link(StatCount) and @link(StatSize) property.
If all OK, result is @true.} If all OK, result is @true.}
function Stat: Boolean; function Stat: Boolean;
{:Send LIST command. If Value is 0, LIST is for all messages. After {: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.} successful operation is listing in FullResult. If all OK, result is @True.}
function List(Value: Integer): Boolean; function List(Value: Integer): Boolean;
{:Send RETR command. After successful operation dowloaded message in {:Send RETR command. After successful operation dowloaded message in
@link(FullResult). If all OK, result is @true.} @link(FullResult). If all OK, result is @true.}
function Retr(Value: Integer): Boolean; function Retr(Value: Integer): Boolean;
{:Send RETR command. After successful operation dowloaded message in {:Send RETR command. After successful operation dowloaded message in
@link(Stream). If all OK, result is @true.} @link(Stream). If all OK, result is @true.}
function RetrStream(Value: Integer; Stream: TStream): Boolean; function RetrStream(Value: Integer; Stream: TStream): Boolean;
{:Send DELE command for delete specified message. If all OK, result is @true.} {:Send DELE command for delete specified message. If all OK, result is @true.}
function Dele(Value: Integer): Boolean; function Dele(Value: Integer): Boolean;
{:Send TOP command. After successful operation dowloaded headers of message {:Send TOP command. After successful operation dowloaded headers of message
and maxlines count of message in @link(FullResult). If all OK, result is and maxlines count of message in @link(FullResult). If all OK, result is
@true.} @true.}
function Top(Value, Maxlines: Integer): Boolean; function Top(Value, Maxlines: Integer): Boolean;
{:Send UIDL command. If Value is 0, UIDL is for all messages. After {: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.} successful operation is listing in FullResult. If all OK, result is @True.}
function Uidl(Value: Integer): Boolean; function Uidl(Value: Integer): Boolean;
{:Call STLS command for upgrade connection to SSL/TLS mode.} {:Call STLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean; function StartTLS: Boolean;
{:Try to find given capabily in capabilty string returned from POP3 server {:Try to find given capabily in capabilty string returned from POP3 server
by CAPA command.} by CAPA command.}
function FindCap(const Value: string): string; function FindCap(const Value: string): string;
published published
{:Result code of last POP3 operation. 0 - error, 1 - OK.} {:Result code of last POP3 operation. 0 - error, 1 - OK.}
property ResultCode: Integer read FResultCode; property ResultCode: Integer read FResultCode;
{:Result string of last POP3 operation.} {:Result string of last POP3 operation.}
property ResultString: string read FResultString; property ResultString: string read FResultString;
{:Stringlist with full lines returned as result of POP3 operation. I.e. if {: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 LIST, this property is filled by list of messages. If
operation is RETR, this property have downloaded message.} operation is RETR, this property have downloaded message.}
property FullResult: TStringList read FFullResult; property FullResult: TStringList read FFullResult;
{:After STAT command is there count of messages in inbox.} {:After STAT command is there count of messages in inbox.}
property StatCount: Integer read FStatCount; property StatCount: Integer read FStatCount;
{:After STAT command is there size of all messages in inbox.} {:After STAT command is there size of all messages in inbox.}
property StatSize: Integer read FStatSize; property StatSize: Integer read FStatSize;
{:After LIST 0 command size of all messages on server, After LIST x size of message x on server} {:After LIST 0 command size of all messages on server, After LIST x size of message x on server}
property ListSize: Integer read FListSize; property ListSize: Integer read FListSize;
{:If server support this, after comnnect is in this property timestamp of {:If server support this, after comnnect is in this property timestamp of
remote server.} remote server.}
property TimeStamp: string read FTimeStamp; property TimeStamp: string read FTimeStamp;
{:Type of authorisation for login to POP3 server. Dafault is autodetect one {:Type of authorisation for login to POP3 server. Dafault is autodetect one
of possible authorisation. Autodetect do this: of possible authorisation. Autodetect do this:
If remote POP3 server support APOP, try login by APOP method. If APOP is 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.} not supported, or if APOP login failed, try classic USER+PASS login method.}
property AuthType: TPOP3AuthType read FAuthType Write FAuthType; property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
{:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.} {:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full {:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!} SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL; property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock; property Sock: TTCPBlockSocket read FSock;
end; end;
implementation implementation
constructor TPOP3Send.Create; constructor TPOP3Send.Create;
begin begin
inherited Create; inherited Create;
FFullResult := TStringList.Create; FFullResult := TStringList.Create;
FPOP3cap := TStringList.Create; FPOP3cap := TStringList.Create;
FSock := TTCPBlockSocket.Create; FSock := TTCPBlockSocket.Create;
FSock.Owner := self; FSock.Owner := self;
FSock.ConvertLineEnd := true; FSock.ConvertLineEnd := true;
FTimeout := 60000; FTimeout := 60000;
FTargetPort := cPop3Protocol; FTargetPort := cPop3Protocol;
FStatCount := 0; FStatCount := 0;
FStatSize := 0; FStatSize := 0;
FListSize := 0; FListSize := 0;
FAuthType := POP3AuthAll; FAuthType := POP3AuthAll;
FAutoTLS := False; FAutoTLS := False;
FFullSSL := False; FFullSSL := False;
end; end;
destructor TPOP3Send.Destroy; destructor TPOP3Send.Destroy;
begin begin
FSock.Free; FSock.Free;
FPOP3cap.Free; FPOP3cap.Free;
FullResult.Free; FullResult.Free;
inherited Destroy; inherited Destroy;
end; end;
function TPOP3Send.ReadResult(Full: Boolean): Integer; function TPOP3Send.ReadResult(Full: Boolean): Integer;
var var
s: AnsiString; s: AnsiString;
begin begin
Result := 0; Result := 0;
FFullResult.Clear; FFullResult.Clear;
s := FSock.RecvString(FTimeout); s := FSock.RecvString(FTimeout);
if Pos('+OK', s) = 1 then if Pos('+OK', s) = 1 then
Result := 1; Result := 1;
FResultString := s; FResultString := s;
if Full and (Result = 1) then if Full and (Result = 1) then
repeat repeat
s := FSock.RecvString(FTimeout); s := FSock.RecvString(FTimeout);
if s = '.' then if s = '.' then
Break; Break;
if s <> '' then if s <> '' then
if s[1] = '.' then if s[1] = '.' then
Delete(s, 1, 1); Delete(s, 1, 1);
FFullResult.Add(s); FFullResult.Add(s);
until FSock.LastError <> 0; until FSock.LastError <> 0;
if not Full and (Result = 1) then if not Full and (Result = 1) then
FFullResult.Add(SeparateRight(FResultString, ' ')); FFullResult.Add(SeparateRight(FResultString, ' '));
if FSock.LastError <> 0 then if FSock.LastError <> 0 then
Result := 0; Result := 0;
FResultCode := Result; FResultCode := Result;
end; end;
function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean; function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean;
begin begin
FSock.SendString(Command + CRLF); FSock.SendString(Command + CRLF);
Result := ReadResult(MultiLine) <> 0; Result := ReadResult(MultiLine) <> 0;
end; end;
function TPOP3Send.AuthLogin: Boolean; function TPOP3Send.AuthLogin: Boolean;
begin begin
Result := False; Result := False;
if not CustomCommand('USER ' + FUserName, False) then if not CustomCommand('USER ' + FUserName, False) then
exit; exit;
Result := CustomCommand('PASS ' + FPassword, False) Result := CustomCommand('PASS ' + FPassword, False)
end; end;
function TPOP3Send.AuthAPOP: Boolean; function TPOP3Send.AuthAPOP: Boolean;
var var
s: string; s: string;
begin begin
s := StrToHex(MD5(FTimeStamp + FPassWord)); s := StrToHex(MD5(FTimeStamp + FPassWord));
Result := CustomCommand('APOP ' + FUserName + ' ' + s, False); Result := CustomCommand('APOP ' + FUserName + ' ' + s, False);
end; end;
function TPOP3Send.Connect: Boolean; function TPOP3Send.Connect: Boolean;
begin begin
// Do not call this function! It is calling by LOGIN method! // Do not call this function! It is calling by LOGIN method!
FStatCount := 0; FStatCount := 0;
FStatSize := 0; FStatSize := 0;
FSock.CloseSocket; FSock.CloseSocket;
FSock.LineBuffer := ''; FSock.LineBuffer := '';
FSock.Bind(FIPInterface, cAnyPort); FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort); FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then if FSock.LastError = 0 then
if FFullSSL then if FFullSSL then
FSock.SSLDoConnect; FSock.SSLDoConnect;
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
function TPOP3Send.Capability: Boolean; function TPOP3Send.Capability: Boolean;
begin begin
FPOP3cap.Clear; FPOP3cap.Clear;
Result := CustomCommand('CAPA', True); Result := CustomCommand('CAPA', True);
if Result then if Result then
FPOP3cap.AddStrings(FFullResult); FPOP3cap.AddStrings(FFullResult);
end; end;
function TPOP3Send.Login: Boolean; function TPOP3Send.Login: Boolean;
var var
s, s1: string; s, s1: string;
begin begin
Result := False; Result := False;
FTimeStamp := ''; FTimeStamp := '';
if not Connect then if not Connect then
Exit; Exit;
if ReadResult(False) <> 1 then if ReadResult(False) <> 1 then
Exit; Exit;
s := SeparateRight(FResultString, '<'); s := SeparateRight(FResultString, '<');
if s <> FResultString then if s <> FResultString then
begin begin
s1 := Trim(SeparateLeft(s, '>')); s1 := Trim(SeparateLeft(s, '>'));
if s1 <> s then if s1 <> s then
FTimeStamp := '<' + s1 + '>'; FTimeStamp := '<' + s1 + '>';
end; end;
Result := False; Result := False;
if Capability then if Capability then
if FAutoTLS and (Findcap('STLS') <> '') then if FAutoTLS and (Findcap('STLS') <> '') then
if StartTLS then if StartTLS then
Capability Capability
else else
begin begin
Result := False; Result := False;
Exit; Exit;
end; end;
if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
begin begin
Result := AuthApop; Result := AuthApop;
if not Result then if not Result then
begin begin
if not Connect then if not Connect then
Exit; Exit;
if ReadResult(False) <> 1 then if ReadResult(False) <> 1 then
Exit; Exit;
end; end;
end; end;
if not Result and not (FAuthType = POP3AuthAPOP) then if not Result and not (FAuthType = POP3AuthAPOP) then
Result := AuthLogin; Result := AuthLogin;
end; end;
function TPOP3Send.Logout: Boolean; function TPOP3Send.Logout: Boolean;
begin begin
Result := CustomCommand('QUIT', False); Result := CustomCommand('QUIT', False);
FSock.CloseSocket; FSock.CloseSocket;
end; end;
function TPOP3Send.Reset: Boolean; function TPOP3Send.Reset: Boolean;
begin begin
Result := CustomCommand('RSET', False); Result := CustomCommand('RSET', False);
end; end;
function TPOP3Send.NoOp: Boolean; function TPOP3Send.NoOp: Boolean;
begin begin
Result := CustomCommand('NOOP', False); Result := CustomCommand('NOOP', False);
end; end;
function TPOP3Send.Stat: Boolean; function TPOP3Send.Stat: Boolean;
var var
s: string; s: string;
begin begin
Result := CustomCommand('STAT', False); Result := CustomCommand('STAT', False);
if Result then if Result then
begin begin
s := SeparateRight(ResultString, '+OK '); s := SeparateRight(ResultString, '+OK ');
FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
end; end;
end; end;
function TPOP3Send.List(Value: Integer): Boolean; function TPOP3Send.List(Value: Integer): Boolean;
var var
s: string; s: string;
n: integer; n: integer;
begin begin
if Value = 0 then if Value = 0 then
s := 'LIST' s := 'LIST'
else else
s := 'LIST ' + IntToStr(Value); s := 'LIST ' + IntToStr(Value);
Result := CustomCommand(s, Value = 0); Result := CustomCommand(s, Value = 0);
FListSize := 0; FListSize := 0;
if Result then if Result then
if Value <> 0 then if Value <> 0 then
begin begin
s := SeparateRight(ResultString, '+OK '); s := SeparateRight(ResultString, '+OK ');
FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
end end
else else
for n := 0 to FFullResult.Count - 1 do for n := 0 to FFullResult.Count - 1 do
FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
end; end;
function TPOP3Send.Retr(Value: Integer): Boolean; function TPOP3Send.Retr(Value: Integer): Boolean;
begin begin
Result := CustomCommand('RETR ' + IntToStr(Value), True); Result := CustomCommand('RETR ' + IntToStr(Value), True);
end; end;
//based on code by Miha Vrhovnik //based on code by Miha Vrhovnik
function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean; function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean;
var var
s: string; s: string;
begin begin
Result := False; Result := False;
FFullResult.Clear; FFullResult.Clear;
Stream.Size := 0; Stream.Size := 0;
FSock.SendString('RETR ' + IntToStr(Value) + CRLF); FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
s := FSock.RecvString(FTimeout); s := FSock.RecvString(FTimeout);
if Pos('+OK', s) = 1 then if Pos('+OK', s) = 1 then
Result := True; Result := True;
FResultString := s; FResultString := s;
if Result then begin if Result then begin
repeat repeat
s := FSock.RecvString(FTimeout); s := FSock.RecvString(FTimeout);
if s = '.' then if s = '.' then
Break; Break;
if s <> '' then begin if s <> '' then begin
if s[1] = '.' then if s[1] = '.' then
Delete(s, 1, 1); Delete(s, 1, 1);
end; end;
WriteStrToStream(Stream, s); WriteStrToStream(Stream, s);
WriteStrToStream(Stream, CRLF); WriteStrToStream(Stream, CRLF);
until FSock.LastError <> 0; until FSock.LastError <> 0;
end; end;
if Result then if Result then
FResultCode := 1 FResultCode := 1
else else
FResultCode := 0; FResultCode := 0;
end; end;
function TPOP3Send.Dele(Value: Integer): Boolean; function TPOP3Send.Dele(Value: Integer): Boolean;
begin begin
Result := CustomCommand('DELE ' + IntToStr(Value), False); Result := CustomCommand('DELE ' + IntToStr(Value), False);
end; end;
function TPOP3Send.Top(Value, Maxlines: Integer): Boolean; function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
begin begin
Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True); Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True);
end; end;
function TPOP3Send.Uidl(Value: Integer): Boolean; function TPOP3Send.Uidl(Value: Integer): Boolean;
var var
s: string; s: string;
begin begin
if Value = 0 then if Value = 0 then
s := 'UIDL' s := 'UIDL'
else else
s := 'UIDL ' + IntToStr(Value); s := 'UIDL ' + IntToStr(Value);
Result := CustomCommand(s, Value = 0); Result := CustomCommand(s, Value = 0);
end; end;
function TPOP3Send.StartTLS: Boolean; function TPOP3Send.StartTLS: Boolean;
begin begin
Result := False; Result := False;
if CustomCommand('STLS', False) then if CustomCommand('STLS', False) then
begin begin
Fsock.SSLDoConnect; Fsock.SSLDoConnect;
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
end; end;
function TPOP3Send.FindCap(const Value: string): string; function TPOP3Send.FindCap(const Value: string): string;
var var
n: Integer; n: Integer;
s: string; s: string;
begin begin
s := UpperCase(Value); s := UpperCase(Value);
Result := ''; Result := '';
for n := 0 to FPOP3cap.Count - 1 do for n := 0 to FPOP3cap.Count - 1 do
if Pos(s, UpperCase(FPOP3cap[n])) = 1 then if Pos(s, UpperCase(FPOP3cap[n])) = 1 then
begin begin
Result := FPOP3cap[n]; Result := FPOP3cap[n];
Break; Break;
end; end;
end; end;
end. end.

640
Units/Synapse/slogsend.pas
View File

@ -1,320 +1,320 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.002.003 | | Project : Ararat Synapse | 001.002.003 |
|==============================================================================| |==============================================================================|
| Content: SysLog client | | Content: SysLog client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer | | Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. | | Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
| Christian Brosius | | Christian Brosius |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@abstract(BSD SYSLOG protocol) {:@abstract(BSD SYSLOG protocol)
Used RFC: RFC-3164 Used RFC: RFC-3164
} }
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$Q-} {$Q-}
{$H+} {$H+}
unit slogsend; unit slogsend;
interface interface
uses uses
SysUtils, Classes, SysUtils, Classes,
blcksock, synautil; blcksock, synautil;
const const
cSysLogProtocol = '514'; cSysLogProtocol = '514';
FCL_Kernel = 0; FCL_Kernel = 0;
FCL_UserLevel = 1; FCL_UserLevel = 1;
FCL_MailSystem = 2; FCL_MailSystem = 2;
FCL_System = 3; FCL_System = 3;
FCL_Security = 4; FCL_Security = 4;
FCL_Syslogd = 5; FCL_Syslogd = 5;
FCL_Printer = 6; FCL_Printer = 6;
FCL_News = 7; FCL_News = 7;
FCL_UUCP = 8; FCL_UUCP = 8;
FCL_Clock = 9; FCL_Clock = 9;
FCL_Authorization = 10; FCL_Authorization = 10;
FCL_FTP = 11; FCL_FTP = 11;
FCL_NTP = 12; FCL_NTP = 12;
FCL_LogAudit = 13; FCL_LogAudit = 13;
FCL_LogAlert = 14; FCL_LogAlert = 14;
FCL_Time = 15; FCL_Time = 15;
FCL_Local0 = 16; FCL_Local0 = 16;
FCL_Local1 = 17; FCL_Local1 = 17;
FCL_Local2 = 18; FCL_Local2 = 18;
FCL_Local3 = 19; FCL_Local3 = 19;
FCL_Local4 = 20; FCL_Local4 = 20;
FCL_Local5 = 21; FCL_Local5 = 21;
FCL_Local6 = 22; FCL_Local6 = 22;
FCL_Local7 = 23; FCL_Local7 = 23;
type type
{:@abstract(Define possible priority of Syslog message)} {:@abstract(Define possible priority of Syslog message)}
TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info, TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
Debug); Debug);
{:@abstract(encoding or decoding of SYSLOG message)} {:@abstract(encoding or decoding of SYSLOG message)}
TSyslogMessage = class(TObject) TSyslogMessage = class(TObject)
private private
FFacility:Byte; FFacility:Byte;
FSeverity:TSyslogSeverity; FSeverity:TSyslogSeverity;
FDateTime:TDateTime; FDateTime:TDateTime;
FTag:String; FTag:String;
FMessage:String; FMessage:String;
FLocalIP:String; FLocalIP:String;
function GetPacketBuf:String; function GetPacketBuf:String;
procedure SetPacketBuf(Value:String); procedure SetPacketBuf(Value:String);
public public
{:Reset values to defaults} {:Reset values to defaults}
procedure Clear; procedure Clear;
published published
{:Define facilicity of Syslog message. For specify you may use predefined {:Define facilicity of Syslog message. For specify you may use predefined
FCL_* constants. Default is "FCL_Local0".} FCL_* constants. Default is "FCL_Local0".}
property Facility:Byte read FFacility write FFacility; property Facility:Byte read FFacility write FFacility;
{:Define possible priority of Syslog message. Default is "Debug".} {:Define possible priority of Syslog message. Default is "Debug".}
property Severity:TSyslogSeverity read FSeverity write FSeverity; property Severity:TSyslogSeverity read FSeverity write FSeverity;
{:date and time of Syslog message} {:date and time of Syslog message}
property DateTime:TDateTime read FDateTime write FDateTime; property DateTime:TDateTime read FDateTime write FDateTime;
{:This is used for identify process of this message. Default is filename {:This is used for identify process of this message. Default is filename
of your executable file.} of your executable file.}
property Tag:String read FTag write FTag; property Tag:String read FTag write FTag;
{:Text of your message for log.} {:Text of your message for log.}
property LogMessage:String read FMessage write FMessage; property LogMessage:String read FMessage write FMessage;
{:IP address of message sender.} {:IP address of message sender.}
property LocalIP:String read FLocalIP write FLocalIP; property LocalIP:String read FLocalIP write FLocalIP;
{:This property holds encoded binary SYSLOG packet} {:This property holds encoded binary SYSLOG packet}
property PacketBuf:String read GetPacketBuf write SetPacketBuf; property PacketBuf:String read GetPacketBuf write SetPacketBuf;
end; end;
{:@abstract(This object implement BSD SysLog client) {:@abstract(This object implement BSD SysLog client)
Note: Are you missing properties for specify server address and port? Look to Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!} parent @link(TSynaClient) too!}
TSyslogSend = class(TSynaClient) TSyslogSend = class(TSynaClient)
private private
FSock: TUDPBlockSocket; FSock: TUDPBlockSocket;
FSysLogMessage: TSysLogMessage; FSysLogMessage: TSysLogMessage;
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
{:Send Syslog UDP packet defined by @link(SysLogMessage).} {:Send Syslog UDP packet defined by @link(SysLogMessage).}
function DoIt: Boolean; function DoIt: Boolean;
published published
{:Syslog message for send} {:Syslog message for send}
property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage; property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage;
end; end;
{:Simply send packet to specified Syslog server.} {:Simply send packet to specified Syslog server.}
function ToSysLog(const SyslogServer: string; Facil: Byte; function ToSysLog(const SyslogServer: string; Facil: Byte;
Sever: TSyslogSeverity; const Content: string): Boolean; Sever: TSyslogSeverity; const Content: string): Boolean;
implementation implementation
function TSyslogMessage.GetPacketBuf:String; function TSyslogMessage.GetPacketBuf:String;
begin begin
Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>'; Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>';
Result := Result + CDateTime(FDateTime) + ' '; Result := Result + CDateTime(FDateTime) + ' ';
Result := Result + FLocalIP + ' '; Result := Result + FLocalIP + ' ';
Result := Result + FTag + ': ' + FMessage; Result := Result + FTag + ': ' + FMessage;
end; end;
procedure TSyslogMessage.SetPacketBuf(Value:String); procedure TSyslogMessage.SetPacketBuf(Value:String);
var StrBuf:String; var StrBuf:String;
IntBuf,Pos:Integer; IntBuf,Pos:Integer;
begin begin
if Length(Value) < 1 then exit; if Length(Value) < 1 then exit;
Pos := 1; Pos := 1;
if Value[Pos] <> '<' then exit; if Value[Pos] <> '<' then exit;
Inc(Pos); Inc(Pos);
// Facility and Severity // Facility and Severity
StrBuf := ''; StrBuf := '';
while (Value[Pos] <> '>')do while (Value[Pos] <> '>')do
begin begin
StrBuf := StrBuf + Value[Pos]; StrBuf := StrBuf + Value[Pos];
Inc(Pos); Inc(Pos);
end; end;
IntBuf := StrToInt(StrBuf); IntBuf := StrToInt(StrBuf);
FFacility := IntBuf div 8; FFacility := IntBuf div 8;
case (IntBuf mod 8)of case (IntBuf mod 8)of
0:FSeverity := Emergency; 0:FSeverity := Emergency;
1:FSeverity := Alert; 1:FSeverity := Alert;
2:FSeverity := Critical; 2:FSeverity := Critical;
3:FSeverity := Error; 3:FSeverity := Error;
4:FSeverity := Warning; 4:FSeverity := Warning;
5:FSeverity := Notice; 5:FSeverity := Notice;
6:FSeverity := Info; 6:FSeverity := Info;
7:FSeverity := Debug; 7:FSeverity := Debug;
end; end;
// DateTime // DateTime
Inc(Pos); Inc(Pos);
StrBuf := ''; StrBuf := '';
// Month // Month
while (Value[Pos] <> ' ')do while (Value[Pos] <> ' ')do
begin begin
StrBuf := StrBuf + Value[Pos]; StrBuf := StrBuf + Value[Pos];
Inc(Pos); Inc(Pos);
end; end;
StrBuf := StrBuf + Value[Pos]; StrBuf := StrBuf + Value[Pos];
Inc(Pos); Inc(Pos);
// Day // Day
while (Value[Pos] <> ' ')do while (Value[Pos] <> ' ')do
begin begin
StrBuf := StrBuf + Value[Pos]; StrBuf := StrBuf + Value[Pos];
Inc(Pos); Inc(Pos);
end; end;
StrBuf := StrBuf + Value[Pos]; StrBuf := StrBuf + Value[Pos];
Inc(Pos); Inc(Pos);
// Time // Time
while (Value[Pos] <> ' ')do while (Value[Pos] <> ' ')do
begin begin
StrBuf := StrBuf + Value[Pos]; StrBuf := StrBuf + Value[Pos];
Inc(Pos); Inc(Pos);
end; end;
FDateTime := DecodeRFCDateTime(StrBuf); FDateTime := DecodeRFCDateTime(StrBuf);
Inc(Pos); Inc(Pos);
// LocalIP // LocalIP
StrBuf := ''; StrBuf := '';
while (Value[Pos] <> ' ')do while (Value[Pos] <> ' ')do
begin begin
StrBuf := StrBuf + Value[Pos]; StrBuf := StrBuf + Value[Pos];
Inc(Pos); Inc(Pos);
end; end;
FLocalIP := StrBuf; FLocalIP := StrBuf;
Inc(Pos); Inc(Pos);
// Tag // Tag
StrBuf := ''; StrBuf := '';
while (Value[Pos] <> ':')do while (Value[Pos] <> ':')do
begin begin
StrBuf := StrBuf + Value[Pos]; StrBuf := StrBuf + Value[Pos];
Inc(Pos); Inc(Pos);
end; end;
FTag := StrBuf; FTag := StrBuf;
// LogMessage // LogMessage
Inc(Pos); Inc(Pos);
StrBuf := ''; StrBuf := '';
while (Pos <= Length(Value))do while (Pos <= Length(Value))do
begin begin
StrBuf := StrBuf + Value[Pos]; StrBuf := StrBuf + Value[Pos];
Inc(Pos); Inc(Pos);
end; end;
FMessage := TrimSP(StrBuf); FMessage := TrimSP(StrBuf);
end; end;
procedure TSysLogMessage.Clear; procedure TSysLogMessage.Clear;
begin begin
FFacility := FCL_Local0; FFacility := FCL_Local0;
FSeverity := Debug; FSeverity := Debug;
FTag := ExtractFileName(ParamStr(0)); FTag := ExtractFileName(ParamStr(0));
FMessage := ''; FMessage := '';
FLocalIP := '0.0.0.0'; FLocalIP := '0.0.0.0';
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
constructor TSyslogSend.Create; constructor TSyslogSend.Create;
begin begin
inherited Create; inherited Create;
FSock := TUDPBlockSocket.Create; FSock := TUDPBlockSocket.Create;
FSock.Owner := self; FSock.Owner := self;
FSysLogMessage := TSysLogMessage.Create; FSysLogMessage := TSysLogMessage.Create;
FTargetPort := cSysLogProtocol; FTargetPort := cSysLogProtocol;
end; end;
destructor TSyslogSend.Destroy; destructor TSyslogSend.Destroy;
begin begin
FSock.Free; FSock.Free;
FSysLogMessage.Free; FSysLogMessage.Free;
inherited Destroy; inherited Destroy;
end; end;
function TSyslogSend.DoIt: Boolean; function TSyslogSend.DoIt: Boolean;
var var
L: TStringList; L: TStringList;
begin begin
Result := False; Result := False;
L := TStringList.Create; L := TStringList.Create;
try try
FSock.ResolveNameToIP(FSock.Localname, L); FSock.ResolveNameToIP(FSock.Localname, L);
if L.Count < 1 then if L.Count < 1 then
FSysLogMessage.LocalIP := '0.0.0.0' FSysLogMessage.LocalIP := '0.0.0.0'
else else
FSysLogMessage.LocalIP := L[0]; FSysLogMessage.LocalIP := L[0];
finally finally
L.Free; L.Free;
end; end;
FSysLogMessage.DateTime := Now; FSysLogMessage.DateTime := Now;
if Length(FSysLogMessage.PacketBuf) <= 1024 then if Length(FSysLogMessage.PacketBuf) <= 1024 then
begin begin
FSock.Connect(FTargetHost, FTargetPort); FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(FSysLogMessage.PacketBuf); FSock.SendString(FSysLogMessage.PacketBuf);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
end; end;
{==============================================================================} {==============================================================================}
function ToSysLog(const SyslogServer: string; Facil: Byte; function ToSysLog(const SyslogServer: string; Facil: Byte;
Sever: TSyslogSeverity; const Content: string): Boolean; Sever: TSyslogSeverity; const Content: string): Boolean;
begin begin
with TSyslogSend.Create do with TSyslogSend.Create do
try try
TargetHost :=SyslogServer; TargetHost :=SyslogServer;
SysLogMessage.Facility := Facil; SysLogMessage.Facility := Facil;
SysLogMessage.Severity := Sever; SysLogMessage.Severity := Sever;
SysLogMessage.LogMessage := Content; SysLogMessage.LogMessage := Content;
Result := DoIt; Result := DoIt;
finally finally
Free; Free;
end; end;
end; end;
end. end.

1450
Units/Synapse/smtpsend.pas
View File

File diff suppressed because it is too large Load Diff

2178
Units/Synapse/snmpsend.pas
View File

File diff suppressed because it is too large Load Diff

748
Units/Synapse/sntpsend.pas
View File

@ -1,374 +1,374 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 003.000.003 | | Project : Ararat Synapse | 003.000.003 |
|==============================================================================| |==============================================================================|
| Content: SNTP client | | Content: SNTP client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer | | Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. | | Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
| Patrick Chevalley | | Patrick Chevalley |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@abstract( NTP and SNTP client) {:@abstract( NTP and SNTP client)
Used RFC: RFC-1305, RFC-2030 Used RFC: RFC-1305, RFC-2030
} }
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$Q-} {$Q-}
{$H+} {$H+}
unit sntpsend; unit sntpsend;
interface interface
uses uses
SysUtils, SysUtils,
synsock, blcksock, synautil; synsock, blcksock, synautil;
const const
cNtpProtocol = '123'; cNtpProtocol = '123';
type type
{:@abstract(Record containing the NTP packet.)} {:@abstract(Record containing the NTP packet.)}
TNtp = packed record TNtp = packed record
mode: Byte; mode: Byte;
stratum: Byte; stratum: Byte;
poll: Byte; poll: Byte;
Precision: Byte; Precision: Byte;
RootDelay: Longint; RootDelay: Longint;
RootDisperson: Longint; RootDisperson: Longint;
RefID: Longint; RefID: Longint;
Ref1: Longint; Ref1: Longint;
Ref2: Longint; Ref2: Longint;
Org1: Longint; Org1: Longint;
Org2: Longint; Org2: Longint;
Rcv1: Longint; Rcv1: Longint;
Rcv2: Longint; Rcv2: Longint;
Xmit1: Longint; Xmit1: Longint;
Xmit2: Longint; Xmit2: Longint;
end; end;
{:@abstract(Implementation of NTP and SNTP client protocol), {:@abstract(Implementation of NTP and SNTP client protocol),
include time synchronisation. It can send NTP or SNTP time queries, or it include time synchronisation. It can send NTP or SNTP time queries, or it
can receive NTP broadcasts too. can receive NTP broadcasts too.
Note: Are you missing properties for specify server address and port? Look to Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!} parent @link(TSynaClient) too!}
TSNTPSend = class(TSynaClient) TSNTPSend = class(TSynaClient)
private private
FNTPReply: TNtp; FNTPReply: TNtp;
FNTPTime: TDateTime; FNTPTime: TDateTime;
FNTPOffset: double; FNTPOffset: double;
FNTPDelay: double; FNTPDelay: double;
FMaxSyncDiff: double; FMaxSyncDiff: double;
FSyncTime: Boolean; FSyncTime: Boolean;
FSock: TUDPBlockSocket; FSock: TUDPBlockSocket;
FBuffer: AnsiString; FBuffer: AnsiString;
FLi, FVn, Fmode : byte; FLi, FVn, Fmode : byte;
function StrToNTP(const Value: AnsiString): TNtp; function StrToNTP(const Value: AnsiString): TNtp;
function NTPtoStr(const Value: Tntp): AnsiString; function NTPtoStr(const Value: Tntp): AnsiString;
procedure ClearNTP(var Value: Tntp); procedure ClearNTP(var Value: Tntp);
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
{:Decode 128 bit timestamp used in NTP packet to TDateTime type.} {:Decode 128 bit timestamp used in NTP packet to TDateTime type.}
function DecodeTs(Nsec, Nfrac: Longint): TDateTime; function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
{:Decode TDateTime type to 128 bit timestamp used in NTP packet.} {:Decode TDateTime type to 128 bit timestamp used in NTP packet.}
procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all {: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 is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
valid.} valid.}
function GetSNTP: Boolean; function GetSNTP: Boolean;
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all {: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 is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
valid. Result time is after all needed corrections.} valid. Result time is after all needed corrections.}
function GetNTP: Boolean; function GetNTP: Boolean;
{:Wait for broadcast NTP packet. If all OK, result is @true and {:Wait for broadcast NTP packet. If all OK, result is @true and
@link(NTPReply) and @link(NTPTime) are valid.} @link(NTPReply) and @link(NTPTime) are valid.}
function GetBroadcastNTP: Boolean; function GetBroadcastNTP: Boolean;
{:Holds last received NTP packet.} {:Holds last received NTP packet.}
property NTPReply: TNtp read FNTPReply; property NTPReply: TNtp read FNTPReply;
published published
{:Date and time of remote NTP or SNTP server. (UTC time!!!)} {:Date and time of remote NTP or SNTP server. (UTC time!!!)}
property NTPTime: TDateTime read FNTPTime; property NTPTime: TDateTime read FNTPTime;
{:Offset between your computer and remote NTP or SNTP server.} {:Offset between your computer and remote NTP or SNTP server.}
property NTPOffset: Double read FNTPOffset; property NTPOffset: Double read FNTPOffset;
{:Delay between your computer and remote NTP or SNTP server.} {:Delay between your computer and remote NTP or SNTP server.}
property NTPDelay: Double read FNTPDelay; property NTPDelay: Double read FNTPDelay;
{:Define allowed maximum difference between your time and remote time for {:Define allowed maximum difference between your time and remote time for
synchronising time. If difference is bigger, your system time is not synchronising time. If difference is bigger, your system time is not
changed!} changed!}
property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff; property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
{:If @true, after successfull getting time is local computer clock {:If @true, after successfull getting time is local computer clock
synchronised to given time. synchronised to given time.
For synchronising time you must have proper rights! (Usually Administrator)} For synchronising time you must have proper rights! (Usually Administrator)}
property SyncTime: Boolean read FSyncTime write FSyncTime; property SyncTime: Boolean read FSyncTime write FSyncTime;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TUDPBlockSocket read FSock; property Sock: TUDPBlockSocket read FSock;
end; end;
implementation implementation
constructor TSNTPSend.Create; constructor TSNTPSend.Create;
begin begin
inherited Create; inherited Create;
FSock := TUDPBlockSocket.Create; FSock := TUDPBlockSocket.Create;
FSock.Owner := self; FSock.Owner := self;
FTimeout := 5000; FTimeout := 5000;
FTargetPort := cNtpProtocol; FTargetPort := cNtpProtocol;
FMaxSyncDiff := 3600; FMaxSyncDiff := 3600;
FSyncTime := False; FSyncTime := False;
end; end;
destructor TSNTPSend.Destroy; destructor TSNTPSend.Destroy;
begin begin
FSock.Free; FSock.Free;
inherited Destroy; inherited Destroy;
end; end;
function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp; function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp;
begin begin
if length(FBuffer) >= SizeOf(Result) then if length(FBuffer) >= SizeOf(Result) then
begin begin
Result.mode := ord(Value[1]); Result.mode := ord(Value[1]);
Result.stratum := ord(Value[2]); Result.stratum := ord(Value[2]);
Result.poll := ord(Value[3]); Result.poll := ord(Value[3]);
Result.Precision := ord(Value[4]); Result.Precision := ord(Value[4]);
Result.RootDelay := DecodeLongInt(value, 5); Result.RootDelay := DecodeLongInt(value, 5);
Result.RootDisperson := DecodeLongInt(value, 9); Result.RootDisperson := DecodeLongInt(value, 9);
Result.RefID := DecodeLongInt(value, 13); Result.RefID := DecodeLongInt(value, 13);
Result.Ref1 := DecodeLongInt(value, 17); Result.Ref1 := DecodeLongInt(value, 17);
Result.Ref2 := DecodeLongInt(value, 21); Result.Ref2 := DecodeLongInt(value, 21);
Result.Org1 := DecodeLongInt(value, 25); Result.Org1 := DecodeLongInt(value, 25);
Result.Org2 := DecodeLongInt(value, 29); Result.Org2 := DecodeLongInt(value, 29);
Result.Rcv1 := DecodeLongInt(value, 33); Result.Rcv1 := DecodeLongInt(value, 33);
Result.Rcv2 := DecodeLongInt(value, 37); Result.Rcv2 := DecodeLongInt(value, 37);
Result.Xmit1 := DecodeLongInt(value, 41); Result.Xmit1 := DecodeLongInt(value, 41);
Result.Xmit2 := DecodeLongInt(value, 45); Result.Xmit2 := DecodeLongInt(value, 45);
end; end;
end; end;
function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString; function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString;
begin begin
SetLength(Result, 4); SetLength(Result, 4);
Result[1] := AnsiChar(Value.mode); Result[1] := AnsiChar(Value.mode);
Result[2] := AnsiChar(Value.stratum); Result[2] := AnsiChar(Value.stratum);
Result[3] := AnsiChar(Value.poll); Result[3] := AnsiChar(Value.poll);
Result[4] := AnsiChar(Value.precision); Result[4] := AnsiChar(Value.precision);
Result := Result + CodeLongInt(Value.RootDelay); Result := Result + CodeLongInt(Value.RootDelay);
Result := Result + CodeLongInt(Value.RootDisperson); Result := Result + CodeLongInt(Value.RootDisperson);
Result := Result + CodeLongInt(Value.RefID); Result := Result + CodeLongInt(Value.RefID);
Result := Result + CodeLongInt(Value.Ref1); Result := Result + CodeLongInt(Value.Ref1);
Result := Result + CodeLongInt(Value.Ref2); Result := Result + CodeLongInt(Value.Ref2);
Result := Result + CodeLongInt(Value.Org1); Result := Result + CodeLongInt(Value.Org1);
Result := Result + CodeLongInt(Value.Org2); Result := Result + CodeLongInt(Value.Org2);
Result := Result + CodeLongInt(Value.Rcv1); Result := Result + CodeLongInt(Value.Rcv1);
Result := Result + CodeLongInt(Value.Rcv2); Result := Result + CodeLongInt(Value.Rcv2);
Result := Result + CodeLongInt(Value.Xmit1); Result := Result + CodeLongInt(Value.Xmit1);
Result := Result + CodeLongInt(Value.Xmit2); Result := Result + CodeLongInt(Value.Xmit2);
end; end;
procedure TSNTPSend.ClearNTP(var Value: Tntp); procedure TSNTPSend.ClearNTP(var Value: Tntp);
begin begin
Value.mode := 0; Value.mode := 0;
Value.stratum := 0; Value.stratum := 0;
Value.poll := 0; Value.poll := 0;
Value.Precision := 0; Value.Precision := 0;
Value.RootDelay := 0; Value.RootDelay := 0;
Value.RootDisperson := 0; Value.RootDisperson := 0;
Value.RefID := 0; Value.RefID := 0;
Value.Ref1 := 0; Value.Ref1 := 0;
Value.Ref2 := 0; Value.Ref2 := 0;
Value.Org1 := 0; Value.Org1 := 0;
Value.Org2 := 0; Value.Org2 := 0;
Value.Rcv1 := 0; Value.Rcv1 := 0;
Value.Rcv2 := 0; Value.Rcv2 := 0;
Value.Xmit1 := 0; Value.Xmit1 := 0;
Value.Xmit2 := 0; Value.Xmit2 := 0;
end; end;
function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime; function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
const const
maxi = 4294967295.0; maxi = 4294967295.0;
var var
d, d1: Double; d, d1: Double;
begin begin
d := Nsec; d := Nsec;
if d < 0 then if d < 0 then
d := maxi + d + 1; d := maxi + d + 1;
d1 := Nfrac; d1 := Nfrac;
if d1 < 0 then if d1 < 0 then
d1 := maxi + d1 + 1; d1 := maxi + d1 + 1;
d1 := d1 / maxi; d1 := d1 / maxi;
d1 := Trunc(d1 * 10000) / 10000; d1 := Trunc(d1 * 10000) / 10000;
Result := (d + d1) / 86400; Result := (d + d1) / 86400;
Result := Result + 2; Result := Result + 2;
end; end;
procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
const const
maxi = 4294967295.0; maxi = 4294967295.0;
maxilongint = 2147483647; maxilongint = 2147483647;
var var
d, d1: Double; d, d1: Double;
begin begin
d := (dt - 2) * 86400; d := (dt - 2) * 86400;
d1 := frac(d); d1 := frac(d);
if d > maxilongint then if d > maxilongint then
d := d - maxi - 1; d := d - maxi - 1;
d := trunc(d); d := trunc(d);
d1 := Trunc(d1 * 10000) / 10000; d1 := Trunc(d1 * 10000) / 10000;
d1 := d1 * maxi; d1 := d1 * maxi;
if d1 > maxilongint then if d1 > maxilongint then
d1 := d1 - maxi - 1; d1 := d1 - maxi - 1;
Nsec:=trunc(d); Nsec:=trunc(d);
Nfrac:=trunc(d1); Nfrac:=trunc(d1);
end; end;
function TSNTPSend.GetBroadcastNTP: Boolean; function TSNTPSend.GetBroadcastNTP: Boolean;
var var
x: Integer; x: Integer;
begin begin
Result := False; Result := False;
FSock.Bind(FIPInterface, FTargetPort); FSock.Bind(FIPInterface, FTargetPort);
FBuffer := FSock.RecvPacket(FTimeout); FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then if FSock.LastError = 0 then
begin begin
x := Length(FBuffer); x := Length(FBuffer);
if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
if x >= SizeOf(NTPReply) then if x >= SizeOf(NTPReply) then
begin begin
FNTPReply := StrToNTP(FBuffer); FNTPReply := StrToNTP(FBuffer);
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime); SetUTTime(FNTPTime);
Result := True; Result := True;
end; end;
end; end;
end; end;
function TSNTPSend.GetSNTP: Boolean; function TSNTPSend.GetSNTP: Boolean;
var var
q: TNtp; q: TNtp;
x: Integer; x: Integer;
begin begin
Result := False; Result := False;
FSock.CloseSocket; FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort); FSock.Connect(FTargetHost, FTargetPort);
ClearNtp(q); ClearNtp(q);
q.mode := $1B; q.mode := $1B;
FBuffer := NTPtoStr(q); FBuffer := NTPtoStr(q);
FSock.SendString(FBuffer); FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout); FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then if FSock.LastError = 0 then
begin begin
x := Length(FBuffer); x := Length(FBuffer);
if x >= SizeOf(NTPReply) then if x >= SizeOf(NTPReply) then
begin begin
FNTPReply := StrToNTP(FBuffer); FNTPReply := StrToNTP(FBuffer);
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime); SetUTTime(FNTPTime);
Result := True; Result := True;
end; end;
end; end;
end; end;
function TSNTPSend.GetNTP: Boolean; function TSNTPSend.GetNTP: Boolean;
var var
q: TNtp; q: TNtp;
x: Integer; x: Integer;
t1, t2, t3, t4 : TDateTime; t1, t2, t3, t4 : TDateTime;
begin begin
Result := False; Result := False;
FSock.CloseSocket; FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort); FSock.Connect(FTargetHost, FTargetPort);
ClearNtp(q); ClearNtp(q);
q.mode := $1B; q.mode := $1B;
t1 := GetUTTime; t1 := GetUTTime;
EncodeTs(t1, q.org1, q.org2); EncodeTs(t1, q.org1, q.org2);
FBuffer := NTPtoStr(q); FBuffer := NTPtoStr(q);
FSock.SendString(FBuffer); FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout); FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then if FSock.LastError = 0 then
begin begin
x := Length(FBuffer); x := Length(FBuffer);
t4 := GetUTTime; t4 := GetUTTime;
if x >= SizeOf(NTPReply) then if x >= SizeOf(NTPReply) then
begin begin
FNTPReply := StrToNTP(FBuffer); FNTPReply := StrToNTP(FBuffer);
FLi := (NTPReply.mode and $C0) shr 6; FLi := (NTPReply.mode and $C0) shr 6;
FVn := (NTPReply.mode and $38) shr 3; FVn := (NTPReply.mode and $38) shr 3;
Fmode := NTPReply.mode and $07; Fmode := NTPReply.mode and $07;
if (Fli < 3) and (Fmode = 4) and if (Fli < 3) and (Fmode = 4) and
(NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and
(NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0) (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0)
then begin then begin
t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2); t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2);
t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
FNTPDelay := (T4 - T1) - (T2 - T3); FNTPDelay := (T4 - T1) - (T2 - T3);
FNTPTime := t3 + FNTPDelay / 2; FNTPTime := t3 + FNTPDelay / 2;
FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400; FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400;
FNTPDelay := FNTPDelay * 86400; FNTPDelay := FNTPDelay * 86400;
if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime); SetUTTime(FNTPTime);
Result := True; Result := True;
end end
else result:=false; else result:=false;
end; end;
end; end;
end; end;
end. end.

2198
Units/Synapse/ssdotnet.pas
View File

File diff suppressed because it is too large Load Diff

1784
Units/Synapse/ssfpc.pas
View File

File diff suppressed because it is too large Load Diff

1138
Units/Synapse/ssl_cryptlib.pas
View File

File diff suppressed because it is too large Load Diff

1650
Units/Synapse/ssl_openssl.pas
View File

File diff suppressed because it is too large Load Diff

4086
Units/Synapse/ssl_openssl_lib.pas
View File

File diff suppressed because it is too large Load Diff

1078
Units/Synapse/ssl_streamsec.pas
View File

File diff suppressed because it is too large Load Diff

2628
Units/Synapse/sslinux.pas
View File

File diff suppressed because it is too large Load Diff

3196
Units/Synapse/sswin32.pas
View File

File diff suppressed because it is too large Load Diff

4070
Units/Synapse/synachar.pas
View File

File diff suppressed because it is too large Load Diff

2920
Units/Synapse/synacode.pas
View File

File diff suppressed because it is too large Load Diff

2456
Units/Synapse/synacrypt.pas
View File

File diff suppressed because it is too large Load Diff

312
Units/Synapse/synadbg.pas
View File

@ -1,156 +1,156 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.001.001 | | Project : Ararat Synapse | 001.001.001 |
|==============================================================================| |==============================================================================|
| Content: Socket debug tools | | Content: Socket debug tools |
|==============================================================================| |==============================================================================|
| Copyright (c)2008-2010, Lukas Gebauer | | Copyright (c)2008-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2008-2010. | | Portions created by Lukas Gebauer are Copyright (c)2008-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@abstract(Socket debug tools) {:@abstract(Socket debug tools)
Routines for help with debugging of events on the Sockets. Routines for help with debugging of events on the Sockets.
} }
{$IFDEF UNICODE} {$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF} {$ENDIF}
unit synadbg; unit synadbg;
interface interface
uses uses
blcksock, synsock, synautil, classes, sysutils; blcksock, synsock, synautil, classes, sysutils;
type type
TSynaDebug = class(TObject) TSynaDebug = class(TObject)
class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
end; end;
procedure AppendToLog(const value: Ansistring); procedure AppendToLog(const value: Ansistring);
var var
LogFile: string; LogFile: string;
implementation implementation
procedure AppendToLog(const value: Ansistring); procedure AppendToLog(const value: Ansistring);
var var
st: TFileStream; st: TFileStream;
s: string; s: string;
h, m, ss, ms: word; h, m, ss, ms: word;
dt: Tdatetime; dt: Tdatetime;
begin begin
if fileexists(LogFile) then if fileexists(LogFile) then
st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite) st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite)
else else
st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite); st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite);
try try
st.Position := st.Size; st.Position := st.Size;
dt := now; dt := now;
decodetime(dt, h, m, ss, ms); decodetime(dt, h, m, ss, ms);
s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value; s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value;
WriteStrToStream(st, s); WriteStrToStream(st, s);
finally finally
st.free; st.free;
end; end;
end; end;
class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
var var
s: string; s: string;
begin begin
case Reason of case Reason of
HR_ResolvingBegin: HR_ResolvingBegin:
s := 'HR_ResolvingBegin'; s := 'HR_ResolvingBegin';
HR_ResolvingEnd: HR_ResolvingEnd:
s := 'HR_ResolvingEnd'; s := 'HR_ResolvingEnd';
HR_SocketCreate: HR_SocketCreate:
s := 'HR_SocketCreate'; s := 'HR_SocketCreate';
HR_SocketClose: HR_SocketClose:
s := 'HR_SocketClose'; s := 'HR_SocketClose';
HR_Bind: HR_Bind:
s := 'HR_Bind'; s := 'HR_Bind';
HR_Connect: HR_Connect:
s := 'HR_Connect'; s := 'HR_Connect';
HR_CanRead: HR_CanRead:
s := 'HR_CanRead'; s := 'HR_CanRead';
HR_CanWrite: HR_CanWrite:
s := 'HR_CanWrite'; s := 'HR_CanWrite';
HR_Listen: HR_Listen:
s := 'HR_Listen'; s := 'HR_Listen';
HR_Accept: HR_Accept:
s := 'HR_Accept'; s := 'HR_Accept';
HR_ReadCount: HR_ReadCount:
s := 'HR_ReadCount'; s := 'HR_ReadCount';
HR_WriteCount: HR_WriteCount:
s := 'HR_WriteCount'; s := 'HR_WriteCount';
HR_Wait: HR_Wait:
s := 'HR_Wait'; s := 'HR_Wait';
HR_Error: HR_Error:
s := 'HR_Error'; s := 'HR_Error';
else else
s := '-unknown-'; s := '-unknown-';
end; end;
s := inttohex(integer(Sender), 8) + s + ': ' + value + CRLF; s := inttohex(integer(Sender), 8) + s + ': ' + value + CRLF;
AppendToLog(s); AppendToLog(s);
end; end;
class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
var var
s, d: Ansistring; s, d: Ansistring;
begin begin
setlength(s, len); setlength(s, len);
move(Buffer^, pointer(s)^, len); move(Buffer^, pointer(s)^, len);
if writing then if writing then
d := '-> ' d := '-> '
else else
d := '<- '; d := '<- ';
s :=inttohex(integer(Sender), 8) + d + s + CRLF; s :=inttohex(integer(Sender), 8) + d + s + CRLF;
AppendToLog(s); AppendToLog(s);
end; end;
initialization initialization
begin begin
Logfile := changefileext(paramstr(0), '.slog'); Logfile := changefileext(paramstr(0), '.slog');
end; end;
end. end.

274
Units/Synapse/synafpc.pas
View File

@ -1,137 +1,137 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.001.002 | | Project : Ararat Synapse | 001.001.002 |
|==============================================================================| |==============================================================================|
| Content: Utils for FreePascal compatibility | | Content: Utils for FreePascal compatibility |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer | | Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. | | Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@exclude} {:@exclude}
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$H+} {$H+}
//old Delphi does not have MSWINDOWS define. //old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32} {$IFDEF WIN32}
{$IFNDEF MSWINDOWS} {$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS} {$DEFINE MSWINDOWS}
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
unit synafpc; unit synafpc;
interface interface
uses uses
{$IFDEF FPC} {$IFDEF FPC}
dynlibs, sysutils; dynlibs, sysutils;
{$ELSE} {$ELSE}
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
Windows; Windows;
{$ELSE} {$ELSE}
SysUtils; SysUtils;
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
{$IFDEF FPC} {$IFDEF FPC}
type type
TLibHandle = dynlibs.TLibHandle; TLibHandle = dynlibs.TLibHandle;
function LoadLibrary(ModuleName: PChar): TLibHandle; function LoadLibrary(ModuleName: PChar): TLibHandle;
function FreeLibrary(Module: TLibHandle): LongBool; function FreeLibrary(Module: TLibHandle): LongBool;
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
{$ELSE} {$ELSE}
type type
{$IFDEF CIL} {$IFDEF CIL}
TLibHandle = Integer; TLibHandle = Integer;
{$ELSE} {$ELSE}
TLibHandle = HModule; TLibHandle = HModule;
{$ENDIF} {$ENDIF}
{$IFDEF VER100} {$IFDEF VER100}
LongWord = DWord; LongWord = DWord;
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
procedure Sleep(milliseconds: Cardinal); procedure Sleep(milliseconds: Cardinal);
implementation implementation
{==============================================================================} {==============================================================================}
{$IFDEF FPC} {$IFDEF FPC}
function LoadLibrary(ModuleName: PChar): TLibHandle; function LoadLibrary(ModuleName: PChar): TLibHandle;
begin begin
Result := dynlibs.LoadLibrary(Modulename); Result := dynlibs.LoadLibrary(Modulename);
end; end;
function FreeLibrary(Module: TLibHandle): LongBool; function FreeLibrary(Module: TLibHandle): LongBool;
begin begin
Result := dynlibs.UnloadLibrary(Module); Result := dynlibs.UnloadLibrary(Module);
end; end;
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
begin begin
Result := dynlibs.GetProcedureAddress(Module, Proc); Result := dynlibs.GetProcedureAddress(Module, Proc);
end; end;
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
begin begin
Result := 0; Result := 0;
end; end;
{$ELSE} {$ELSE}
{$ENDIF} {$ENDIF}
procedure Sleep(milliseconds: Cardinal); procedure Sleep(milliseconds: Cardinal);
begin begin
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
{$IFDEF FPC} {$IFDEF FPC}
sysutils.sleep(milliseconds); sysutils.sleep(milliseconds);
{$ELSE} {$ELSE}
windows.sleep(milliseconds); windows.sleep(milliseconds);
{$ENDIF} {$ENDIF}
{$ELSE} {$ELSE}
sysutils.sleep(milliseconds); sysutils.sleep(milliseconds);
{$ENDIF} {$ENDIF}
end; end;
end. end.

726
Units/Synapse/synaicnv.pas
View File

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

844
Units/Synapse/synaip.pas
View File

@ -1,422 +1,422 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.002.001 | | Project : Ararat Synapse | 001.002.001 |
|==============================================================================| |==============================================================================|
| Content: IP address support procedures and functions | | Content: IP address support procedures and functions |
|==============================================================================| |==============================================================================|
| Copyright (c)2006-2010, Lukas Gebauer | | Copyright (c)2006-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 2006-2010. | | Portions created by Lukas Gebauer are Copyright (c) 2006-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@abstract(IP adress support procedures and functions)} {:@abstract(IP adress support procedures and functions)}
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$Q-} {$Q-}
{$R-} {$R-}
{$H+} {$H+}
{$IFDEF UNICODE} {$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF} {$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF} {$ENDIF}
unit synaip; unit synaip;
interface interface
uses uses
SysUtils, SynaUtil; SysUtils, SynaUtil;
type type
{:binary form of IPv6 adress (for string conversion routines)} {:binary form of IPv6 adress (for string conversion routines)}
TIp6Bytes = array [0..15] of Byte; TIp6Bytes = array [0..15] of Byte;
{:binary form of IPv6 adress (for string conversion routines)} {:binary form of IPv6 adress (for string conversion routines)}
TIp6Words = array [0..7] of Word; TIp6Words = array [0..7] of Word;
{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!} {:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
function IsIP(const Value: string): Boolean; function IsIP(const Value: string): Boolean;
{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!} {:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
function IsIP6(const Value: string): Boolean; function IsIP6(const Value: string): Boolean;
{:Returns a string with the "Host" ip address converted to binary form.} {:Returns a string with the "Host" ip address converted to binary form.}
function IPToID(Host: string): Ansistring; function IPToID(Host: string): Ansistring;
{:Convert IPv6 address from their string form to binary byte array.} {:Convert IPv6 address from their string form to binary byte array.}
function StrToIp6(value: string): TIp6Bytes; function StrToIp6(value: string): TIp6Bytes;
{:Convert IPv6 address from binary byte array to string form.} {:Convert IPv6 address from binary byte array to string form.}
function Ip6ToStr(value: TIp6Bytes): string; function Ip6ToStr(value: TIp6Bytes): string;
{:Convert IPv4 address from their string form to binary.} {:Convert IPv4 address from their string form to binary.}
function StrToIp(value: string): integer; function StrToIp(value: string): integer;
{:Convert IPv4 address from binary to string form.} {:Convert IPv4 address from binary to string form.}
function IpToStr(value: integer): string; function IpToStr(value: integer): string;
{:Convert IPv4 address to reverse form.} {:Convert IPv4 address to reverse form.}
function ReverseIP(Value: AnsiString): AnsiString; function ReverseIP(Value: AnsiString): AnsiString;
{:Convert IPv6 address to reverse form.} {:Convert IPv6 address to reverse form.}
function ReverseIP6(Value: AnsiString): AnsiString; function ReverseIP6(Value: AnsiString): AnsiString;
{:Expand short form of IPv6 address to long form.} {:Expand short form of IPv6 address to long form.}
function ExpandIP6(Value: AnsiString): AnsiString; function ExpandIP6(Value: AnsiString): AnsiString;
implementation implementation
{==============================================================================} {==============================================================================}
function IsIP(const Value: string): Boolean; function IsIP(const Value: string): Boolean;
var var
TempIP: string; TempIP: string;
function ByteIsOk(const Value: string): Boolean; function ByteIsOk(const Value: string): Boolean;
var var
x, n: integer; x, n: integer;
begin begin
x := StrToIntDef(Value, -1); x := StrToIntDef(Value, -1);
Result := (x >= 0) and (x < 256); Result := (x >= 0) and (x < 256);
// X may be in correct range, but value still may not be correct value! // X may be in correct range, but value still may not be correct value!
// i.e. "$80" // i.e. "$80"
if Result then if Result then
for n := 1 to length(Value) do for n := 1 to length(Value) do
if not (AnsiChar(Value[n]) in ['0'..'9']) then if not (AnsiChar(Value[n]) in ['0'..'9']) then
begin begin
Result := False; Result := False;
Break; Break;
end; end;
end; end;
begin begin
TempIP := Value; TempIP := Value;
Result := False; Result := False;
if not ByteIsOk(Fetch(TempIP, '.')) then if not ByteIsOk(Fetch(TempIP, '.')) then
Exit; Exit;
if not ByteIsOk(Fetch(TempIP, '.')) then if not ByteIsOk(Fetch(TempIP, '.')) then
Exit; Exit;
if not ByteIsOk(Fetch(TempIP, '.')) then if not ByteIsOk(Fetch(TempIP, '.')) then
Exit; Exit;
if ByteIsOk(TempIP) then if ByteIsOk(TempIP) then
Result := True; Result := True;
end; end;
{==============================================================================} {==============================================================================}
function IsIP6(const Value: string): Boolean; function IsIP6(const Value: string): Boolean;
var var
TempIP: string; TempIP: string;
s,t: string; s,t: string;
x: integer; x: integer;
partcount: integer; partcount: integer;
zerocount: integer; zerocount: integer;
First: Boolean; First: Boolean;
begin begin
TempIP := Value; TempIP := Value;
Result := False; Result := False;
if Value = '::' then if Value = '::' then
begin begin
Result := True; Result := True;
Exit; Exit;
end; end;
partcount := 0; partcount := 0;
zerocount := 0; zerocount := 0;
First := True; First := True;
while tempIP <> '' do while tempIP <> '' do
begin begin
s := fetch(TempIP, ':'); s := fetch(TempIP, ':');
if not(First) and (s = '') then if not(First) and (s = '') then
Inc(zerocount); Inc(zerocount);
First := False; First := False;
if zerocount > 1 then if zerocount > 1 then
break; break;
Inc(partCount); Inc(partCount);
if s = '' then if s = '' then
Continue; Continue;
if partCount > 8 then if partCount > 8 then
break; break;
if tempIP = '' then if tempIP = '' then
begin begin
t := SeparateRight(s, '%'); t := SeparateRight(s, '%');
s := SeparateLeft(s, '%'); s := SeparateLeft(s, '%');
x := StrToIntDef('$' + t, -1); x := StrToIntDef('$' + t, -1);
if (x < 0) or (x > $ffff) then if (x < 0) or (x > $ffff) then
break; break;
end; end;
x := StrToIntDef('$' + s, -1); x := StrToIntDef('$' + s, -1);
if (x < 0) or (x > $ffff) then if (x < 0) or (x > $ffff) then
break; break;
if tempIP = '' then if tempIP = '' then
if not((PartCount = 1) and (ZeroCount = 0)) then if not((PartCount = 1) and (ZeroCount = 0)) then
Result := True; Result := True;
end; end;
end; end;
{==============================================================================} {==============================================================================}
function IPToID(Host: string): Ansistring; function IPToID(Host: string): Ansistring;
var var
s: string; s: string;
i, x: Integer; i, x: Integer;
begin begin
Result := ''; Result := '';
for x := 0 to 3 do for x := 0 to 3 do
begin begin
s := Fetch(Host, '.'); s := Fetch(Host, '.');
i := StrToIntDef(s, 0); i := StrToIntDef(s, 0);
Result := Result + AnsiChar(i); Result := Result + AnsiChar(i);
end; end;
end; end;
{==============================================================================} {==============================================================================}
function StrToIp(value: string): integer; function StrToIp(value: string): integer;
var var
s: string; s: string;
i, x: Integer; i, x: Integer;
begin begin
Result := 0; Result := 0;
for x := 0 to 3 do for x := 0 to 3 do
begin begin
s := Fetch(value, '.'); s := Fetch(value, '.');
i := StrToIntDef(s, 0); i := StrToIntDef(s, 0);
Result := (256 * Result) + i; Result := (256 * Result) + i;
end; end;
end; end;
{==============================================================================} {==============================================================================}
function IpToStr(value: integer): string; function IpToStr(value: integer): string;
var var
x1, x2: word; x1, x2: word;
y1, y2: byte; y1, y2: byte;
begin begin
Result := ''; Result := '';
x1 := value shr 16; x1 := value shr 16;
x2 := value and $FFFF; x2 := value and $FFFF;
y1 := x1 div $100; y1 := x1 div $100;
y2 := x1 mod $100; y2 := x1 mod $100;
Result := inttostr(y1) + '.' + inttostr(y2) + '.'; Result := inttostr(y1) + '.' + inttostr(y2) + '.';
y1 := x2 div $100; y1 := x2 div $100;
y2 := x2 mod $100; y2 := x2 mod $100;
Result := Result + inttostr(y1) + '.' + inttostr(y2); Result := Result + inttostr(y1) + '.' + inttostr(y2);
end; end;
{==============================================================================} {==============================================================================}
function ExpandIP6(Value: AnsiString): AnsiString; function ExpandIP6(Value: AnsiString): AnsiString;
var var
n: integer; n: integer;
s: ansistring; s: ansistring;
x: integer; x: integer;
begin begin
Result := ''; Result := '';
if value = '' then if value = '' then
exit; exit;
x := countofchar(value, ':'); x := countofchar(value, ':');
if x > 7 then if x > 7 then
exit; exit;
if value[1] = ':' then if value[1] = ':' then
value := '0' + value; value := '0' + value;
if value[length(value)] = ':' then if value[length(value)] = ':' then
value := value + '0'; value := value + '0';
x := 8 - x; x := 8 - x;
s := ''; s := '';
for n := 1 to x do for n := 1 to x do
s := s + ':0'; s := s + ':0';
s := s + ':'; s := s + ':';
Result := replacestring(value, '::', s); Result := replacestring(value, '::', s);
end; end;
{==============================================================================} {==============================================================================}
function StrToIp6(Value: string): TIp6Bytes; function StrToIp6(Value: string): TIp6Bytes;
var var
IPv6: TIp6Words; IPv6: TIp6Words;
Index: Integer; Index: Integer;
n: integer; n: integer;
b1, b2: byte; b1, b2: byte;
s: string; s: string;
x: integer; x: integer;
begin begin
for n := 0 to 15 do for n := 0 to 15 do
Result[n] := 0; Result[n] := 0;
for n := 0 to 7 do for n := 0 to 7 do
Ipv6[n] := 0; Ipv6[n] := 0;
Index := 0; Index := 0;
Value := ExpandIP6(value); Value := ExpandIP6(value);
if value = '' then if value = '' then
exit; exit;
while Value <> '' do while Value <> '' do
begin begin
if Index > 7 then if Index > 7 then
Exit; Exit;
s := fetch(value, ':'); s := fetch(value, ':');
if s = '@' then if s = '@' then
break; break;
if s = '' then if s = '' then
begin begin
IPv6[Index] := 0; IPv6[Index] := 0;
end end
else else
begin begin
x := StrToIntDef('$' + s, -1); x := StrToIntDef('$' + s, -1);
if (x > 65535) or (x < 0) then if (x > 65535) or (x < 0) then
Exit; Exit;
IPv6[Index] := x; IPv6[Index] := x;
end; end;
Inc(Index); Inc(Index);
end; end;
for n := 0 to 7 do for n := 0 to 7 do
begin begin
b1 := ipv6[n] div 256; b1 := ipv6[n] div 256;
b2 := ipv6[n] mod 256; b2 := ipv6[n] mod 256;
Result[n * 2] := b1; Result[n * 2] := b1;
Result[(n * 2) + 1] := b2; Result[(n * 2) + 1] := b2;
end; end;
end; end;
{==============================================================================} {==============================================================================}
//based on routine by the Free Pascal development team //based on routine by the Free Pascal development team
function Ip6ToStr(value: TIp6Bytes): string; function Ip6ToStr(value: TIp6Bytes): string;
var var
i, x: byte; i, x: byte;
zr1,zr2: set of byte; zr1,zr2: set of byte;
zc1,zc2: byte; zc1,zc2: byte;
have_skipped: boolean; have_skipped: boolean;
ip6w: TIp6words; ip6w: TIp6words;
begin begin
zr1 := []; zr1 := [];
zr2 := []; zr2 := [];
zc1 := 0; zc1 := 0;
zc2 := 0; zc2 := 0;
for i := 0 to 7 do for i := 0 to 7 do
begin begin
x := i * 2; x := i * 2;
ip6w[i] := value[x] * 256 + value[x + 1]; ip6w[i] := value[x] * 256 + value[x + 1];
if ip6w[i] = 0 then if ip6w[i] = 0 then
begin begin
include(zr2, i); include(zr2, i);
inc(zc2); inc(zc2);
end end
else else
begin begin
if zc1 < zc2 then if zc1 < zc2 then
begin begin
zc1 := zc2; zc1 := zc2;
zr1 := zr2; zr1 := zr2;
zc2 := 0; zc2 := 0;
zr2 := []; zr2 := [];
end; end;
end; end;
end; end;
if zc1 < zc2 then if zc1 < zc2 then
begin begin
zr1 := zr2; zr1 := zr2;
end; end;
SetLength(Result, 8*5-1); SetLength(Result, 8*5-1);
SetLength(Result, 0); SetLength(Result, 0);
have_skipped := false; have_skipped := false;
for i := 0 to 7 do for i := 0 to 7 do
begin begin
if not(i in zr1) then if not(i in zr1) then
begin begin
if have_skipped then if have_skipped then
begin begin
if Result = '' then if Result = '' then
Result := '::' Result := '::'
else else
Result := Result + ':'; Result := Result + ':';
have_skipped := false; have_skipped := false;
end; end;
Result := Result + IntToHex(Ip6w[i], 1) + ':'; Result := Result + IntToHex(Ip6w[i], 1) + ':';
end end
else else
begin begin
have_skipped := true; have_skipped := true;
end; end;
end; end;
if have_skipped then if have_skipped then
if Result = '' then if Result = '' then
Result := '::0' Result := '::0'
else else
Result := Result + ':'; Result := Result + ':';
if Result = '' then if Result = '' then
Result := '::0'; Result := '::0';
if not (7 in zr1) then if not (7 in zr1) then
SetLength(Result, Length(Result)-1); SetLength(Result, Length(Result)-1);
Result := LowerCase(result); Result := LowerCase(result);
end; end;
{==============================================================================} {==============================================================================}
function ReverseIP(Value: AnsiString): AnsiString; function ReverseIP(Value: AnsiString): AnsiString;
var var
x: Integer; x: Integer;
begin begin
Result := ''; Result := '';
repeat repeat
x := LastDelimiter('.', Value); x := LastDelimiter('.', Value);
Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x); Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
Delete(Value, x, Length(Value) - x + 1); Delete(Value, x, Length(Value) - x + 1);
until x < 1; until x < 1;
if Length(Result) > 0 then if Length(Result) > 0 then
if Result[1] = '.' then if Result[1] = '.' then
Delete(Result, 1, 1); Delete(Result, 1, 1);
end; end;
{==============================================================================} {==============================================================================}
function ReverseIP6(Value: AnsiString): AnsiString; function ReverseIP6(Value: AnsiString): AnsiString;
var var
ip6: TIp6bytes; ip6: TIp6bytes;
n: integer; n: integer;
x, y: integer; x, y: integer;
begin begin
ip6 := StrToIP6(Value); ip6 := StrToIP6(Value);
x := ip6[15] div 16; x := ip6[15] div 16;
y := ip6[15] mod 16; y := ip6[15] mod 16;
Result := IntToHex(y, 1) + '.' + IntToHex(x, 1); Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
for n := 14 downto 0 do for n := 14 downto 0 do
begin begin
x := ip6[n] div 16; x := ip6[n] div 16;
y := ip6[n] mod 16; y := ip6[n] mod 16;
Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1); Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
end; end;
end; end;
{==============================================================================} {==============================================================================}
end. end.

788
Units/Synapse/synamisc.pas
View File

@ -1,394 +1,394 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.003.000 | | Project : Ararat Synapse | 001.003.000 |
|==============================================================================| |==============================================================================|
| Content: misc. procedures and functions | | Content: misc. procedures and functions |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer | | Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 2002-2010. | | Portions created by Lukas Gebauer are Copyright (c) 2002-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@abstract(Misc. network based utilities)} {:@abstract(Misc. network based utilities)}
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$Q-} {$Q-}
{$H+} {$H+}
{$IFDEF UNICODE} {$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF} {$ENDIF}
unit synamisc; unit synamisc;
interface interface
{$IFDEF VER125} {$IFDEF VER125}
{$DEFINE BCB} {$DEFINE BCB}
{$ENDIF} {$ENDIF}
{$IFDEF BCB} {$IFDEF BCB}
{$ObjExportAll On} {$ObjExportAll On}
{$HPPEMIT '#pragma comment( lib , "wininet.lib" )'} {$HPPEMIT '#pragma comment( lib , "wininet.lib" )'}
{$ENDIF} {$ENDIF}
uses uses
synautil, blcksock, SysUtils, Classes, synautil, blcksock, SysUtils, Classes,
{$IFDEF LINUX} {$IFDEF LINUX}
Libc; Libc;
{$ELSE} {$ELSE}
Windows; Windows;
{$ENDIF} {$ENDIF}
Type Type
{:@abstract(This record contains information about proxy setting.)} {:@abstract(This record contains information about proxy setting.)}
TProxySetting = record TProxySetting = record
Host: string; Host: string;
Port: string; Port: string;
Bypass: string; Bypass: string;
end; end;
{:By this function you can turn-on computer on network, if this computer {: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) 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 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 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 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 computer on another network, you must specify any existing IP addres on same
network segment as targeting computer.} network segment as targeting computer.}
procedure WakeOnLan(MAC, IP: string); procedure WakeOnLan(MAC, IP: string);
{:Autodetect current DNS servers used by system. If is defined more then one DNS {:Autodetect current DNS servers used by system. If is defined more then one DNS
server, then result is comma-delimited.} server, then result is comma-delimited.}
function GetDNS: string; function GetDNS: string;
{:Autodetect InternetExplorer proxy setting for given protocol. This function {:Autodetect InternetExplorer proxy setting for given protocol. This function
working only on windows!} working only on windows!}
function GetIEProxy(protocol: string): TProxySetting; function GetIEProxy(protocol: string): TProxySetting;
{:Return all known IP addresses on local system. Addresses are divided by comma.} {:Return all known IP addresses on local system. Addresses are divided by comma.}
function GetLocalIPs: string; function GetLocalIPs: string;
implementation implementation
{==============================================================================} {==============================================================================}
procedure WakeOnLan(MAC, IP: string); procedure WakeOnLan(MAC, IP: string);
var var
sock: TUDPBlockSocket; sock: TUDPBlockSocket;
HexMac: Ansistring; HexMac: Ansistring;
data: Ansistring; data: Ansistring;
n: integer; n: integer;
b: Byte; b: Byte;
begin begin
if MAC <> '' then if MAC <> '' then
begin begin
MAC := ReplaceString(MAC, '-', ''); MAC := ReplaceString(MAC, '-', '');
MAC := ReplaceString(MAC, ':', ''); MAC := ReplaceString(MAC, ':', '');
if Length(MAC) < 12 then if Length(MAC) < 12 then
Exit; Exit;
HexMac := ''; HexMac := '';
for n := 0 to 5 do for n := 0 to 5 do
begin begin
b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0); b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0);
HexMac := HexMac + char(b); HexMac := HexMac + char(b);
end; end;
if IP = '' then if IP = '' then
IP := cBroadcast; IP := cBroadcast;
sock := TUDPBlockSocket.Create; sock := TUDPBlockSocket.Create;
try try
sock.CreateSocket; sock.CreateSocket;
sock.EnableBroadcast(true); sock.EnableBroadcast(true);
sock.Connect(IP, '9'); sock.Connect(IP, '9');
data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF; data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF;
for n := 1 to 16 do for n := 1 to 16 do
data := data + HexMac; data := data + HexMac;
sock.SendString(data); sock.SendString(data);
finally finally
sock.Free; sock.Free;
end; end;
end; end;
end; end;
{==============================================================================} {==============================================================================}
{$IFNDEF LINUX} {$IFNDEF LINUX}
function GetDNSbyIpHlp: string; function GetDNSbyIpHlp: string;
type type
PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING; PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING;
TIP_ADDRESS_STRING = array[0..15] of Ansichar; TIP_ADDRESS_STRING = array[0..15] of Ansichar;
PTIP_ADDR_STRING = ^TIP_ADDR_STRING; PTIP_ADDR_STRING = ^TIP_ADDR_STRING;
TIP_ADDR_STRING = packed record TIP_ADDR_STRING = packed record
Next: PTIP_ADDR_STRING; Next: PTIP_ADDR_STRING;
IpAddress: TIP_ADDRESS_STRING; IpAddress: TIP_ADDRESS_STRING;
IpMask: TIP_ADDRESS_STRING; IpMask: TIP_ADDRESS_STRING;
Context: DWORD; Context: DWORD;
end; end;
PTFixedInfo = ^TFixedInfo; PTFixedInfo = ^TFixedInfo;
TFixedInfo = packed record TFixedInfo = packed record
HostName: array[1..128 + 4] of Ansichar; HostName: array[1..128 + 4] of Ansichar;
DomainName: array[1..128 + 4] of Ansichar; DomainName: array[1..128 + 4] of Ansichar;
CurrentDNSServer: PTIP_ADDR_STRING; CurrentDNSServer: PTIP_ADDR_STRING;
DNSServerList: TIP_ADDR_STRING; DNSServerList: TIP_ADDR_STRING;
NodeType: UINT; NodeType: UINT;
ScopeID: array[1..256 + 4] of Ansichar; ScopeID: array[1..256 + 4] of Ansichar;
EnableRouting: UINT; EnableRouting: UINT;
EnableProxy: UINT; EnableProxy: UINT;
EnableDNS: UINT; EnableDNS: UINT;
end; end;
const const
IpHlpDLL = 'IPHLPAPI.DLL'; IpHlpDLL = 'IPHLPAPI.DLL';
var var
IpHlpModule: THandle; IpHlpModule: THandle;
FixedInfo: PTFixedInfo; FixedInfo: PTFixedInfo;
InfoSize: Longint; InfoSize: Longint;
PDnsServer: PTIP_ADDR_STRING; PDnsServer: PTIP_ADDR_STRING;
err: integer; err: integer;
GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall; GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall;
begin begin
InfoSize := 0; InfoSize := 0;
Result := '...'; Result := '...';
IpHlpModule := LoadLibrary(IpHlpDLL); IpHlpModule := LoadLibrary(IpHlpDLL);
if IpHlpModule = 0 then if IpHlpModule = 0 then
exit; exit;
try try
GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams'))); GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams')));
if @GetNetworkParams = nil then if @GetNetworkParams = nil then
Exit; Exit;
err := GetNetworkParams(Nil, @InfoSize); err := GetNetworkParams(Nil, @InfoSize);
if err <> ERROR_BUFFER_OVERFLOW then if err <> ERROR_BUFFER_OVERFLOW then
Exit; Exit;
Result := ''; Result := '';
GetMem (FixedInfo, InfoSize); GetMem (FixedInfo, InfoSize);
try try
err := GetNetworkParams(FixedInfo, @InfoSize); err := GetNetworkParams(FixedInfo, @InfoSize);
if err <> ERROR_SUCCESS then if err <> ERROR_SUCCESS then
exit; exit;
with FixedInfo^ do with FixedInfo^ do
begin begin
Result := DnsServerList.IpAddress; Result := DnsServerList.IpAddress;
PDnsServer := DnsServerList.Next; PDnsServer := DnsServerList.Next;
while PDnsServer <> Nil do while PDnsServer <> Nil do
begin begin
if Result <> '' then if Result <> '' then
Result := Result + ','; Result := Result + ',';
Result := Result + PDnsServer^.IPAddress; Result := Result + PDnsServer^.IPAddress;
PDnsServer := PDnsServer.Next; PDnsServer := PDnsServer.Next;
end; end;
end; end;
finally finally
FreeMem(FixedInfo); FreeMem(FixedInfo);
end; end;
finally finally
FreeLibrary(IpHlpModule); FreeLibrary(IpHlpModule);
end; end;
end; end;
function ReadReg(SubKey, Vn: PChar): string; function ReadReg(SubKey, Vn: PChar): string;
var var
OpenKey: HKEY; OpenKey: HKEY;
DataType, DataSize: integer; DataType, DataSize: integer;
Temp: array [0..2048] of char; Temp: array [0..2048] of char;
begin begin
Result := ''; Result := '';
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE, if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE,
KEY_READ, OpenKey) = ERROR_SUCCESS then KEY_READ, OpenKey) = ERROR_SUCCESS then
begin begin
DataType := REG_SZ; DataType := REG_SZ;
DataSize := SizeOf(Temp); DataSize := SizeOf(Temp);
if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then
SetString(Result, Temp, DataSize div SizeOf(Char) - 1); SetString(Result, Temp, DataSize div SizeOf(Char) - 1);
RegCloseKey(OpenKey); RegCloseKey(OpenKey);
end; end;
end ; end ;
{$ENDIF} {$ENDIF}
function GetDNS: string; function GetDNS: string;
{$IFDEF LINUX} {$IFDEF LINUX}
var var
l: TStringList; l: TStringList;
n: integer; n: integer;
begin begin
Result := ''; Result := '';
l := TStringList.Create; l := TStringList.Create;
try try
l.LoadFromFile('/etc/resolv.conf'); l.LoadFromFile('/etc/resolv.conf');
for n := 0 to l.Count - 1 do for n := 0 to l.Count - 1 do
if Pos('NAMESERVER', uppercase(l[n])) = 1 then if Pos('NAMESERVER', uppercase(l[n])) = 1 then
begin begin
if Result <> '' then if Result <> '' then
Result := Result + ','; Result := Result + ',';
Result := Result + SeparateRight(l[n], ' '); Result := Result + SeparateRight(l[n], ' ');
end; end;
finally finally
l.Free; l.Free;
end; end;
end; end;
{$ELSE} {$ELSE}
const const
NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary'; NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary';
NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters'; NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters';
W9xfix = 'System\CurrentControlSet\Services\MSTCP'; W9xfix = 'System\CurrentControlSet\Services\MSTCP';
begin begin
Result := GetDNSbyIpHlp; Result := GetDNSbyIpHlp;
if Result = '...' then if Result = '...' then
begin begin
if Win32Platform = VER_PLATFORM_WIN32_NT then if Win32Platform = VER_PLATFORM_WIN32_NT then
begin begin
Result := ReadReg(NTdyn, 'NameServer'); Result := ReadReg(NTdyn, 'NameServer');
if result = '' then if result = '' then
Result := ReadReg(NTfix, 'NameServer'); Result := ReadReg(NTfix, 'NameServer');
if result = '' then if result = '' then
Result := ReadReg(NTfix, 'DhcpNameServer'); Result := ReadReg(NTfix, 'DhcpNameServer');
end end
else else
Result := ReadReg(W9xfix, 'NameServer'); Result := ReadReg(W9xfix, 'NameServer');
Result := ReplaceString(trim(Result), ' ', ','); Result := ReplaceString(trim(Result), ' ', ',');
end; end;
end; end;
{$ENDIF} {$ENDIF}
{==============================================================================} {==============================================================================}
function GetIEProxy(protocol: string): TProxySetting; function GetIEProxy(protocol: string): TProxySetting;
{$IFDEF LINUX} {$IFDEF LINUX}
begin begin
Result.Host := ''; Result.Host := '';
Result.Port := ''; Result.Port := '';
Result.Bypass := ''; Result.Bypass := '';
end; end;
{$ELSE} {$ELSE}
type type
PInternetProxyInfo = ^TInternetProxyInfo; PInternetProxyInfo = ^TInternetProxyInfo;
TInternetProxyInfo = packed record TInternetProxyInfo = packed record
dwAccessType: DWORD; dwAccessType: DWORD;
lpszProxy: LPCSTR; lpszProxy: LPCSTR;
lpszProxyBypass: LPCSTR; lpszProxyBypass: LPCSTR;
end; end;
const const
INTERNET_OPTION_PROXY = 38; INTERNET_OPTION_PROXY = 38;
INTERNET_OPEN_TYPE_PROXY = 3; INTERNET_OPEN_TYPE_PROXY = 3;
WininetDLL = 'WININET.DLL'; WininetDLL = 'WININET.DLL';
var var
WininetModule: THandle; WininetModule: THandle;
ProxyInfo: PInternetProxyInfo; ProxyInfo: PInternetProxyInfo;
Err: Boolean; Err: Boolean;
Len: DWORD; Len: DWORD;
Proxy: string; Proxy: string;
DefProxy: string; DefProxy: string;
ProxyList: TStringList; ProxyList: TStringList;
n: integer; n: integer;
InternetQueryOption: function (hInet: Pointer; dwOption: DWORD; InternetQueryOption: function (hInet: Pointer; dwOption: DWORD;
lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall; lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall;
begin begin
Result.Host := ''; Result.Host := '';
Result.Port := ''; Result.Port := '';
Result.Bypass := ''; Result.Bypass := '';
WininetModule := LoadLibrary(WininetDLL); WininetModule := LoadLibrary(WininetDLL);
if WininetModule = 0 then if WininetModule = 0 then
exit; exit;
try try
InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA'))); InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA')));
if @InternetQueryOption = nil then if @InternetQueryOption = nil then
Exit; Exit;
if protocol = '' then if protocol = '' then
protocol := 'http'; protocol := 'http';
Len := 4096; Len := 4096;
GetMem(ProxyInfo, Len); GetMem(ProxyInfo, Len);
ProxyList := TStringList.Create; ProxyList := TStringList.Create;
try try
Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len); Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
if Err then if Err then
if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
begin begin
ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ','); ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
Proxy := ''; Proxy := '';
DefProxy := ''; DefProxy := '';
for n := 0 to ProxyList.Count -1 do for n := 0 to ProxyList.Count -1 do
begin begin
if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then
begin begin
Proxy := SeparateRight(ProxyList[n], '='); Proxy := SeparateRight(ProxyList[n], '=');
break; break;
end; end;
if Pos('=', ProxyList[n]) < 1 then if Pos('=', ProxyList[n]) < 1 then
DefProxy := ProxyList[n]; DefProxy := ProxyList[n];
end; end;
if Proxy = '' then if Proxy = '' then
Proxy := DefProxy; Proxy := DefProxy;
if Proxy <> '' then if Proxy <> '' then
begin begin
Result.Host := Trim(SeparateLeft(Proxy, ':')); Result.Host := Trim(SeparateLeft(Proxy, ':'));
Result.Port := Trim(SeparateRight(Proxy, ':')); Result.Port := Trim(SeparateRight(Proxy, ':'));
end; end;
Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ','); Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
end; end;
finally finally
ProxyList.Free; ProxyList.Free;
FreeMem(ProxyInfo); FreeMem(ProxyInfo);
end; end;
finally finally
FreeLibrary(WininetModule); FreeLibrary(WininetModule);
end; end;
end; end;
{$ENDIF} {$ENDIF}
{==============================================================================} {==============================================================================}
function GetLocalIPs: string; function GetLocalIPs: string;
var var
TcpSock: TTCPBlockSocket; TcpSock: TTCPBlockSocket;
ipList: TStringList; ipList: TStringList;
begin begin
Result := ''; Result := '';
ipList := TStringList.Create; ipList := TStringList.Create;
try try
TcpSock := TTCPBlockSocket.create; TcpSock := TTCPBlockSocket.create;
try try
TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList); TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
Result := ipList.CommaText; Result := ipList.CommaText;
finally finally
TcpSock.Free; TcpSock.Free;
end; end;
finally finally
ipList.Free; ipList.Free;
end; end;
end; end;
{==============================================================================} {==============================================================================}
end. end.

4636
Units/Synapse/synaser.pas
View File

File diff suppressed because it is too large Load Diff

3640
Units/Synapse/synautil.pas
View File

File diff suppressed because it is too large Load Diff

154
Units/Synapse/synsock.pas
View File

@ -1,77 +1,77 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 005.002.000 | | Project : Ararat Synapse | 005.002.000 |
|==============================================================================| |==============================================================================|
| Content: Socket Independent Platform Layer | | Content: Socket Independent Platform Layer |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer | | Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-20010. | | Portions created by Lukas Gebauer are Copyright (c)2001-20010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@exclude} {:@exclude}
unit synsock; unit synsock;
{$MINENUMSIZE 4} {$MINENUMSIZE 4}
//old Delphi does not have MSWINDOWS define. //old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32} {$IFDEF WIN32}
{$IFNDEF MSWINDOWS} {$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS} {$DEFINE MSWINDOWS}
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
{$IFDEF CIL} {$IFDEF CIL}
{$I ssdotnet.pas} {$I ssdotnet.pas}
{$ELSE} {$ELSE}
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
{$I sswin32.pas} {$I sswin32.pas}
{$ELSE} {$ELSE}
{$IFDEF WINCE} {$IFDEF WINCE}
{$I sswin32.pas} //not complete yet! {$I sswin32.pas} //not complete yet!
{$ELSE} {$ELSE}
{$IFDEF FPC} {$IFDEF FPC}
{$I ssfpc.pas} {$I ssfpc.pas}
{$ELSE} {$ELSE}
{$I sslinux.pas} {$I sslinux.pas}
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
end. end.

728
Units/Synapse/tlntsend.pas
View File

@ -1,364 +1,364 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 001.003.001 | | Project : Ararat Synapse | 001.003.001 |
|==============================================================================| |==============================================================================|
| Content: TELNET and SSH2 client | | Content: TELNET and SSH2 client |
|==============================================================================| |==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer | | Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: | | modification, are permitted provided that the following conditions are met: |
| | | |
| Redistributions of source code must retain the above copyright notice, this | | Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. | | list of conditions and the following disclaimer. |
| | | |
| Redistributions in binary form must reproduce the above copyright notice, | | Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation | | this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. | | and/or other materials provided with the distribution. |
| | | |
| Neither the name of Lukas Gebauer nor the names of its contributors may | | 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 | | be used to endorse or promote products derived from this software without |
| specific prior written permission. | | specific prior written permission. |
| | | |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | | 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 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. | | DAMAGE. |
|==============================================================================| |==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2002-2010. | | Portions created by Lukas Gebauer are Copyright (c)2002-2010. |
| All Rights Reserved. | | All Rights Reserved. |
|==============================================================================| |==============================================================================|
| Contributor(s): | | Contributor(s): |
|==============================================================================| |==============================================================================|
| History: see HISTORY.HTM from distribution package | | History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) | | (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================} |==============================================================================}
{:@abstract(Telnet script client) {:@abstract(Telnet script client)
Used RFC: RFC-854 Used RFC: RFC-854
} }
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$ENDIF} {$ENDIF}
{$H+} {$H+}
{$IFDEF UNICODE} {$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF} {$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF} {$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF} {$ENDIF}
unit tlntsend; unit tlntsend;
interface interface
uses uses
SysUtils, Classes, SysUtils, Classes,
blcksock, synautil; blcksock, synautil;
const const
cTelnetProtocol = '23'; cTelnetProtocol = '23';
cSSHProtocol = '22'; cSSHProtocol = '22';
TLNT_EOR = #239; TLNT_EOR = #239;
TLNT_SE = #240; TLNT_SE = #240;
TLNT_NOP = #241; TLNT_NOP = #241;
TLNT_DATA_MARK = #242; TLNT_DATA_MARK = #242;
TLNT_BREAK = #243; TLNT_BREAK = #243;
TLNT_IP = #244; TLNT_IP = #244;
TLNT_AO = #245; TLNT_AO = #245;
TLNT_AYT = #246; TLNT_AYT = #246;
TLNT_EC = #247; TLNT_EC = #247;
TLNT_EL = #248; TLNT_EL = #248;
TLNT_GA = #249; TLNT_GA = #249;
TLNT_SB = #250; TLNT_SB = #250;
TLNT_WILL = #251; TLNT_WILL = #251;
TLNT_WONT = #252; TLNT_WONT = #252;
TLNT_DO = #253; TLNT_DO = #253;
TLNT_DONT = #254; TLNT_DONT = #254;
TLNT_IAC = #255; TLNT_IAC = #255;
type type
{:@abstract(State of telnet protocol). Used internaly by TTelnetSend.} {:@abstract(State of telnet protocol). Used internaly by TTelnetSend.}
TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT, TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC); tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
{:@abstract(Class with implementation of Telnet/SSH script client.) {:@abstract(Class with implementation of Telnet/SSH script client.)
Note: Are you missing properties for specify server address and port? Look to Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!} parent @link(TSynaClient) too!}
TTelnetSend = class(TSynaClient) TTelnetSend = class(TSynaClient)
private private
FSock: TTCPBlockSocket; FSock: TTCPBlockSocket;
FBuffer: Ansistring; FBuffer: Ansistring;
FState: TTelnetState; FState: TTelnetState;
FSessionLog: Ansistring; FSessionLog: Ansistring;
FSubNeg: Ansistring; FSubNeg: Ansistring;
FSubType: Ansichar; FSubType: Ansichar;
FTermType: Ansistring; FTermType: Ansistring;
function Connect: Boolean; function Connect: Boolean;
function Negotiate(const Buf: Ansistring): Ansistring; function Negotiate(const Buf: Ansistring): Ansistring;
procedure FilterHook(Sender: TObject; var Value: AnsiString); procedure FilterHook(Sender: TObject; var Value: AnsiString);
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
{:Connects to Telnet server.} {:Connects to Telnet server.}
function Login: Boolean; function Login: Boolean;
{:Connects to SSH2 server and login by Username and Password properties. {:Connects to SSH2 server and login by Username and Password properties.
You must use some of SSL plugins with SSH support. For exammple CryptLib.} You must use some of SSL plugins with SSH support. For exammple CryptLib.}
function SSHLogin: Boolean; function SSHLogin: Boolean;
{:Logout from telnet server.} {:Logout from telnet server.}
procedure Logout; procedure Logout;
{:Send this data to telnet server.} {:Send this data to telnet server.}
procedure Send(const Value: string); procedure Send(const Value: string);
{:Reading data from telnet server until Value is readed. If it is not readed {:Reading data from telnet server until Value is readed. If it is not readed
until timeout, result is @false. Otherwise result is @true.} until timeout, result is @false. Otherwise result is @true.}
function WaitFor(const Value: string): Boolean; function WaitFor(const Value: string): Boolean;
{:Read data terminated by terminator from telnet server.} {:Read data terminated by terminator from telnet server.}
function RecvTerminated(const Terminator: string): string; function RecvTerminated(const Terminator: string): string;
{:Read string from telnet server.} {:Read string from telnet server.}
function RecvString: string; function RecvString: string;
published published
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock; property Sock: TTCPBlockSocket read FSock;
{:all readed datas in this session (from connect) is stored in this large {:all readed datas in this session (from connect) is stored in this large
string.} string.}
property SessionLog: Ansistring read FSessionLog write FSessionLog; property SessionLog: Ansistring read FSessionLog write FSessionLog;
{:Terminal type indentification. By default is 'SYNAPSE'.} {:Terminal type indentification. By default is 'SYNAPSE'.}
property TermType: Ansistring read FTermType write FTermType; property TermType: Ansistring read FTermType write FTermType;
end; end;
implementation implementation
constructor TTelnetSend.Create; constructor TTelnetSend.Create;
begin begin
inherited Create; inherited Create;
FSock := TTCPBlockSocket.Create; FSock := TTCPBlockSocket.Create;
FSock.Owner := self; FSock.Owner := self;
FSock.OnReadFilter := FilterHook; FSock.OnReadFilter := FilterHook;
FTimeout := 60000; FTimeout := 60000;
FTargetPort := cTelnetProtocol; FTargetPort := cTelnetProtocol;
FSubNeg := ''; FSubNeg := '';
FSubType := #0; FSubType := #0;
FTermType := 'SYNAPSE'; FTermType := 'SYNAPSE';
end; end;
destructor TTelnetSend.Destroy; destructor TTelnetSend.Destroy;
begin begin
FSock.Free; FSock.Free;
inherited Destroy; inherited Destroy;
end; end;
function TTelnetSend.Connect: Boolean; function TTelnetSend.Connect: Boolean;
begin begin
// Do not call this function! It is calling by LOGIN method! // Do not call this function! It is calling by LOGIN method!
FBuffer := ''; FBuffer := '';
FSessionLog := ''; FSessionLog := '';
FState := tsDATA; FState := tsDATA;
FSock.CloseSocket; FSock.CloseSocket;
FSock.LineBuffer := ''; FSock.LineBuffer := '';
FSock.Bind(FIPInterface, cAnyPort); FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort); FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
function TTelnetSend.RecvTerminated(const Terminator: string): string; function TTelnetSend.RecvTerminated(const Terminator: string): string;
begin begin
Result := FSock.RecvTerminated(FTimeout, Terminator); Result := FSock.RecvTerminated(FTimeout, Terminator);
end; end;
function TTelnetSend.RecvString: string; function TTelnetSend.RecvString: string;
begin begin
Result := FSock.RecvTerminated(FTimeout, CRLF); Result := FSock.RecvTerminated(FTimeout, CRLF);
end; end;
function TTelnetSend.WaitFor(const Value: string): Boolean; function TTelnetSend.WaitFor(const Value: string): Boolean;
begin begin
Result := FSock.RecvTerminated(FTimeout, Value) <> ''; Result := FSock.RecvTerminated(FTimeout, Value) <> '';
end; end;
procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString); procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString);
begin begin
Value := Negotiate(Value); Value := Negotiate(Value);
FSessionLog := FSessionLog + Value; FSessionLog := FSessionLog + Value;
end; end;
function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring; function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring;
var var
n: integer; n: integer;
c: Ansichar; c: Ansichar;
Reply: Ansistring; Reply: Ansistring;
SubReply: Ansistring; SubReply: Ansistring;
begin begin
Result := ''; Result := '';
for n := 1 to Length(Buf) do for n := 1 to Length(Buf) do
begin begin
c := Buf[n]; c := Buf[n];
Reply := ''; Reply := '';
case FState of case FState of
tsData: tsData:
if c = TLNT_IAC then if c = TLNT_IAC then
FState := tsIAC FState := tsIAC
else else
Result := Result + c; Result := Result + c;
tsIAC: tsIAC:
case c of case c of
TLNT_IAC: TLNT_IAC:
begin begin
FState := tsData; FState := tsData;
Result := Result + TLNT_IAC; Result := Result + TLNT_IAC;
end; end;
TLNT_WILL: TLNT_WILL:
FState := tsIAC_WILL; FState := tsIAC_WILL;
TLNT_WONT: TLNT_WONT:
FState := tsIAC_WONT; FState := tsIAC_WONT;
TLNT_DONT: TLNT_DONT:
FState := tsIAC_DONT; FState := tsIAC_DONT;
TLNT_DO: TLNT_DO:
FState := tsIAC_DO; FState := tsIAC_DO;
TLNT_EOR: TLNT_EOR:
FState := tsDATA; FState := tsDATA;
TLNT_SB: TLNT_SB:
begin begin
FState := tsIAC_SB; FState := tsIAC_SB;
FSubType := #0; FSubType := #0;
FSubNeg := ''; FSubNeg := '';
end; end;
else else
FState := tsData; FState := tsData;
end; end;
tsIAC_WILL: tsIAC_WILL:
begin begin
case c of case c of
#3: //suppress GA #3: //suppress GA
Reply := TLNT_DO; Reply := TLNT_DO;
else else
Reply := TLNT_DONT; Reply := TLNT_DONT;
end; end;
FState := tsData; FState := tsData;
end; end;
tsIAC_WONT: tsIAC_WONT:
begin begin
Reply := TLNT_DONT; Reply := TLNT_DONT;
FState := tsData; FState := tsData;
end; end;
tsIAC_DO: tsIAC_DO:
begin begin
case c of case c of
#24: //termtype #24: //termtype
Reply := TLNT_WILL; Reply := TLNT_WILL;
else else
Reply := TLNT_WONT; Reply := TLNT_WONT;
end; end;
FState := tsData; FState := tsData;
end; end;
tsIAC_DONT: tsIAC_DONT:
begin begin
Reply := TLNT_WONT; Reply := TLNT_WONT;
FState := tsData; FState := tsData;
end; end;
tsIAC_SB: tsIAC_SB:
begin begin
FSubType := c; FSubType := c;
FState := tsIAC_SBDATA; FState := tsIAC_SBDATA;
end; end;
tsIAC_SBDATA: tsIAC_SBDATA:
begin begin
if c = TLNT_IAC then if c = TLNT_IAC then
FState := tsSBDATA_IAC FState := tsSBDATA_IAC
else else
FSubNeg := FSubNeg + c; FSubNeg := FSubNeg + c;
end; end;
tsSBDATA_IAC: tsSBDATA_IAC:
case c of case c of
TLNT_IAC: TLNT_IAC:
begin begin
FState := tsIAC_SBDATA; FState := tsIAC_SBDATA;
FSubNeg := FSubNeg + c; FSubNeg := FSubNeg + c;
end; end;
TLNT_SE: TLNT_SE:
begin begin
SubReply := ''; SubReply := '';
case FSubType of case FSubType of
#24: //termtype #24: //termtype
begin begin
if (FSubNeg <> '') and (FSubNeg[1] = #1) then if (FSubNeg <> '') and (FSubNeg[1] = #1) then
SubReply := #0 + FTermType; SubReply := #0 + FTermType;
end; end;
end; end;
Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE); Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE);
FState := tsDATA; FState := tsDATA;
end; end;
else else
FState := tsDATA; FState := tsDATA;
end; end;
else else
FState := tsData; FState := tsData;
end; end;
if Reply <> '' then if Reply <> '' then
Sock.SendString(TLNT_IAC + Reply + c); Sock.SendString(TLNT_IAC + Reply + c);
end; end;
end; end;
procedure TTelnetSend.Send(const Value: string); procedure TTelnetSend.Send(const Value: string);
begin begin
Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC)); Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC));
end; end;
function TTelnetSend.Login: Boolean; function TTelnetSend.Login: Boolean;
begin begin
Result := False; Result := False;
if not Connect then if not Connect then
Exit; Exit;
Result := True; Result := True;
end; end;
function TTelnetSend.SSHLogin: Boolean; function TTelnetSend.SSHLogin: Boolean;
begin begin
Result := False; Result := False;
if Connect then if Connect then
begin begin
FSock.SSL.SSLType := LT_SSHv2; FSock.SSL.SSLType := LT_SSHv2;
FSock.SSL.Username := FUsername; FSock.SSL.Username := FUsername;
FSock.SSL.Password := FPassword; FSock.SSL.Password := FPassword;
FSock.SSLDoConnect; FSock.SSLDoConnect;
Result := FSock.LastError = 0; Result := FSock.LastError = 0;
end; end;
end; end;
procedure TTelnetSend.Logout; procedure TTelnetSend.Logout;
begin begin
FSock.CloseSocket; FSock.CloseSocket;
end; end;
end. end.