Nothing's changed? First git commit =D
This commit is contained in:
parent
25fbd55694
commit
5f49c2129c
|
@ -1,64 +1,64 @@
|
|||
program new;
|
||||
{.LoadDLL libsmart}
|
||||
function IsKeyDown(C:Char): Boolean;
|
||||
begin
|
||||
Result := SmartIsKeyDown(ord(c));
|
||||
end;
|
||||
|
||||
procedure MoveMouse(x, y: Integer);
|
||||
begin
|
||||
SmartMoveMouse(x, y);
|
||||
end;
|
||||
|
||||
procedure HoldMouse(x, y: Integer; left: Boolean);
|
||||
begin
|
||||
SmartHoldMouse(x, y, left);
|
||||
end;
|
||||
|
||||
procedure ReleaseMouse(x, y: Integer; left: Boolean);
|
||||
begin
|
||||
SmartReleaseMouse(x, y, left);
|
||||
end;
|
||||
|
||||
procedure KeyUp(key: Byte);
|
||||
begin
|
||||
If Key = 13 Then
|
||||
Key := 10;
|
||||
SmartReleaseKey(key);
|
||||
end;
|
||||
|
||||
procedure KeyDown(key: Byte);
|
||||
begin
|
||||
If Key = 13 Then
|
||||
Key := 10;
|
||||
SmartHoldKey(key);
|
||||
end;
|
||||
|
||||
procedure SendKeys(S: String);
|
||||
begin
|
||||
SmartSendKeys(S);
|
||||
end;
|
||||
|
||||
procedure GetMousePos(var x, y: Integer);
|
||||
begin
|
||||
SmartGetMousePos(x, y);
|
||||
end;
|
||||
|
||||
function GetColor(x, y: Integer): Integer;
|
||||
begin
|
||||
result:= SmartGetColor(x, y);
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
w,h:integer;
|
||||
begin
|
||||
SmartSetup('http://world19.runescape.com/', 'plugin.js?param=o0,a1,m0', 765, 503);
|
||||
SetTargetArray(SmartImageArray, 765,503);
|
||||
getclientdimensions(w,h);
|
||||
writeln(inttostr(w) + ' , ' + inttostr(h));
|
||||
if findcolortolerance(w,h,clwhite,0,0,764,502,300) then
|
||||
smartmovemouse(w,h);
|
||||
savescreenshot('/tmp/smart.bmp');
|
||||
//Wait(5000);
|
||||
end.
|
||||
program new;
|
||||
{.LoadDLL libsmart}
|
||||
function IsKeyDown(C:Char): Boolean;
|
||||
begin
|
||||
Result := SmartIsKeyDown(ord(c));
|
||||
end;
|
||||
|
||||
procedure MoveMouse(x, y: Integer);
|
||||
begin
|
||||
SmartMoveMouse(x, y);
|
||||
end;
|
||||
|
||||
procedure HoldMouse(x, y: Integer; left: Boolean);
|
||||
begin
|
||||
SmartHoldMouse(x, y, left);
|
||||
end;
|
||||
|
||||
procedure ReleaseMouse(x, y: Integer; left: Boolean);
|
||||
begin
|
||||
SmartReleaseMouse(x, y, left);
|
||||
end;
|
||||
|
||||
procedure KeyUp(key: Byte);
|
||||
begin
|
||||
If Key = 13 Then
|
||||
Key := 10;
|
||||
SmartReleaseKey(key);
|
||||
end;
|
||||
|
||||
procedure KeyDown(key: Byte);
|
||||
begin
|
||||
If Key = 13 Then
|
||||
Key := 10;
|
||||
SmartHoldKey(key);
|
||||
end;
|
||||
|
||||
procedure SendKeys(S: String);
|
||||
begin
|
||||
SmartSendKeys(S);
|
||||
end;
|
||||
|
||||
procedure GetMousePos(var x, y: Integer);
|
||||
begin
|
||||
SmartGetMousePos(x, y);
|
||||
end;
|
||||
|
||||
function GetColor(x, y: Integer): Integer;
|
||||
begin
|
||||
result:= SmartGetColor(x, y);
|
||||
end;
|
||||
|
||||
|
||||
var
|
||||
w,h:integer;
|
||||
begin
|
||||
SmartSetup('http://world19.runescape.com/', 'plugin.js?param=o0,a1,m0', 765, 503);
|
||||
SetTargetArray(SmartImageArray, 765,503);
|
||||
getclientdimensions(w,h);
|
||||
writeln(inttostr(w) + ' , ' + inttostr(h));
|
||||
if findcolortolerance(w,h,clwhite,0,0,764,502,300) then
|
||||
smartmovemouse(w,h);
|
||||
savescreenshot('/tmp/smart.bmp');
|
||||
//Wait(5000);
|
||||
end.
|
||||
|
|
|
@ -1,66 +1,66 @@
|
|||
procedure SplitTPAExWrap(arr: TPointArray; w, h: Integer; out res : T2DPointArray);
|
||||
begin
|
||||
res := SplitTPAEx(arr,w,h);
|
||||
end;
|
||||
|
||||
procedure SplitTPAWrap(arr: TPointArray; Dist: Integer; out res: T2DPointArray);
|
||||
begin
|
||||
res := SplitTPA(arr,dist);
|
||||
end;
|
||||
|
||||
procedure FindGapsTPAWrap(TPA: TPointArray; MinPixels: Integer; out Res : T2DPointArray); extdecl;
|
||||
begin
|
||||
Res := FindGapsTPA(TPA,MinPixels);
|
||||
end;
|
||||
procedure RemoveDistTPointArrayWrap(x, y, dist: Integer; ThePoints: TPointArray; RemoveHigher: Boolean; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := RemoveDistTPointArray(x,y,dist,thepoints,removehigher);
|
||||
end;
|
||||
procedure CombineTPAWrap(Ar1, Ar2: TPointArray; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := CombineTPA(Ar1,Ar2);
|
||||
end;
|
||||
procedure ReArrangeandShortenArrayExWrap(a: TPointArray; w, h: Integer; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := ReArrangeandShortenArrayEx(a,w,h);
|
||||
end;
|
||||
procedure ReArrangeandShortenArrayWrap(a: TPointArray; Dist: Integer; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := ReArrangeandShortenArray(a,dist);
|
||||
end;
|
||||
procedure TPAtoATPAExWrap(TPA: TPointArray; w, h: Integer; out Res : T2DPointArray);extdecl;
|
||||
begin
|
||||
Res := TPAtoATPAEx(TPA,w,h);
|
||||
end;
|
||||
procedure TPAtoATPAWrap(TPA: TPointArray; Dist: Integer; out Res : T2DPointArray);extdecl;
|
||||
begin
|
||||
Res := TPAtoATPA(TPA,Dist);
|
||||
end;
|
||||
procedure CombineIntArrayWrap(Ar1, Ar2: TIntegerArray; out Res : TIntegerArray);extdecl;
|
||||
begin
|
||||
Res := CombineIntArray(Ar1,Ar2);
|
||||
end;
|
||||
procedure MergeATPAWrap(ATPA : T2DPointArray; out Res: TPointArray); extdecl;
|
||||
begin
|
||||
Res := MergeATPA(ATPA);
|
||||
end;
|
||||
procedure TPAFromBoxWrap(const Box : TBox; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := TPAFromBox(Box);
|
||||
end;
|
||||
procedure RotatePointsWrap(Const P: TPointArray; A, cx, cy: Extended; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := RotatePoints(P,a,cx,cy);
|
||||
end;
|
||||
procedure FindTPAEdgesWrap(p: TPointArray; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := FindTPAEdges(p);
|
||||
end;
|
||||
procedure ClearTPAFromTPAWrap(arP, ClearPoints: TPointArray; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := ClearTPAFromTPA(arP, clearpoints);
|
||||
end;
|
||||
procedure ReturnPointsNotInTPAWrap(Const TotalTPA: TPointArray; const Box: TBox; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := ReturnPointsNotInTPA(TotalTPA,box);
|
||||
end;
|
||||
procedure SplitTPAExWrap(arr: TPointArray; w, h: Integer; out res : T2DPointArray);
|
||||
begin
|
||||
res := SplitTPAEx(arr,w,h);
|
||||
end;
|
||||
|
||||
procedure SplitTPAWrap(arr: TPointArray; Dist: Integer; out res: T2DPointArray);
|
||||
begin
|
||||
res := SplitTPA(arr,dist);
|
||||
end;
|
||||
|
||||
procedure FindGapsTPAWrap(TPA: TPointArray; MinPixels: Integer; out Res : T2DPointArray); extdecl;
|
||||
begin
|
||||
Res := FindGapsTPA(TPA,MinPixels);
|
||||
end;
|
||||
procedure RemoveDistTPointArrayWrap(x, y, dist: Integer; ThePoints: TPointArray; RemoveHigher: Boolean; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := RemoveDistTPointArray(x,y,dist,thepoints,removehigher);
|
||||
end;
|
||||
procedure CombineTPAWrap(Ar1, Ar2: TPointArray; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := CombineTPA(Ar1,Ar2);
|
||||
end;
|
||||
procedure ReArrangeandShortenArrayExWrap(a: TPointArray; w, h: Integer; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := ReArrangeandShortenArrayEx(a,w,h);
|
||||
end;
|
||||
procedure ReArrangeandShortenArrayWrap(a: TPointArray; Dist: Integer; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := ReArrangeandShortenArray(a,dist);
|
||||
end;
|
||||
procedure TPAtoATPAExWrap(TPA: TPointArray; w, h: Integer; out Res : T2DPointArray);extdecl;
|
||||
begin
|
||||
Res := TPAtoATPAEx(TPA,w,h);
|
||||
end;
|
||||
procedure TPAtoATPAWrap(TPA: TPointArray; Dist: Integer; out Res : T2DPointArray);extdecl;
|
||||
begin
|
||||
Res := TPAtoATPA(TPA,Dist);
|
||||
end;
|
||||
procedure CombineIntArrayWrap(Ar1, Ar2: TIntegerArray; out Res : TIntegerArray);extdecl;
|
||||
begin
|
||||
Res := CombineIntArray(Ar1,Ar2);
|
||||
end;
|
||||
procedure MergeATPAWrap(ATPA : T2DPointArray; out Res: TPointArray); extdecl;
|
||||
begin
|
||||
Res := MergeATPA(ATPA);
|
||||
end;
|
||||
procedure TPAFromBoxWrap(const Box : TBox; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := TPAFromBox(Box);
|
||||
end;
|
||||
procedure RotatePointsWrap(Const P: TPointArray; A, cx, cy: Extended; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := RotatePoints(P,a,cx,cy);
|
||||
end;
|
||||
procedure FindTPAEdgesWrap(p: TPointArray; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := FindTPAEdges(p);
|
||||
end;
|
||||
procedure ClearTPAFromTPAWrap(arP, ClearPoints: TPointArray; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := ClearTPAFromTPA(arP, clearpoints);
|
||||
end;
|
||||
procedure ReturnPointsNotInTPAWrap(Const TotalTPA: TPointArray; const Box: TBox; out Res : TPointArray);extdecl;
|
||||
begin
|
||||
Res := ReturnPointsNotInTPA(TotalTPA,box);
|
||||
end;
|
||||
|
|
|
@ -1,114 +1,114 @@
|
|||
unit stringutil;
|
||||
|
||||
{$mode objfpc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,mufasatypes;
|
||||
|
||||
type
|
||||
StrExtr =(Numbers, Letters, Others);
|
||||
function ExtractFromStr( Str : string; Extract : StrExtr) : string;
|
||||
function Capitalize(str : string) : string;
|
||||
function Implode(Glue : string; Pieces: TStringArray): string;
|
||||
function Explode(del, str: string): TStringArray;
|
||||
|
||||
implementation
|
||||
|
||||
function Implode(Glue: string;Pieces: TStringArray): string;
|
||||
var
|
||||
I, Len : integer;
|
||||
begin
|
||||
Len := high(Pieces);
|
||||
if (Len < 0) then
|
||||
exit;
|
||||
Result := Pieces[0];
|
||||
for i := 1 to len do
|
||||
result := result + Glue + Pieces[i];
|
||||
end;
|
||||
|
||||
function Explode(del, str: string): TStringArray;
|
||||
var
|
||||
i,ii : integer;
|
||||
lastpos : integer;
|
||||
lenstr : integer;
|
||||
lendel : integer;
|
||||
lenres : integer;
|
||||
matches : boolean;
|
||||
begin;
|
||||
lastpos := 1;
|
||||
lenres := 0;
|
||||
setlength(result,lenres);
|
||||
lendel := length(del);
|
||||
lenstr := length(str);
|
||||
// for i := 1 to lenstr do
|
||||
i := 1;
|
||||
while i <= lenstr do
|
||||
begin;
|
||||
if not ((i + lendel - 1) > lenstr) then
|
||||
begin
|
||||
matches := true;
|
||||
for ii := 1 to lendel do
|
||||
if str[i + ii - 1] <> del[ii] then
|
||||
begin
|
||||
matches := false;
|
||||
break;
|
||||
end;
|
||||
if matches then
|
||||
begin;
|
||||
inc(lenres);
|
||||
setlength(result,lenres);
|
||||
result[lenres-1] := Copy(str,lastpos,i-lastpos);
|
||||
lastpos := i+lendel;
|
||||
i := i + lendel-1;//Dirty
|
||||
if i = lenstr then //This was the trailing delimiter
|
||||
exit;
|
||||
end;
|
||||
end else //We cannot possibly find a delimiter anymore, thus copy the rest of the string and exit
|
||||
Break;
|
||||
inc(i);
|
||||
end;
|
||||
//Copy the rest of the string (if it's not a delimiter)
|
||||
inc(lenres);
|
||||
setlength(result,lenres);
|
||||
result[lenres-1] := Copy(str,lastpos,lenstr - lastpos + 1);
|
||||
end;
|
||||
|
||||
function Capitalize(str : string) : string;
|
||||
var
|
||||
i , l : integer;
|
||||
cap : boolean;
|
||||
Range : set of char;
|
||||
begin;
|
||||
result := str;
|
||||
l := length(str);
|
||||
cap := true;
|
||||
Range := ['a'..'z','A'..'Z'];
|
||||
for i := 1 to l do
|
||||
if cap and (str[i] in Range) then
|
||||
begin;
|
||||
result[i] := UpperCase(str[i])[1];
|
||||
cap := false;
|
||||
end else if not (str[i] in Range) then
|
||||
cap := true;
|
||||
end;
|
||||
|
||||
function ExtractFromStr( Str : string; Extract : StrExtr) : string;
|
||||
var
|
||||
Range : set of char;
|
||||
i : integer;
|
||||
begin;
|
||||
case Extract of
|
||||
Numbers : Range := ['0'..'9'];
|
||||
Letters : Range := ['A'..'Z','a'..'z'];
|
||||
Others : Range := [#0..#255] - ['0'..'9','A'..'Z','a'..'z'];
|
||||
end;
|
||||
Result := '';
|
||||
for i := length(str) downto 1 do
|
||||
if str[i] in Range then
|
||||
result := str[i] + result;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
unit stringutil;
|
||||
|
||||
{$mode objfpc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,mufasatypes;
|
||||
|
||||
type
|
||||
StrExtr =(Numbers, Letters, Others);
|
||||
function ExtractFromStr( Str : string; Extract : StrExtr) : string;
|
||||
function Capitalize(str : string) : string;
|
||||
function Implode(Glue : string; Pieces: TStringArray): string;
|
||||
function Explode(del, str: string): TStringArray;
|
||||
|
||||
implementation
|
||||
|
||||
function Implode(Glue: string;Pieces: TStringArray): string;
|
||||
var
|
||||
I, Len : integer;
|
||||
begin
|
||||
Len := high(Pieces);
|
||||
if (Len < 0) then
|
||||
exit;
|
||||
Result := Pieces[0];
|
||||
for i := 1 to len do
|
||||
result := result + Glue + Pieces[i];
|
||||
end;
|
||||
|
||||
function Explode(del, str: string): TStringArray;
|
||||
var
|
||||
i,ii : integer;
|
||||
lastpos : integer;
|
||||
lenstr : integer;
|
||||
lendel : integer;
|
||||
lenres : integer;
|
||||
matches : boolean;
|
||||
begin;
|
||||
lastpos := 1;
|
||||
lenres := 0;
|
||||
setlength(result,lenres);
|
||||
lendel := length(del);
|
||||
lenstr := length(str);
|
||||
// for i := 1 to lenstr do
|
||||
i := 1;
|
||||
while i <= lenstr do
|
||||
begin;
|
||||
if not ((i + lendel - 1) > lenstr) then
|
||||
begin
|
||||
matches := true;
|
||||
for ii := 1 to lendel do
|
||||
if str[i + ii - 1] <> del[ii] then
|
||||
begin
|
||||
matches := false;
|
||||
break;
|
||||
end;
|
||||
if matches then
|
||||
begin;
|
||||
inc(lenres);
|
||||
setlength(result,lenres);
|
||||
result[lenres-1] := Copy(str,lastpos,i-lastpos);
|
||||
lastpos := i+lendel;
|
||||
i := i + lendel-1;//Dirty
|
||||
if i = lenstr then //This was the trailing delimiter
|
||||
exit;
|
||||
end;
|
||||
end else //We cannot possibly find a delimiter anymore, thus copy the rest of the string and exit
|
||||
Break;
|
||||
inc(i);
|
||||
end;
|
||||
//Copy the rest of the string (if it's not a delimiter)
|
||||
inc(lenres);
|
||||
setlength(result,lenres);
|
||||
result[lenres-1] := Copy(str,lastpos,lenstr - lastpos + 1);
|
||||
end;
|
||||
|
||||
function Capitalize(str : string) : string;
|
||||
var
|
||||
i , l : integer;
|
||||
cap : boolean;
|
||||
Range : set of char;
|
||||
begin;
|
||||
result := str;
|
||||
l := length(str);
|
||||
cap := true;
|
||||
Range := ['a'..'z','A'..'Z'];
|
||||
for i := 1 to l do
|
||||
if cap and (str[i] in Range) then
|
||||
begin;
|
||||
result[i] := UpperCase(str[i])[1];
|
||||
cap := false;
|
||||
end else if not (str[i] in Range) then
|
||||
cap := true;
|
||||
end;
|
||||
|
||||
function ExtractFromStr( Str : string; Extract : StrExtr) : string;
|
||||
var
|
||||
Range : set of char;
|
||||
i : integer;
|
||||
begin;
|
||||
case Extract of
|
||||
Numbers : Range := ['0'..'9'];
|
||||
Letters : Range := ['A'..'Z','a'..'z'];
|
||||
Others : Range := [#0..#255] - ['0'..'9','A'..'Z','a'..'z'];
|
||||
end;
|
||||
Result := '';
|
||||
for i := length(str) downto 1 do
|
||||
if str[i] in Range then
|
||||
result := str[i] + result;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
|
|
|
@ -1,50 +1,50 @@
|
|||
unit mufasabase;
|
||||
|
||||
{$mode objfpc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
files, Classes, SysUtils{$ifdef MSWindows},windows{$endif};
|
||||
|
||||
procedure mDebugLn( s : string);overload;
|
||||
procedure mDebugLn( s : string; f : array of const);overload;
|
||||
procedure InitmDebug;
|
||||
procedure FreemDebug;
|
||||
implementation
|
||||
|
||||
uses
|
||||
TestUnit;
|
||||
var
|
||||
CanDebug : boolean = false;
|
||||
|
||||
procedure mDebugLn(s: string);
|
||||
begin
|
||||
if CanDebug then
|
||||
Writeln(s);
|
||||
end;
|
||||
|
||||
procedure mDebugLn(s: string; f: array of const); overload;
|
||||
begin
|
||||
mDebugLn(format(s,f));
|
||||
end;
|
||||
|
||||
procedure InitmDebug;
|
||||
begin
|
||||
CanDebug := true;
|
||||
{$ifdef MSWindows}
|
||||
IsConsole:= True;
|
||||
SysInitStdIO;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
procedure FreemDebug;
|
||||
begin
|
||||
CanDebug := false;
|
||||
{$ifdef MSWindows}
|
||||
IsConsole := false;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
unit mufasabase;
|
||||
|
||||
{$mode objfpc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
files, Classes, SysUtils{$ifdef MSWindows},windows{$endif};
|
||||
|
||||
procedure mDebugLn( s : string);overload;
|
||||
procedure mDebugLn( s : string; f : array of const);overload;
|
||||
procedure InitmDebug;
|
||||
procedure FreemDebug;
|
||||
implementation
|
||||
|
||||
uses
|
||||
TestUnit;
|
||||
var
|
||||
CanDebug : boolean = false;
|
||||
|
||||
procedure mDebugLn(s: string);
|
||||
begin
|
||||
if CanDebug then
|
||||
Writeln(s);
|
||||
end;
|
||||
|
||||
procedure mDebugLn(s: string; f: array of const); overload;
|
||||
begin
|
||||
mDebugLn(format(s,f));
|
||||
end;
|
||||
|
||||
procedure InitmDebug;
|
||||
begin
|
||||
CanDebug := true;
|
||||
{$ifdef MSWindows}
|
||||
IsConsole:= True;
|
||||
SysInitStdIO;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
procedure FreemDebug;
|
||||
begin
|
||||
CanDebug := false;
|
||||
{$ifdef MSWindows}
|
||||
IsConsole := false;
|
||||
{$endif}
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
|
|
|
@ -1,42 +1,42 @@
|
|||
unit web;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,LazHelpHTML,UTF8Process;
|
||||
|
||||
procedure OpenWebPage(URL: string);
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
procedure OpenWebPage(URL: string);
|
||||
var
|
||||
v: THTMLBrowserHelpViewer;
|
||||
BrowserPath, BrowserParams: string;
|
||||
p: LongInt;
|
||||
BrowserProcess: TProcessUTF8;
|
||||
begin
|
||||
v:=THTMLBrowserHelpViewer.Create(nil);
|
||||
try
|
||||
v.FindDefaultBrowser(BrowserPath,BrowserParams);
|
||||
p:=System.Pos('%s', BrowserParams);
|
||||
System.Delete(BrowserParams,p,2);
|
||||
System.Insert(URL,BrowserParams,p);
|
||||
|
||||
// start browser
|
||||
BrowserProcess:=TProcessUTF8.Create(nil);
|
||||
try
|
||||
BrowserProcess.CommandLine:=BrowserPath+' '+BrowserParams;
|
||||
BrowserProcess.Execute;
|
||||
finally
|
||||
BrowserProcess.Free;
|
||||
end;
|
||||
finally
|
||||
v.Free;
|
||||
end;
|
||||
end;
|
||||
end.
|
||||
|
||||
unit web;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,LazHelpHTML,UTF8Process;
|
||||
|
||||
procedure OpenWebPage(URL: string);
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
procedure OpenWebPage(URL: string);
|
||||
var
|
||||
v: THTMLBrowserHelpViewer;
|
||||
BrowserPath, BrowserParams: string;
|
||||
p: LongInt;
|
||||
BrowserProcess: TProcessUTF8;
|
||||
begin
|
||||
v:=THTMLBrowserHelpViewer.Create(nil);
|
||||
try
|
||||
v.FindDefaultBrowser(BrowserPath,BrowserParams);
|
||||
p:=System.Pos('%s', BrowserParams);
|
||||
System.Delete(BrowserParams,p,2);
|
||||
System.Insert(URL,BrowserParams,p);
|
||||
|
||||
// start browser
|
||||
BrowserProcess:=TProcessUTF8.Create(nil);
|
||||
try
|
||||
BrowserProcess.CommandLine:=BrowserPath+' '+BrowserParams;
|
||||
BrowserProcess.Execute;
|
||||
finally
|
||||
BrowserProcess.Free;
|
||||
end;
|
||||
finally
|
||||
v.Free;
|
||||
end;
|
||||
end;
|
||||
end.
|
||||
|
||||
|
|
|
@ -1,140 +1,140 @@
|
|||
{******************************************************************************}
|
||||
{* DCPcrypt v2.0 written by David Barton (crypto@cityinthesky.co.uk) **********}
|
||||
{******************************************************************************}
|
||||
{* A Base64 encoding/decoding unit ********************************************}
|
||||
{******************************************************************************}
|
||||
{* Copyright (c) 1999-2002 David Barton *}
|
||||
{* Permission is hereby granted, free of charge, to any person obtaining a *}
|
||||
{* copy of this software and associated documentation files (the "Software"), *}
|
||||
{* to deal in the Software without restriction, including without limitation *}
|
||||
{* the rights to use, copy, modify, merge, publish, distribute, sublicense, *}
|
||||
{* 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: *}
|
||||
{* *}
|
||||
{* The above copyright notice and this permission notice shall be included in *}
|
||||
{* all copies or substantial portions of the Software. *}
|
||||
{* *}
|
||||
{* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *}
|
||||
{* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *}
|
||||
{* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *}
|
||||
{* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *}
|
||||
{* 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 *}
|
||||
{* DEALINGS IN THE SOFTWARE. *}
|
||||
{******************************************************************************}
|
||||
unit DCPbase64;
|
||||
|
||||
{$mode delphi}
|
||||
interface
|
||||
uses
|
||||
Sysutils;
|
||||
|
||||
function Base64EncodeStr(const Value: string): string;
|
||||
{ Encode a string into Base64 format }
|
||||
function Base64DecodeStr(const Value: string): string;
|
||||
{ Decode a Base64 format string }
|
||||
function Base64Encode(pInput: pointer; pOutput: pointer; Size: longint): longint;
|
||||
{ Encode a lump of raw data (output is (4/3) times bigger than input) }
|
||||
function Base64Decode(pInput: pointer; pOutput: pointer; Size: longint): longint;
|
||||
{ Decode a lump of raw data }
|
||||
|
||||
|
||||
{******************************************************************************}
|
||||
{******************************************************************************}
|
||||
implementation
|
||||
|
||||
|
||||
const
|
||||
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,
|
||||
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);
|
||||
|
||||
function Base64Encode(pInput: pointer; pOutput: pointer; Size: longint): longint;
|
||||
var
|
||||
i, iptr, optr: integer;
|
||||
Input, Output: PByteArray;
|
||||
begin
|
||||
Input:= PByteArray(pInput); Output:= PByteArray(pOutput);
|
||||
iptr:= 0; optr:= 0;
|
||||
for i:= 1 to (Size div 3) do
|
||||
begin
|
||||
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+2]:= B64[((Input^[iptr+1] and 15) shl 2) + (Input^[iptr+2] shr 6)];
|
||||
Output^[optr+3]:= B64[Input^[iptr+2] and 63];
|
||||
Inc(optr,4); Inc(iptr,3);
|
||||
end;
|
||||
case (Size mod 3) of
|
||||
1: begin
|
||||
Output^[optr+0]:= B64[Input^[iptr] shr 2];
|
||||
Output^[optr+1]:= B64[(Input^[iptr] and 3) shl 4];
|
||||
Output^[optr+2]:= byte('=');
|
||||
Output^[optr+3]:= byte('=');
|
||||
end;
|
||||
2: begin
|
||||
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+2]:= B64[(Input^[iptr+1] and 15) shl 2];
|
||||
Output^[optr+3]:= byte('=');
|
||||
end;
|
||||
end;
|
||||
Result:= ((Size+2) div 3) * 4;
|
||||
end;
|
||||
|
||||
function Base64EncodeStr(const Value: string): string;
|
||||
begin
|
||||
SetLength(Result,((Length(Value)+2) div 3) * 4);
|
||||
Base64Encode(@Value[1],@Result[1],Length(Value));
|
||||
end;
|
||||
|
||||
function Base64Decode(pInput: pointer; pOutput: pointer; Size: longint): longint;
|
||||
var
|
||||
i, j, iptr, optr: integer;
|
||||
Temp: array[0..3] of byte;
|
||||
Input, Output: PByteArray;
|
||||
begin
|
||||
Input:= PByteArray(pInput); Output:= PByteArray(pOutput);
|
||||
iptr:= 0; optr:= 0;
|
||||
Result:= 0;
|
||||
for i:= 1 to (Size div 4) do
|
||||
begin
|
||||
for j:= 0 to 3 do
|
||||
begin
|
||||
case Input^[iptr] of
|
||||
65..90 : Temp[j]:= Input^[iptr] - Ord('A');
|
||||
97..122: Temp[j]:= Input^[iptr] - Ord('a') + 26;
|
||||
48..57 : Temp[j]:= Input^[iptr] - Ord('0') + 52;
|
||||
43 : Temp[j]:= 62;
|
||||
47 : Temp[j]:= 63;
|
||||
61 : Temp[j]:= $FF;
|
||||
end;
|
||||
Inc(iptr);
|
||||
end;
|
||||
Output^[optr]:= (Temp[0] shl 2) or (Temp[1] shr 4);
|
||||
Result:= optr+1;
|
||||
if (Temp[2]<> $FF) and (Temp[3]= $FF) then
|
||||
begin
|
||||
Output^[optr+1]:= (Temp[1] shl 4) or (Temp[2] shr 2);
|
||||
Result:= optr+2;
|
||||
Inc(optr)
|
||||
end
|
||||
else if (Temp[2]<> $FF) then
|
||||
begin
|
||||
Output^[optr+1]:= (Temp[1] shl 4) or (Temp[2] shr 2);
|
||||
Output^[optr+2]:= (Temp[2] shl 6) or Temp[3];
|
||||
Result:= optr+3;
|
||||
Inc(optr,2);
|
||||
end;
|
||||
Inc(optr);
|
||||
end;
|
||||
end;
|
||||
|
||||
function Base64DecodeStr(const Value: string): string;
|
||||
begin
|
||||
SetLength(Result,(Length(Value) div 4) * 3);
|
||||
SetLength(Result,Base64Decode(@Value[1],@Result[1],Length(Value)));
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
{******************************************************************************}
|
||||
{* DCPcrypt v2.0 written by David Barton (crypto@cityinthesky.co.uk) **********}
|
||||
{******************************************************************************}
|
||||
{* A Base64 encoding/decoding unit ********************************************}
|
||||
{******************************************************************************}
|
||||
{* Copyright (c) 1999-2002 David Barton *}
|
||||
{* Permission is hereby granted, free of charge, to any person obtaining a *}
|
||||
{* copy of this software and associated documentation files (the "Software"), *}
|
||||
{* to deal in the Software without restriction, including without limitation *}
|
||||
{* the rights to use, copy, modify, merge, publish, distribute, sublicense, *}
|
||||
{* 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: *}
|
||||
{* *}
|
||||
{* The above copyright notice and this permission notice shall be included in *}
|
||||
{* all copies or substantial portions of the Software. *}
|
||||
{* *}
|
||||
{* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *}
|
||||
{* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *}
|
||||
{* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *}
|
||||
{* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *}
|
||||
{* 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 *}
|
||||
{* DEALINGS IN THE SOFTWARE. *}
|
||||
{******************************************************************************}
|
||||
unit DCPbase64;
|
||||
|
||||
{$mode delphi}
|
||||
interface
|
||||
uses
|
||||
Sysutils;
|
||||
|
||||
function Base64EncodeStr(const Value: string): string;
|
||||
{ Encode a string into Base64 format }
|
||||
function Base64DecodeStr(const Value: string): string;
|
||||
{ Decode a Base64 format string }
|
||||
function Base64Encode(pInput: pointer; pOutput: pointer; Size: longint): longint;
|
||||
{ Encode a lump of raw data (output is (4/3) times bigger than input) }
|
||||
function Base64Decode(pInput: pointer; pOutput: pointer; Size: longint): longint;
|
||||
{ Decode a lump of raw data }
|
||||
|
||||
|
||||
{******************************************************************************}
|
||||
{******************************************************************************}
|
||||
implementation
|
||||
|
||||
|
||||
const
|
||||
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,
|
||||
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);
|
||||
|
||||
function Base64Encode(pInput: pointer; pOutput: pointer; Size: longint): longint;
|
||||
var
|
||||
i, iptr, optr: integer;
|
||||
Input, Output: PByteArray;
|
||||
begin
|
||||
Input:= PByteArray(pInput); Output:= PByteArray(pOutput);
|
||||
iptr:= 0; optr:= 0;
|
||||
for i:= 1 to (Size div 3) do
|
||||
begin
|
||||
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+2]:= B64[((Input^[iptr+1] and 15) shl 2) + (Input^[iptr+2] shr 6)];
|
||||
Output^[optr+3]:= B64[Input^[iptr+2] and 63];
|
||||
Inc(optr,4); Inc(iptr,3);
|
||||
end;
|
||||
case (Size mod 3) of
|
||||
1: begin
|
||||
Output^[optr+0]:= B64[Input^[iptr] shr 2];
|
||||
Output^[optr+1]:= B64[(Input^[iptr] and 3) shl 4];
|
||||
Output^[optr+2]:= byte('=');
|
||||
Output^[optr+3]:= byte('=');
|
||||
end;
|
||||
2: begin
|
||||
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+2]:= B64[(Input^[iptr+1] and 15) shl 2];
|
||||
Output^[optr+3]:= byte('=');
|
||||
end;
|
||||
end;
|
||||
Result:= ((Size+2) div 3) * 4;
|
||||
end;
|
||||
|
||||
function Base64EncodeStr(const Value: string): string;
|
||||
begin
|
||||
SetLength(Result,((Length(Value)+2) div 3) * 4);
|
||||
Base64Encode(@Value[1],@Result[1],Length(Value));
|
||||
end;
|
||||
|
||||
function Base64Decode(pInput: pointer; pOutput: pointer; Size: longint): longint;
|
||||
var
|
||||
i, j, iptr, optr: integer;
|
||||
Temp: array[0..3] of byte;
|
||||
Input, Output: PByteArray;
|
||||
begin
|
||||
Input:= PByteArray(pInput); Output:= PByteArray(pOutput);
|
||||
iptr:= 0; optr:= 0;
|
||||
Result:= 0;
|
||||
for i:= 1 to (Size div 4) do
|
||||
begin
|
||||
for j:= 0 to 3 do
|
||||
begin
|
||||
case Input^[iptr] of
|
||||
65..90 : Temp[j]:= Input^[iptr] - Ord('A');
|
||||
97..122: Temp[j]:= Input^[iptr] - Ord('a') + 26;
|
||||
48..57 : Temp[j]:= Input^[iptr] - Ord('0') + 52;
|
||||
43 : Temp[j]:= 62;
|
||||
47 : Temp[j]:= 63;
|
||||
61 : Temp[j]:= $FF;
|
||||
end;
|
||||
Inc(iptr);
|
||||
end;
|
||||
Output^[optr]:= (Temp[0] shl 2) or (Temp[1] shr 4);
|
||||
Result:= optr+1;
|
||||
if (Temp[2]<> $FF) and (Temp[3]= $FF) then
|
||||
begin
|
||||
Output^[optr+1]:= (Temp[1] shl 4) or (Temp[2] shr 2);
|
||||
Result:= optr+2;
|
||||
Inc(optr)
|
||||
end
|
||||
else if (Temp[2]<> $FF) then
|
||||
begin
|
||||
Output^[optr+1]:= (Temp[1] shl 4) or (Temp[2] shr 2);
|
||||
Output^[optr+2]:= (Temp[2] shl 6) or Temp[3];
|
||||
Result:= optr+3;
|
||||
Inc(optr,2);
|
||||
end;
|
||||
Inc(optr);
|
||||
end;
|
||||
end;
|
||||
|
||||
function Base64DecodeStr(const Value: string): string;
|
||||
begin
|
||||
SetLength(Result,(Length(Value) div 4) * 3);
|
||||
SetLength(Result,Base64Decode(@Value[1],@Result[1],Length(Value)));
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -1,277 +1,277 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.001 |
|
||||
|==============================================================================|
|
||||
| Content: ClamAV-daemon client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)2005-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2005-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract( ClamAV-daemon client)
|
||||
|
||||
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)
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit clamsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
synsock, blcksock, synautil;
|
||||
|
||||
const
|
||||
cClamProtocol = '3310';
|
||||
|
||||
type
|
||||
|
||||
{:@abstract(Implementation of ClamAV-daemon client protocol)
|
||||
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
|
||||
and read result.}
|
||||
TClamSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TTCPBlockSocket;
|
||||
FDSock: TTCPBlockSocket;
|
||||
FSession: boolean;
|
||||
function Login: boolean; virtual;
|
||||
function Logout: Boolean; virtual;
|
||||
function OpenStream: Boolean; virtual;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Call any command to ClamD. Used internally by other methods.}
|
||||
function DoCommand(const Value: AnsiString): AnsiString; virtual;
|
||||
|
||||
{:Return ClamAV version and version of loaded databases.}
|
||||
function GetVersion: AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStrings.}
|
||||
function ScanStrings(const Value: TStrings): AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStream.}
|
||||
function ScanStream(const Value: TStream): AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStrings by new 0.95 API.}
|
||||
function ScanStrings2(const Value: TStrings): AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStream by new 0.95 API.}
|
||||
function ScanStream2(const Value: TStream): AnsiString; virtual;
|
||||
published
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
|
||||
{:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.}
|
||||
property DSock: TTCPBlockSocket read FDSock;
|
||||
|
||||
{:Can turn-on session mode of communication with ClamD. Default is @false,
|
||||
because ClamAV developers design their TCP code very badly and session mode
|
||||
is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs
|
||||
and this mode will be possible in future.}
|
||||
property Session: boolean read FSession write FSession;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TClamSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FDSock := TTCPBlockSocket.Create;
|
||||
FDSock.Owner := self;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cClamProtocol;
|
||||
FSession := false;
|
||||
end;
|
||||
|
||||
destructor TClamSend.Destroy;
|
||||
begin
|
||||
Logout;
|
||||
FDSock.Free;
|
||||
FSock.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TClamSend.DoCommand(const Value: AnsiString): AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if not FSession then
|
||||
FSock.CloseSocket
|
||||
else
|
||||
FSock.SendString(Value + LF);
|
||||
if not FSession or (FSock.LastError <> 0) then
|
||||
begin
|
||||
if Login then
|
||||
FSock.SendString(Value + LF)
|
||||
else
|
||||
Exit;
|
||||
end;
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
|
||||
function TClamSend.Login: boolean;
|
||||
begin
|
||||
Result := False;
|
||||
Sock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
if FSession then
|
||||
FSock.SendString('SESSION' + LF);
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TClamSend.Logout: Boolean;
|
||||
begin
|
||||
FSock.SendString('END' + LF);
|
||||
Result := FSock.LastError = 0;
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TClamSend.GetVersion: AnsiString;
|
||||
begin
|
||||
Result := DoCommand('nVERSION');
|
||||
end;
|
||||
|
||||
function TClamSend.OpenStream: Boolean;
|
||||
var
|
||||
S: AnsiString;
|
||||
begin
|
||||
Result := False;
|
||||
s := DoCommand('nSTREAM');
|
||||
if (s <> '') and (Copy(s, 1, 4) = 'PORT') then
|
||||
begin
|
||||
s := SeparateRight(s, ' ');
|
||||
FDSock.CloseSocket;
|
||||
FDSock.Bind(FIPInterface, cAnyPort);
|
||||
if FDSock.LastError <> 0 then
|
||||
Exit;
|
||||
FDSock.Connect(FTargetHost, s);
|
||||
if FDSock.LastError <> 0 then
|
||||
Exit;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStrings(const Value: TStrings): AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if OpenStream then
|
||||
begin
|
||||
DSock.SendString(Value.Text);
|
||||
DSock.CloseSocket;
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStream(const Value: TStream): AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if OpenStream then
|
||||
begin
|
||||
DSock.SendStreamRaw(Value);
|
||||
DSock.CloseSocket;
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStrings2(const Value: TStrings): AnsiString;
|
||||
var
|
||||
i: integer;
|
||||
s: AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if not FSession then
|
||||
FSock.CloseSocket
|
||||
else
|
||||
FSock.sendstring('nINSTREAM' + LF);
|
||||
if not FSession or (FSock.LastError <> 0) then
|
||||
begin
|
||||
if Login then
|
||||
FSock.sendstring('nINSTREAM' + LF)
|
||||
else
|
||||
Exit;
|
||||
end;
|
||||
s := Value.text;
|
||||
i := length(s);
|
||||
FSock.SendString(CodeLongint(i) + s + #0#0#0#0);
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStream2(const Value: TStream): AnsiString;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
Result := '';
|
||||
if not FSession then
|
||||
FSock.CloseSocket
|
||||
else
|
||||
FSock.sendstring('nINSTREAM' + LF);
|
||||
if not FSession or (FSock.LastError <> 0) then
|
||||
begin
|
||||
if Login then
|
||||
FSock.sendstring('nINSTREAM' + LF)
|
||||
else
|
||||
Exit;
|
||||
end;
|
||||
i := value.Size;
|
||||
FSock.SendString(CodeLongint(i));
|
||||
FSock.SendStreamRaw(Value);
|
||||
FSock.SendString(#0#0#0#0);
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.001 |
|
||||
|==============================================================================|
|
||||
| Content: ClamAV-daemon client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)2005-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2005-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract( ClamAV-daemon client)
|
||||
|
||||
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)
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit clamsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
synsock, blcksock, synautil;
|
||||
|
||||
const
|
||||
cClamProtocol = '3310';
|
||||
|
||||
type
|
||||
|
||||
{:@abstract(Implementation of ClamAV-daemon client protocol)
|
||||
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
|
||||
and read result.}
|
||||
TClamSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TTCPBlockSocket;
|
||||
FDSock: TTCPBlockSocket;
|
||||
FSession: boolean;
|
||||
function Login: boolean; virtual;
|
||||
function Logout: Boolean; virtual;
|
||||
function OpenStream: Boolean; virtual;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Call any command to ClamD. Used internally by other methods.}
|
||||
function DoCommand(const Value: AnsiString): AnsiString; virtual;
|
||||
|
||||
{:Return ClamAV version and version of loaded databases.}
|
||||
function GetVersion: AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStrings.}
|
||||
function ScanStrings(const Value: TStrings): AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStream.}
|
||||
function ScanStream(const Value: TStream): AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStrings by new 0.95 API.}
|
||||
function ScanStrings2(const Value: TStrings): AnsiString; virtual;
|
||||
|
||||
{:Scan content of TStream by new 0.95 API.}
|
||||
function ScanStream2(const Value: TStream): AnsiString; virtual;
|
||||
published
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
|
||||
{:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.}
|
||||
property DSock: TTCPBlockSocket read FDSock;
|
||||
|
||||
{:Can turn-on session mode of communication with ClamD. Default is @false,
|
||||
because ClamAV developers design their TCP code very badly and session mode
|
||||
is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs
|
||||
and this mode will be possible in future.}
|
||||
property Session: boolean read FSession write FSession;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TClamSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FDSock := TTCPBlockSocket.Create;
|
||||
FDSock.Owner := self;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cClamProtocol;
|
||||
FSession := false;
|
||||
end;
|
||||
|
||||
destructor TClamSend.Destroy;
|
||||
begin
|
||||
Logout;
|
||||
FDSock.Free;
|
||||
FSock.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TClamSend.DoCommand(const Value: AnsiString): AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if not FSession then
|
||||
FSock.CloseSocket
|
||||
else
|
||||
FSock.SendString(Value + LF);
|
||||
if not FSession or (FSock.LastError <> 0) then
|
||||
begin
|
||||
if Login then
|
||||
FSock.SendString(Value + LF)
|
||||
else
|
||||
Exit;
|
||||
end;
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
|
||||
function TClamSend.Login: boolean;
|
||||
begin
|
||||
Result := False;
|
||||
Sock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
if FSession then
|
||||
FSock.SendString('SESSION' + LF);
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TClamSend.Logout: Boolean;
|
||||
begin
|
||||
FSock.SendString('END' + LF);
|
||||
Result := FSock.LastError = 0;
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TClamSend.GetVersion: AnsiString;
|
||||
begin
|
||||
Result := DoCommand('nVERSION');
|
||||
end;
|
||||
|
||||
function TClamSend.OpenStream: Boolean;
|
||||
var
|
||||
S: AnsiString;
|
||||
begin
|
||||
Result := False;
|
||||
s := DoCommand('nSTREAM');
|
||||
if (s <> '') and (Copy(s, 1, 4) = 'PORT') then
|
||||
begin
|
||||
s := SeparateRight(s, ' ');
|
||||
FDSock.CloseSocket;
|
||||
FDSock.Bind(FIPInterface, cAnyPort);
|
||||
if FDSock.LastError <> 0 then
|
||||
Exit;
|
||||
FDSock.Connect(FTargetHost, s);
|
||||
if FDSock.LastError <> 0 then
|
||||
Exit;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStrings(const Value: TStrings): AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if OpenStream then
|
||||
begin
|
||||
DSock.SendString(Value.Text);
|
||||
DSock.CloseSocket;
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStream(const Value: TStream): AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if OpenStream then
|
||||
begin
|
||||
DSock.SendStreamRaw(Value);
|
||||
DSock.CloseSocket;
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStrings2(const Value: TStrings): AnsiString;
|
||||
var
|
||||
i: integer;
|
||||
s: AnsiString;
|
||||
begin
|
||||
Result := '';
|
||||
if not FSession then
|
||||
FSock.CloseSocket
|
||||
else
|
||||
FSock.sendstring('nINSTREAM' + LF);
|
||||
if not FSession or (FSock.LastError <> 0) then
|
||||
begin
|
||||
if Login then
|
||||
FSock.sendstring('nINSTREAM' + LF)
|
||||
else
|
||||
Exit;
|
||||
end;
|
||||
s := Value.text;
|
||||
i := length(s);
|
||||
FSock.SendString(CodeLongint(i) + s + #0#0#0#0);
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
|
||||
function TClamSend.ScanStream2(const Value: TStream): AnsiString;
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
Result := '';
|
||||
if not FSession then
|
||||
FSock.CloseSocket
|
||||
else
|
||||
FSock.sendstring('nINSTREAM' + LF);
|
||||
if not FSession or (FSock.LastError <> 0) then
|
||||
begin
|
||||
if Login then
|
||||
FSock.sendstring('nINSTREAM' + LF)
|
||||
else
|
||||
Exit;
|
||||
end;
|
||||
i := value.Size;
|
||||
FSock.SendString(CodeLongint(i));
|
||||
FSock.SendStreamRaw(Value);
|
||||
FSock.SendString(#0#0#0#0);
|
||||
Result := FSock.RecvTerminated(FTimeout, LF);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -1,403 +1,403 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.001 |
|
||||
|==============================================================================|
|
||||
| Content: Trivial FTP (TFTP) client and server |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{: @abstract(TFTP client and server protocol)
|
||||
|
||||
Used RFC: RFC-1350
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit ftptsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cTFTPProtocol = '69';
|
||||
|
||||
cTFTP_RRQ = word(1);
|
||||
cTFTP_WRQ = word(2);
|
||||
cTFTP_DTA = word(3);
|
||||
cTFTP_ACK = word(4);
|
||||
cTFTP_ERR = word(5);
|
||||
|
||||
type
|
||||
{:@abstract(Implementation of TFTP client and server)
|
||||
Note: Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TTFTPSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TUDPBlockSocket;
|
||||
FErrorCode: integer;
|
||||
FErrorString: string;
|
||||
FData: TMemoryStream;
|
||||
FRequestIP: string;
|
||||
FRequestPort: string;
|
||||
function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
|
||||
function RecvPacket(Serial: word; var Value: string): Boolean;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Upload @link(data) as file to TFTP server.}
|
||||
function SendFile(const Filename: string): Boolean;
|
||||
|
||||
{:Download file from TFTP server to @link(data).}
|
||||
function RecvFile(const Filename: string): Boolean;
|
||||
|
||||
{:Acts as TFTP server and wait for client request. When some request
|
||||
incoming within Timeout, result is @true and parametres is filled with
|
||||
information from request. You must handle this request, validate it, and
|
||||
call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
|
||||
to TFTP Client.}
|
||||
function WaitForRequest(var Req: word; var filename: string): Boolean;
|
||||
|
||||
{:send error to TFTP client, when you acts as TFTP server.}
|
||||
procedure ReplyError(Error: word; Description: string);
|
||||
|
||||
{:Accept uploaded file from TFTP client to @link(data), when you acts as
|
||||
TFTP server.}
|
||||
function ReplyRecv: Boolean;
|
||||
|
||||
{:Accept download request file from TFTP client and send content of
|
||||
@link(data), when you acts as TFTP server.}
|
||||
function ReplySend: Boolean;
|
||||
published
|
||||
{:Code of TFTP error.}
|
||||
property ErrorCode: integer read FErrorCode;
|
||||
|
||||
{:Human readable decription of TFTP error. (if is sended by remote side)}
|
||||
property ErrorString: string read FErrorString;
|
||||
|
||||
{:MemoryStream with datas for sending or receiving}
|
||||
property Data: TMemoryStream read FData;
|
||||
|
||||
{:Address of TFTP remote side.}
|
||||
property RequestIP: string read FRequestIP write FRequestIP;
|
||||
|
||||
{:Port of TFTP remote side.}
|
||||
property RequestPort: string read FRequestPort write FRequestPort;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TTFTPSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TUDPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FTargetPort := cTFTPProtocol;
|
||||
FData := TMemoryStream.Create;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
end;
|
||||
|
||||
destructor TTFTPSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FData.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
|
||||
var
|
||||
s, sh: string;
|
||||
begin
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
Result := false;
|
||||
if Cmd <> 2 then
|
||||
s := CodeInt(Cmd) + CodeInt(Serial) + Value
|
||||
else
|
||||
s := CodeInt(Cmd) + Value;
|
||||
FSock.SendString(s);
|
||||
s := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
if length(s) >= 4 then
|
||||
begin
|
||||
sh := CodeInt(4) + CodeInt(Serial);
|
||||
if Pos(sh, s) = 1 then
|
||||
Result := True
|
||||
else
|
||||
if s[1] = #5 then
|
||||
begin
|
||||
FErrorCode := DecodeInt(s, 3);
|
||||
Delete(s, 1, 4);
|
||||
FErrorString := SeparateLeft(s, #0);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
begin
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
Result := False;
|
||||
Value := '';
|
||||
s := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
if length(s) >= 4 then
|
||||
if DecodeInt(s, 1) = 3 then
|
||||
begin
|
||||
ser := DecodeInt(s, 3);
|
||||
if ser = Serial then
|
||||
begin
|
||||
Delete(s, 1, 4);
|
||||
Value := s;
|
||||
S := CodeInt(4) + CodeInt(ser);
|
||||
FSock.SendString(s);
|
||||
Result := FSock.LastError = 0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
|
||||
FSock.SendString(s);
|
||||
end;
|
||||
end;
|
||||
if DecodeInt(s, 1) = 5 then
|
||||
begin
|
||||
FErrorCode := DecodeInt(s, 3);
|
||||
Delete(s, 1, 4);
|
||||
FErrorString := SeparateLeft(s, #0);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.SendFile(const Filename: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
n, n1, n2: integer;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
try
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
s := Filename + #0 + 'octet' + #0;
|
||||
if not Sendpacket(2, 0, s) then
|
||||
Exit;
|
||||
ser := 1;
|
||||
FData.Position := 0;
|
||||
n1 := FData.Size div 512;
|
||||
n2 := FData.Size mod 512;
|
||||
for n := 1 to n1 do
|
||||
begin
|
||||
s := ReadStrFromStream(FData, 512);
|
||||
// SetLength(s, 512);
|
||||
// FData.Read(pointer(s)^, 512);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
end;
|
||||
s := ReadStrFromStream(FData, n2);
|
||||
// SetLength(s, n2);
|
||||
// FData.Read(pointer(s)^, n2);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
Result := True;
|
||||
end;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.RecvFile(const Filename: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
try
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
s := CodeInt(1) + Filename + #0 + 'octet' + #0;
|
||||
FSock.SendString(s);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
FData.Clear;
|
||||
ser := 1;
|
||||
repeat
|
||||
if not RecvPacket(ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
WriteStrToStream(FData, s);
|
||||
// FData.Write(pointer(s)^, length(s));
|
||||
until length(s) <> 512;
|
||||
FData.Position := 0;
|
||||
Result := true;
|
||||
end;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind('0.0.0.0', FTargetPort);
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
s := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
if Length(s) >= 4 then
|
||||
begin
|
||||
FRequestIP := FSock.GetRemoteSinIP;
|
||||
FRequestPort := IntToStr(FSock.GetRemoteSinPort);
|
||||
Req := DecodeInt(s, 1);
|
||||
delete(s, 1, 2);
|
||||
filename := Trim(SeparateLeft(s, #0));
|
||||
s := SeparateRight(s, #0);
|
||||
s := SeparateLeft(s, #0);
|
||||
Result := lowercase(trim(s)) = 'octet';
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTFTPSend.ReplyError(Error: word; Description: string);
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FRequestIP, FRequestPort);
|
||||
s := CodeInt(5) + CodeInt(Error) + Description + #0;
|
||||
FSock.SendString(s);
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TTFTPSend.ReplyRecv: Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: integer;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FRequestIP, FRequestPort);
|
||||
try
|
||||
s := CodeInt(4) + CodeInt(0);
|
||||
FSock.SendString(s);
|
||||
FData.Clear;
|
||||
ser := 1;
|
||||
repeat
|
||||
if not RecvPacket(ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
WriteStrToStream(FData, s);
|
||||
// FData.Write(pointer(s)^, length(s));
|
||||
until length(s) <> 512;
|
||||
FData.Position := 0;
|
||||
Result := true;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.ReplySend: Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
n, n1, n2: integer;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FRequestIP, FRequestPort);
|
||||
try
|
||||
ser := 1;
|
||||
FData.Position := 0;
|
||||
n1 := FData.Size div 512;
|
||||
n2 := FData.Size mod 512;
|
||||
for n := 1 to n1 do
|
||||
begin
|
||||
s := ReadStrFromStream(FData, 512);
|
||||
// SetLength(s, 512);
|
||||
// FData.Read(pointer(s)^, 512);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
end;
|
||||
s := ReadStrFromStream(FData, n2);
|
||||
// SetLength(s, n2);
|
||||
// FData.Read(pointer(s)^, n2);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
Result := True;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.001 |
|
||||
|==============================================================================|
|
||||
| Content: Trivial FTP (TFTP) client and server |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{: @abstract(TFTP client and server protocol)
|
||||
|
||||
Used RFC: RFC-1350
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit ftptsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cTFTPProtocol = '69';
|
||||
|
||||
cTFTP_RRQ = word(1);
|
||||
cTFTP_WRQ = word(2);
|
||||
cTFTP_DTA = word(3);
|
||||
cTFTP_ACK = word(4);
|
||||
cTFTP_ERR = word(5);
|
||||
|
||||
type
|
||||
{:@abstract(Implementation of TFTP client and server)
|
||||
Note: Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TTFTPSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TUDPBlockSocket;
|
||||
FErrorCode: integer;
|
||||
FErrorString: string;
|
||||
FData: TMemoryStream;
|
||||
FRequestIP: string;
|
||||
FRequestPort: string;
|
||||
function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
|
||||
function RecvPacket(Serial: word; var Value: string): Boolean;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Upload @link(data) as file to TFTP server.}
|
||||
function SendFile(const Filename: string): Boolean;
|
||||
|
||||
{:Download file from TFTP server to @link(data).}
|
||||
function RecvFile(const Filename: string): Boolean;
|
||||
|
||||
{:Acts as TFTP server and wait for client request. When some request
|
||||
incoming within Timeout, result is @true and parametres is filled with
|
||||
information from request. You must handle this request, validate it, and
|
||||
call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
|
||||
to TFTP Client.}
|
||||
function WaitForRequest(var Req: word; var filename: string): Boolean;
|
||||
|
||||
{:send error to TFTP client, when you acts as TFTP server.}
|
||||
procedure ReplyError(Error: word; Description: string);
|
||||
|
||||
{:Accept uploaded file from TFTP client to @link(data), when you acts as
|
||||
TFTP server.}
|
||||
function ReplyRecv: Boolean;
|
||||
|
||||
{:Accept download request file from TFTP client and send content of
|
||||
@link(data), when you acts as TFTP server.}
|
||||
function ReplySend: Boolean;
|
||||
published
|
||||
{:Code of TFTP error.}
|
||||
property ErrorCode: integer read FErrorCode;
|
||||
|
||||
{:Human readable decription of TFTP error. (if is sended by remote side)}
|
||||
property ErrorString: string read FErrorString;
|
||||
|
||||
{:MemoryStream with datas for sending or receiving}
|
||||
property Data: TMemoryStream read FData;
|
||||
|
||||
{:Address of TFTP remote side.}
|
||||
property RequestIP: string read FRequestIP write FRequestIP;
|
||||
|
||||
{:Port of TFTP remote side.}
|
||||
property RequestPort: string read FRequestPort write FRequestPort;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TTFTPSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TUDPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FTargetPort := cTFTPProtocol;
|
||||
FData := TMemoryStream.Create;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
end;
|
||||
|
||||
destructor TTFTPSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FData.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
|
||||
var
|
||||
s, sh: string;
|
||||
begin
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
Result := false;
|
||||
if Cmd <> 2 then
|
||||
s := CodeInt(Cmd) + CodeInt(Serial) + Value
|
||||
else
|
||||
s := CodeInt(Cmd) + Value;
|
||||
FSock.SendString(s);
|
||||
s := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
if length(s) >= 4 then
|
||||
begin
|
||||
sh := CodeInt(4) + CodeInt(Serial);
|
||||
if Pos(sh, s) = 1 then
|
||||
Result := True
|
||||
else
|
||||
if s[1] = #5 then
|
||||
begin
|
||||
FErrorCode := DecodeInt(s, 3);
|
||||
Delete(s, 1, 4);
|
||||
FErrorString := SeparateLeft(s, #0);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
begin
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
Result := False;
|
||||
Value := '';
|
||||
s := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
if length(s) >= 4 then
|
||||
if DecodeInt(s, 1) = 3 then
|
||||
begin
|
||||
ser := DecodeInt(s, 3);
|
||||
if ser = Serial then
|
||||
begin
|
||||
Delete(s, 1, 4);
|
||||
Value := s;
|
||||
S := CodeInt(4) + CodeInt(ser);
|
||||
FSock.SendString(s);
|
||||
Result := FSock.LastError = 0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
|
||||
FSock.SendString(s);
|
||||
end;
|
||||
end;
|
||||
if DecodeInt(s, 1) = 5 then
|
||||
begin
|
||||
FErrorCode := DecodeInt(s, 3);
|
||||
Delete(s, 1, 4);
|
||||
FErrorString := SeparateLeft(s, #0);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.SendFile(const Filename: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
n, n1, n2: integer;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
try
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
s := Filename + #0 + 'octet' + #0;
|
||||
if not Sendpacket(2, 0, s) then
|
||||
Exit;
|
||||
ser := 1;
|
||||
FData.Position := 0;
|
||||
n1 := FData.Size div 512;
|
||||
n2 := FData.Size mod 512;
|
||||
for n := 1 to n1 do
|
||||
begin
|
||||
s := ReadStrFromStream(FData, 512);
|
||||
// SetLength(s, 512);
|
||||
// FData.Read(pointer(s)^, 512);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
end;
|
||||
s := ReadStrFromStream(FData, n2);
|
||||
// SetLength(s, n2);
|
||||
// FData.Read(pointer(s)^, n2);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
Result := True;
|
||||
end;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.RecvFile(const Filename: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
try
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
s := CodeInt(1) + Filename + #0 + 'octet' + #0;
|
||||
FSock.SendString(s);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
FData.Clear;
|
||||
ser := 1;
|
||||
repeat
|
||||
if not RecvPacket(ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
WriteStrToStream(FData, s);
|
||||
// FData.Write(pointer(s)^, length(s));
|
||||
until length(s) <> 512;
|
||||
FData.Position := 0;
|
||||
Result := true;
|
||||
end;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind('0.0.0.0', FTargetPort);
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
s := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
if Length(s) >= 4 then
|
||||
begin
|
||||
FRequestIP := FSock.GetRemoteSinIP;
|
||||
FRequestPort := IntToStr(FSock.GetRemoteSinPort);
|
||||
Req := DecodeInt(s, 1);
|
||||
delete(s, 1, 2);
|
||||
filename := Trim(SeparateLeft(s, #0));
|
||||
s := SeparateRight(s, #0);
|
||||
s := SeparateLeft(s, #0);
|
||||
Result := lowercase(trim(s)) = 'octet';
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTFTPSend.ReplyError(Error: word; Description: string);
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FRequestIP, FRequestPort);
|
||||
s := CodeInt(5) + CodeInt(Error) + Description + #0;
|
||||
FSock.SendString(s);
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TTFTPSend.ReplyRecv: Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: integer;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FRequestIP, FRequestPort);
|
||||
try
|
||||
s := CodeInt(4) + CodeInt(0);
|
||||
FSock.SendString(s);
|
||||
FData.Clear;
|
||||
ser := 1;
|
||||
repeat
|
||||
if not RecvPacket(ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
WriteStrToStream(FData, s);
|
||||
// FData.Write(pointer(s)^, length(s));
|
||||
until length(s) <> 512;
|
||||
FData.Position := 0;
|
||||
Result := true;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTFTPSend.ReplySend: Boolean;
|
||||
var
|
||||
s: string;
|
||||
ser: word;
|
||||
n, n1, n2: integer;
|
||||
begin
|
||||
Result := False;
|
||||
FErrorCode := 0;
|
||||
FErrorString := '';
|
||||
FSock.CloseSocket;
|
||||
FSock.Connect(FRequestIP, FRequestPort);
|
||||
try
|
||||
ser := 1;
|
||||
FData.Position := 0;
|
||||
n1 := FData.Size div 512;
|
||||
n2 := FData.Size mod 512;
|
||||
for n := 1 to n1 do
|
||||
begin
|
||||
s := ReadStrFromStream(FData, 512);
|
||||
// SetLength(s, 512);
|
||||
// FData.Read(pointer(s)^, 512);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
inc(ser);
|
||||
end;
|
||||
s := ReadStrFromStream(FData, n2);
|
||||
// SetLength(s, n2);
|
||||
// FData.Read(pointer(s)^, n2);
|
||||
if not Sendpacket(3, ser, s) then
|
||||
Exit;
|
||||
Result := True;
|
||||
finally
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
end.
|
||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -1,263 +1,263 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.011 |
|
||||
|==============================================================================|
|
||||
| Content: Inline MIME support procedures and functions |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2006, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(Utilities for inline MIME)
|
||||
Support for Inline MIME encoding and decoding.
|
||||
|
||||
Used RFC: RFC-2047, RFC-2231
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit mimeinln;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
synachar, synacode, synautil;
|
||||
|
||||
{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".}
|
||||
function InlineDecode(const Value: string; CP: TMimeChar): string;
|
||||
|
||||
{:Encodes string to MIME inline encoding. The source characterset is "CP", and
|
||||
the target charset is "MimeP".}
|
||||
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
|
||||
|
||||
{:Returns @true, if "Value" contains characters needed for inline coding.}
|
||||
function NeedInline(const Value: AnsiString): boolean;
|
||||
|
||||
{:Inline mime encoding similar to @link(InlineEncode), but you can specify
|
||||
source charset, and the target characterset is automatically assigned.}
|
||||
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
|
||||
|
||||
{:Inline MIME encoding similar to @link(InlineEncode), but the source charset
|
||||
is automatically set to the system default charset, and the target charset is
|
||||
automatically assigned from set of allowed encoding for MIME.}
|
||||
function InlineCode(const Value: string): string;
|
||||
|
||||
{:Converts e-mail address to canonical mime form. You can specify source charset.}
|
||||
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
|
||||
|
||||
{:Converts e-mail address to canonical mime form. Source charser it system
|
||||
default charset.}
|
||||
function InlineEmail(const Value: string): string;
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineDecode(const Value: string; CP: TMimeChar): string;
|
||||
var
|
||||
s, su, v: string;
|
||||
x, y, z, n: Integer;
|
||||
ichar: TMimeChar;
|
||||
c: Char;
|
||||
|
||||
function SearchEndInline(const Value: string; be: Integer): Integer;
|
||||
var
|
||||
n, q: Integer;
|
||||
begin
|
||||
q := 0;
|
||||
Result := 0;
|
||||
for n := be + 2 to Length(Value) - 1 do
|
||||
if Value[n] = '?' then
|
||||
begin
|
||||
Inc(q);
|
||||
if (q > 2) and (Value[n + 1] = '=') then
|
||||
begin
|
||||
Result := n;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
Result := '';
|
||||
v := Value;
|
||||
x := Pos('=?', v);
|
||||
y := SearchEndInline(v, x);
|
||||
//fix for broken coding with begin, but not with end.
|
||||
if (x > 0) and (y <= 0) then
|
||||
y := Length(Result);
|
||||
while (y > x) and (x > 0) do
|
||||
begin
|
||||
s := Copy(v, 1, x - 1);
|
||||
if Trim(s) <> '' then
|
||||
Result := Result + s;
|
||||
s := Copy(v, x, y - x + 2);
|
||||
Delete(v, 1, y + 1);
|
||||
su := Copy(s, 3, Length(s) - 4);
|
||||
z := Pos('?', su);
|
||||
if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
|
||||
begin
|
||||
ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*'));
|
||||
c := UpperCase(su)[z + 1];
|
||||
su := Copy(su, z + 3, Length(su) - z - 2);
|
||||
if c = 'B' then
|
||||
begin
|
||||
s := DecodeBase64(su);
|
||||
s := CharsetConversion(s, ichar, CP);
|
||||
end;
|
||||
if c = 'Q' then
|
||||
begin
|
||||
s := '';
|
||||
for n := 1 to Length(su) do
|
||||
if su[n] = '_' then
|
||||
s := s + ' '
|
||||
else
|
||||
s := s + su[n];
|
||||
s := DecodeQuotedPrintable(s);
|
||||
s := CharsetConversion(s, ichar, CP);
|
||||
end;
|
||||
end;
|
||||
Result := Result + s;
|
||||
x := Pos('=?', v);
|
||||
y := SearchEndInline(v, x);
|
||||
end;
|
||||
Result := Result + v;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
|
||||
var
|
||||
s, s1, e: string;
|
||||
n: Integer;
|
||||
begin
|
||||
s := CharsetConversion(Value, CP, MimeP);
|
||||
s := EncodeSafeQuotedPrintable(s);
|
||||
e := GetIdFromCP(MimeP);
|
||||
s1 := '';
|
||||
Result := '';
|
||||
for n := 1 to Length(s) do
|
||||
if s[n] = ' ' then
|
||||
begin
|
||||
// s1 := s1 + '=20';
|
||||
s1 := s1 + '_';
|
||||
if Length(s1) > 32 then
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ' ';
|
||||
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
|
||||
s1 := '';
|
||||
end;
|
||||
end
|
||||
else
|
||||
s1 := s1 + s[n];
|
||||
if s1 <> '' then
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ' ';
|
||||
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function NeedInline(const Value: AnsiString): boolean;
|
||||
var
|
||||
n: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
for n := 1 to Length(Value) do
|
||||
if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then
|
||||
begin
|
||||
Result := True;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
|
||||
var
|
||||
c: TMimeChar;
|
||||
begin
|
||||
if NeedInline(Value) then
|
||||
begin
|
||||
c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
|
||||
Result := InlineEncode(Value, FromCP, c);
|
||||
end
|
||||
else
|
||||
Result := Value;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineCode(const Value: string): string;
|
||||
begin
|
||||
Result := InlineCodeEx(Value, GetCurCP);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
|
||||
var
|
||||
sd, se: string;
|
||||
begin
|
||||
sd := GetEmailDesc(Value);
|
||||
se := GetEmailAddr(Value);
|
||||
if sd = '' then
|
||||
Result := se
|
||||
else
|
||||
Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineEmail(const Value: string): string;
|
||||
begin
|
||||
Result := InlineEmailEx(Value, GetCurCP);
|
||||
end;
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.011 |
|
||||
|==============================================================================|
|
||||
| Content: Inline MIME support procedures and functions |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2006, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(Utilities for inline MIME)
|
||||
Support for Inline MIME encoding and decoding.
|
||||
|
||||
Used RFC: RFC-2047, RFC-2231
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit mimeinln;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
synachar, synacode, synautil;
|
||||
|
||||
{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".}
|
||||
function InlineDecode(const Value: string; CP: TMimeChar): string;
|
||||
|
||||
{:Encodes string to MIME inline encoding. The source characterset is "CP", and
|
||||
the target charset is "MimeP".}
|
||||
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
|
||||
|
||||
{:Returns @true, if "Value" contains characters needed for inline coding.}
|
||||
function NeedInline(const Value: AnsiString): boolean;
|
||||
|
||||
{:Inline mime encoding similar to @link(InlineEncode), but you can specify
|
||||
source charset, and the target characterset is automatically assigned.}
|
||||
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
|
||||
|
||||
{:Inline MIME encoding similar to @link(InlineEncode), but the source charset
|
||||
is automatically set to the system default charset, and the target charset is
|
||||
automatically assigned from set of allowed encoding for MIME.}
|
||||
function InlineCode(const Value: string): string;
|
||||
|
||||
{:Converts e-mail address to canonical mime form. You can specify source charset.}
|
||||
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
|
||||
|
||||
{:Converts e-mail address to canonical mime form. Source charser it system
|
||||
default charset.}
|
||||
function InlineEmail(const Value: string): string;
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineDecode(const Value: string; CP: TMimeChar): string;
|
||||
var
|
||||
s, su, v: string;
|
||||
x, y, z, n: Integer;
|
||||
ichar: TMimeChar;
|
||||
c: Char;
|
||||
|
||||
function SearchEndInline(const Value: string; be: Integer): Integer;
|
||||
var
|
||||
n, q: Integer;
|
||||
begin
|
||||
q := 0;
|
||||
Result := 0;
|
||||
for n := be + 2 to Length(Value) - 1 do
|
||||
if Value[n] = '?' then
|
||||
begin
|
||||
Inc(q);
|
||||
if (q > 2) and (Value[n + 1] = '=') then
|
||||
begin
|
||||
Result := n;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
Result := '';
|
||||
v := Value;
|
||||
x := Pos('=?', v);
|
||||
y := SearchEndInline(v, x);
|
||||
//fix for broken coding with begin, but not with end.
|
||||
if (x > 0) and (y <= 0) then
|
||||
y := Length(Result);
|
||||
while (y > x) and (x > 0) do
|
||||
begin
|
||||
s := Copy(v, 1, x - 1);
|
||||
if Trim(s) <> '' then
|
||||
Result := Result + s;
|
||||
s := Copy(v, x, y - x + 2);
|
||||
Delete(v, 1, y + 1);
|
||||
su := Copy(s, 3, Length(s) - 4);
|
||||
z := Pos('?', su);
|
||||
if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
|
||||
begin
|
||||
ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*'));
|
||||
c := UpperCase(su)[z + 1];
|
||||
su := Copy(su, z + 3, Length(su) - z - 2);
|
||||
if c = 'B' then
|
||||
begin
|
||||
s := DecodeBase64(su);
|
||||
s := CharsetConversion(s, ichar, CP);
|
||||
end;
|
||||
if c = 'Q' then
|
||||
begin
|
||||
s := '';
|
||||
for n := 1 to Length(su) do
|
||||
if su[n] = '_' then
|
||||
s := s + ' '
|
||||
else
|
||||
s := s + su[n];
|
||||
s := DecodeQuotedPrintable(s);
|
||||
s := CharsetConversion(s, ichar, CP);
|
||||
end;
|
||||
end;
|
||||
Result := Result + s;
|
||||
x := Pos('=?', v);
|
||||
y := SearchEndInline(v, x);
|
||||
end;
|
||||
Result := Result + v;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
|
||||
var
|
||||
s, s1, e: string;
|
||||
n: Integer;
|
||||
begin
|
||||
s := CharsetConversion(Value, CP, MimeP);
|
||||
s := EncodeSafeQuotedPrintable(s);
|
||||
e := GetIdFromCP(MimeP);
|
||||
s1 := '';
|
||||
Result := '';
|
||||
for n := 1 to Length(s) do
|
||||
if s[n] = ' ' then
|
||||
begin
|
||||
// s1 := s1 + '=20';
|
||||
s1 := s1 + '_';
|
||||
if Length(s1) > 32 then
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ' ';
|
||||
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
|
||||
s1 := '';
|
||||
end;
|
||||
end
|
||||
else
|
||||
s1 := s1 + s[n];
|
||||
if s1 <> '' then
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ' ';
|
||||
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function NeedInline(const Value: AnsiString): boolean;
|
||||
var
|
||||
n: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
for n := 1 to Length(Value) do
|
||||
if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then
|
||||
begin
|
||||
Result := True;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
|
||||
var
|
||||
c: TMimeChar;
|
||||
begin
|
||||
if NeedInline(Value) then
|
||||
begin
|
||||
c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
|
||||
Result := InlineEncode(Value, FromCP, c);
|
||||
end
|
||||
else
|
||||
Result := Value;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineCode(const Value: string): string;
|
||||
begin
|
||||
Result := InlineCodeEx(Value, GetCurCP);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
|
||||
var
|
||||
sd, se: string;
|
||||
begin
|
||||
sd := GetEmailDesc(Value);
|
||||
se := GetEmailAddr(Value);
|
||||
if sd = '' then
|
||||
Result := se
|
||||
else
|
||||
Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function InlineEmail(const Value: string): string;
|
||||
begin
|
||||
Result := InlineEmailEx(Value, GetCurCP);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -1,481 +1,481 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.005.002 |
|
||||
|==============================================================================|
|
||||
| Content: NNTP client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(NNTP client)
|
||||
NNTP (network news transfer protocol)
|
||||
|
||||
Used RFC: RFC-977, RFC-2980
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$WARN SUSPICIOUS_TYPECAST OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit nntpsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cNNTPProtocol = '119';
|
||||
|
||||
type
|
||||
|
||||
{:abstract(Implementation of Network News Transfer Protocol.
|
||||
|
||||
Note: Are you missing properties for setting Username and Password? Look to
|
||||
parent @link(TSynaClient) object!
|
||||
|
||||
Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TNNTPSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TTCPBlockSocket;
|
||||
FResultCode: Integer;
|
||||
FResultString: string;
|
||||
FData: TStringList;
|
||||
FDataToSend: TStringList;
|
||||
FAutoTLS: Boolean;
|
||||
FFullSSL: Boolean;
|
||||
FNNTPcap: TStringList;
|
||||
function ReadResult: Integer;
|
||||
function ReadData: boolean;
|
||||
function SendData: boolean;
|
||||
function Connect: Boolean;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Connects to NNTP server and begin session.}
|
||||
function Login: Boolean;
|
||||
|
||||
{:Logout from NNTP server and terminate session.}
|
||||
function Logout: Boolean;
|
||||
|
||||
{:By this you can call any NNTP command.}
|
||||
function DoCommand(const Command: string): boolean;
|
||||
|
||||
{:by this you can call any NNTP command. This variant is used for commands
|
||||
for download information from server.}
|
||||
function DoCommandRead(const Command: string): boolean;
|
||||
|
||||
{:by this you can call any NNTP command. This variant is used for commands
|
||||
for upload information to server.}
|
||||
function DoCommandWrite(const Command: string): boolean;
|
||||
|
||||
{:Download full message to @link(data) property. Value can be number of
|
||||
message or message-id (in brackets).}
|
||||
function GetArticle(const Value: string): Boolean;
|
||||
|
||||
{:Download only body of message to @link(data) property. Value can be number
|
||||
of message or message-id (in brackets).}
|
||||
function GetBody(const Value: string): Boolean;
|
||||
|
||||
{:Download only headers of message to @link(data) property. Value can be
|
||||
number of message or message-id (in brackets).}
|
||||
function GetHead(const Value: string): Boolean;
|
||||
|
||||
{:Get message status. Value can be number of message or message-id
|
||||
(in brackets).}
|
||||
function GetStat(const Value: string): Boolean;
|
||||
|
||||
{:Select given group.}
|
||||
function SelectGroup(const Value: string): Boolean;
|
||||
|
||||
{:Tell to server 'I have mesage with given message-ID.' If server need this
|
||||
message, message is uploaded to server.}
|
||||
function IHave(const MessID: string): Boolean;
|
||||
|
||||
{:Move message pointer to last item in group.}
|
||||
function GotoLast: Boolean;
|
||||
|
||||
{:Move message pointer to next item in group.}
|
||||
function GotoNext: Boolean;
|
||||
|
||||
{:Download to @link(data) property list of all groups on NNTP server.}
|
||||
function ListGroups: Boolean;
|
||||
|
||||
{:Download to @link(data) property list of all groups created after given time.}
|
||||
function ListNewGroups(Since: TDateTime): Boolean;
|
||||
|
||||
{:Download to @link(data) property list of message-ids in given group since
|
||||
given time.}
|
||||
function NewArticles(const Group: string; Since: TDateTime): Boolean;
|
||||
|
||||
{:Upload new article to server. (for new messages by you)}
|
||||
function PostArticle: Boolean;
|
||||
|
||||
{:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP
|
||||
server'.}
|
||||
function SwitchToSlave: Boolean;
|
||||
|
||||
{:Call NNTP XOVER command.}
|
||||
function Xover(xoStart, xoEnd: string): boolean;
|
||||
|
||||
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
|
||||
function StartTLS: Boolean;
|
||||
|
||||
{:Try to find given capability in extension list. This list is getted after
|
||||
successful login to NNTP server. If extension capability is not found,
|
||||
then return is empty string.}
|
||||
function FindCap(const Value: string): string;
|
||||
|
||||
{:Try get list of server extensions. List is returned in @link(data) property.}
|
||||
function ListExtensions: Boolean;
|
||||
published
|
||||
{:Result code number of last operation.}
|
||||
property ResultCode: Integer read FResultCode;
|
||||
|
||||
{:String description of last result code from NNTP server.}
|
||||
property ResultString: string read FResultString;
|
||||
|
||||
{:Readed data. (message, etc.)}
|
||||
property Data: TStringList read FData;
|
||||
|
||||
{:If is set to @true, then upgrade to SSL/TLS mode after login if remote
|
||||
server support it.}
|
||||
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
|
||||
|
||||
{:SSL/TLS mode is used from first contact to server. Servers with full
|
||||
SSL/TLS mode usualy using non-standard TCP port!}
|
||||
property FullSSL: Boolean read FFullSSL Write FFullSSL;
|
||||
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TNNTPSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FData := TStringList.Create;
|
||||
FDataToSend := TStringList.Create;
|
||||
FNNTPcap := TStringList.Create;
|
||||
FSock.ConvertLineEnd := True;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cNNTPProtocol;
|
||||
FAutoTLS := False;
|
||||
FFullSSL := False;
|
||||
end;
|
||||
|
||||
destructor TNNTPSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FDataToSend.Free;
|
||||
FData.Free;
|
||||
FNNTPcap.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TNNTPSend.ReadResult: Integer;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
Result := 0;
|
||||
FData.Clear;
|
||||
s := FSock.RecvString(FTimeout);
|
||||
FResultString := Copy(s, 5, Length(s) - 4);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
if Length(s) >= 3 then
|
||||
Result := StrToIntDef(Copy(s, 1, 3), 0);
|
||||
FResultCode := Result;
|
||||
end;
|
||||
|
||||
function TNNTPSend.ReadData: boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if s = '.' then
|
||||
break;
|
||||
if (s <> '') and (s[1] = '.') then
|
||||
s := Copy(s, 2, Length(s) - 1);
|
||||
FData.Add(s);
|
||||
until FSock.LastError <> 0;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TNNTPSend.SendData: boolean;
|
||||
var
|
||||
s: string;
|
||||
n: integer;
|
||||
begin
|
||||
for n := 0 to FDataToSend.Count - 1 do
|
||||
begin
|
||||
s := FDataToSend[n];
|
||||
if (s <> '') and (s[1] = '.') then
|
||||
s := s + '.';
|
||||
FSock.SendString(s + CRLF);
|
||||
if FSock.LastError <> 0 then
|
||||
break;
|
||||
end;
|
||||
if FDataToSend.Count = 0 then
|
||||
FSock.SendString(CRLF);
|
||||
if FSock.LastError = 0 then
|
||||
FSock.SendString('.' + CRLF);
|
||||
FDataToSend.Clear;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TNNTPSend.Connect: Boolean;
|
||||
begin
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
if FSock.LastError = 0 then
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
if FSock.LastError = 0 then
|
||||
if FFullSSL then
|
||||
FSock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TNNTPSend.Login: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
FNNTPcap.Clear;
|
||||
if not Connect then
|
||||
Exit;
|
||||
Result := (ReadResult div 100) = 2;
|
||||
ListExtensions;
|
||||
FNNTPcap.Assign(Fdata);
|
||||
if Result then
|
||||
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
|
||||
Result := StartTLS;
|
||||
if (FUsername <> '') and Result then
|
||||
begin
|
||||
FSock.SendString('AUTHINFO USER ' + FUsername + CRLF);
|
||||
if (ReadResult div 100) = 3 then
|
||||
begin
|
||||
FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF);
|
||||
Result := (ReadResult div 100) = 2;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TNNTPSend.Logout: Boolean;
|
||||
begin
|
||||
FSock.SendString('QUIT' + CRLF);
|
||||
Result := (ReadResult div 100) = 2;
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TNNTPSend.DoCommand(const Command: string): Boolean;
|
||||
begin
|
||||
FSock.SendString(Command + CRLF);
|
||||
Result := (ReadResult div 100) = 2;
|
||||
Result := Result and (FSock.LastError = 0);
|
||||
end;
|
||||
|
||||
function TNNTPSend.DoCommandRead(const Command: string): Boolean;
|
||||
begin
|
||||
Result := DoCommand(Command);
|
||||
if Result then
|
||||
begin
|
||||
Result := ReadData;
|
||||
Result := Result and (FSock.LastError = 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TNNTPSend.DoCommandWrite(const Command: string): Boolean;
|
||||
var
|
||||
x: integer;
|
||||
begin
|
||||
FDataToSend.Assign(FData);
|
||||
FSock.SendString(Command + CRLF);
|
||||
x := (ReadResult div 100);
|
||||
if x = 3 then
|
||||
begin
|
||||
SendData;
|
||||
x := (ReadResult div 100);
|
||||
end;
|
||||
Result := x = 2;
|
||||
Result := Result and (FSock.LastError = 0);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetArticle(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'ARTICLE';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetBody(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'BODY';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetHead(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'HEAD';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetStat(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'STAT';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommand(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.SelectGroup(const Value: string): Boolean;
|
||||
begin
|
||||
Result := DoCommand('GROUP ' + Value);
|
||||
end;
|
||||
|
||||
function TNNTPSend.IHave(const MessID: string): Boolean;
|
||||
begin
|
||||
Result := DoCommandWrite('IHAVE ' + MessID);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GotoLast: Boolean;
|
||||
begin
|
||||
Result := DoCommand('LAST');
|
||||
end;
|
||||
|
||||
function TNNTPSend.GotoNext: Boolean;
|
||||
begin
|
||||
Result := DoCommand('NEXT');
|
||||
end;
|
||||
|
||||
function TNNTPSend.ListGroups: Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('LIST');
|
||||
end;
|
||||
|
||||
function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT');
|
||||
end;
|
||||
|
||||
function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT');
|
||||
end;
|
||||
|
||||
function TNNTPSend.PostArticle: Boolean;
|
||||
begin
|
||||
Result := DoCommandWrite('POST');
|
||||
end;
|
||||
|
||||
function TNNTPSend.SwitchToSlave: Boolean;
|
||||
begin
|
||||
Result := DoCommand('SLAVE');
|
||||
end;
|
||||
|
||||
function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'XOVER ' + xoStart;
|
||||
if xoEnd <> xoStart then
|
||||
s := s + '-' + xoEnd;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.StartTLS: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if FindCap('STARTTLS') <> '' then
|
||||
begin
|
||||
if DoCommand('STARTTLS') then
|
||||
begin
|
||||
Fsock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TNNTPSend.ListExtensions: Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('LIST EXTENSIONS');
|
||||
end;
|
||||
|
||||
function TNNTPSend.FindCap(const Value: string): string;
|
||||
var
|
||||
n: Integer;
|
||||
s: string;
|
||||
begin
|
||||
s := UpperCase(Value);
|
||||
Result := '';
|
||||
for n := 0 to FNNTPcap.Count - 1 do
|
||||
if Pos(s, UpperCase(FNNTPcap[n])) = 1 then
|
||||
begin
|
||||
Result := FNNTPcap[n];
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.005.002 |
|
||||
|==============================================================================|
|
||||
| Content: NNTP client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(NNTP client)
|
||||
NNTP (network news transfer protocol)
|
||||
|
||||
Used RFC: RFC-977, RFC-2980
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$WARN SUSPICIOUS_TYPECAST OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit nntpsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cNNTPProtocol = '119';
|
||||
|
||||
type
|
||||
|
||||
{:abstract(Implementation of Network News Transfer Protocol.
|
||||
|
||||
Note: Are you missing properties for setting Username and Password? Look to
|
||||
parent @link(TSynaClient) object!
|
||||
|
||||
Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TNNTPSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TTCPBlockSocket;
|
||||
FResultCode: Integer;
|
||||
FResultString: string;
|
||||
FData: TStringList;
|
||||
FDataToSend: TStringList;
|
||||
FAutoTLS: Boolean;
|
||||
FFullSSL: Boolean;
|
||||
FNNTPcap: TStringList;
|
||||
function ReadResult: Integer;
|
||||
function ReadData: boolean;
|
||||
function SendData: boolean;
|
||||
function Connect: Boolean;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Connects to NNTP server and begin session.}
|
||||
function Login: Boolean;
|
||||
|
||||
{:Logout from NNTP server and terminate session.}
|
||||
function Logout: Boolean;
|
||||
|
||||
{:By this you can call any NNTP command.}
|
||||
function DoCommand(const Command: string): boolean;
|
||||
|
||||
{:by this you can call any NNTP command. This variant is used for commands
|
||||
for download information from server.}
|
||||
function DoCommandRead(const Command: string): boolean;
|
||||
|
||||
{:by this you can call any NNTP command. This variant is used for commands
|
||||
for upload information to server.}
|
||||
function DoCommandWrite(const Command: string): boolean;
|
||||
|
||||
{:Download full message to @link(data) property. Value can be number of
|
||||
message or message-id (in brackets).}
|
||||
function GetArticle(const Value: string): Boolean;
|
||||
|
||||
{:Download only body of message to @link(data) property. Value can be number
|
||||
of message or message-id (in brackets).}
|
||||
function GetBody(const Value: string): Boolean;
|
||||
|
||||
{:Download only headers of message to @link(data) property. Value can be
|
||||
number of message or message-id (in brackets).}
|
||||
function GetHead(const Value: string): Boolean;
|
||||
|
||||
{:Get message status. Value can be number of message or message-id
|
||||
(in brackets).}
|
||||
function GetStat(const Value: string): Boolean;
|
||||
|
||||
{:Select given group.}
|
||||
function SelectGroup(const Value: string): Boolean;
|
||||
|
||||
{:Tell to server 'I have mesage with given message-ID.' If server need this
|
||||
message, message is uploaded to server.}
|
||||
function IHave(const MessID: string): Boolean;
|
||||
|
||||
{:Move message pointer to last item in group.}
|
||||
function GotoLast: Boolean;
|
||||
|
||||
{:Move message pointer to next item in group.}
|
||||
function GotoNext: Boolean;
|
||||
|
||||
{:Download to @link(data) property list of all groups on NNTP server.}
|
||||
function ListGroups: Boolean;
|
||||
|
||||
{:Download to @link(data) property list of all groups created after given time.}
|
||||
function ListNewGroups(Since: TDateTime): Boolean;
|
||||
|
||||
{:Download to @link(data) property list of message-ids in given group since
|
||||
given time.}
|
||||
function NewArticles(const Group: string; Since: TDateTime): Boolean;
|
||||
|
||||
{:Upload new article to server. (for new messages by you)}
|
||||
function PostArticle: Boolean;
|
||||
|
||||
{:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP
|
||||
server'.}
|
||||
function SwitchToSlave: Boolean;
|
||||
|
||||
{:Call NNTP XOVER command.}
|
||||
function Xover(xoStart, xoEnd: string): boolean;
|
||||
|
||||
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
|
||||
function StartTLS: Boolean;
|
||||
|
||||
{:Try to find given capability in extension list. This list is getted after
|
||||
successful login to NNTP server. If extension capability is not found,
|
||||
then return is empty string.}
|
||||
function FindCap(const Value: string): string;
|
||||
|
||||
{:Try get list of server extensions. List is returned in @link(data) property.}
|
||||
function ListExtensions: Boolean;
|
||||
published
|
||||
{:Result code number of last operation.}
|
||||
property ResultCode: Integer read FResultCode;
|
||||
|
||||
{:String description of last result code from NNTP server.}
|
||||
property ResultString: string read FResultString;
|
||||
|
||||
{:Readed data. (message, etc.)}
|
||||
property Data: TStringList read FData;
|
||||
|
||||
{:If is set to @true, then upgrade to SSL/TLS mode after login if remote
|
||||
server support it.}
|
||||
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
|
||||
|
||||
{:SSL/TLS mode is used from first contact to server. Servers with full
|
||||
SSL/TLS mode usualy using non-standard TCP port!}
|
||||
property FullSSL: Boolean read FFullSSL Write FFullSSL;
|
||||
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TNNTPSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FData := TStringList.Create;
|
||||
FDataToSend := TStringList.Create;
|
||||
FNNTPcap := TStringList.Create;
|
||||
FSock.ConvertLineEnd := True;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cNNTPProtocol;
|
||||
FAutoTLS := False;
|
||||
FFullSSL := False;
|
||||
end;
|
||||
|
||||
destructor TNNTPSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FDataToSend.Free;
|
||||
FData.Free;
|
||||
FNNTPcap.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TNNTPSend.ReadResult: Integer;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
Result := 0;
|
||||
FData.Clear;
|
||||
s := FSock.RecvString(FTimeout);
|
||||
FResultString := Copy(s, 5, Length(s) - 4);
|
||||
if FSock.LastError <> 0 then
|
||||
Exit;
|
||||
if Length(s) >= 3 then
|
||||
Result := StrToIntDef(Copy(s, 1, 3), 0);
|
||||
FResultCode := Result;
|
||||
end;
|
||||
|
||||
function TNNTPSend.ReadData: boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if s = '.' then
|
||||
break;
|
||||
if (s <> '') and (s[1] = '.') then
|
||||
s := Copy(s, 2, Length(s) - 1);
|
||||
FData.Add(s);
|
||||
until FSock.LastError <> 0;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TNNTPSend.SendData: boolean;
|
||||
var
|
||||
s: string;
|
||||
n: integer;
|
||||
begin
|
||||
for n := 0 to FDataToSend.Count - 1 do
|
||||
begin
|
||||
s := FDataToSend[n];
|
||||
if (s <> '') and (s[1] = '.') then
|
||||
s := s + '.';
|
||||
FSock.SendString(s + CRLF);
|
||||
if FSock.LastError <> 0 then
|
||||
break;
|
||||
end;
|
||||
if FDataToSend.Count = 0 then
|
||||
FSock.SendString(CRLF);
|
||||
if FSock.LastError = 0 then
|
||||
FSock.SendString('.' + CRLF);
|
||||
FDataToSend.Clear;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TNNTPSend.Connect: Boolean;
|
||||
begin
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
if FSock.LastError = 0 then
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
if FSock.LastError = 0 then
|
||||
if FFullSSL then
|
||||
FSock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TNNTPSend.Login: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
FNNTPcap.Clear;
|
||||
if not Connect then
|
||||
Exit;
|
||||
Result := (ReadResult div 100) = 2;
|
||||
ListExtensions;
|
||||
FNNTPcap.Assign(Fdata);
|
||||
if Result then
|
||||
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
|
||||
Result := StartTLS;
|
||||
if (FUsername <> '') and Result then
|
||||
begin
|
||||
FSock.SendString('AUTHINFO USER ' + FUsername + CRLF);
|
||||
if (ReadResult div 100) = 3 then
|
||||
begin
|
||||
FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF);
|
||||
Result := (ReadResult div 100) = 2;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TNNTPSend.Logout: Boolean;
|
||||
begin
|
||||
FSock.SendString('QUIT' + CRLF);
|
||||
Result := (ReadResult div 100) = 2;
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TNNTPSend.DoCommand(const Command: string): Boolean;
|
||||
begin
|
||||
FSock.SendString(Command + CRLF);
|
||||
Result := (ReadResult div 100) = 2;
|
||||
Result := Result and (FSock.LastError = 0);
|
||||
end;
|
||||
|
||||
function TNNTPSend.DoCommandRead(const Command: string): Boolean;
|
||||
begin
|
||||
Result := DoCommand(Command);
|
||||
if Result then
|
||||
begin
|
||||
Result := ReadData;
|
||||
Result := Result and (FSock.LastError = 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TNNTPSend.DoCommandWrite(const Command: string): Boolean;
|
||||
var
|
||||
x: integer;
|
||||
begin
|
||||
FDataToSend.Assign(FData);
|
||||
FSock.SendString(Command + CRLF);
|
||||
x := (ReadResult div 100);
|
||||
if x = 3 then
|
||||
begin
|
||||
SendData;
|
||||
x := (ReadResult div 100);
|
||||
end;
|
||||
Result := x = 2;
|
||||
Result := Result and (FSock.LastError = 0);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetArticle(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'ARTICLE';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetBody(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'BODY';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetHead(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'HEAD';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GetStat(const Value: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'STAT';
|
||||
if Value <> '' then
|
||||
s := s + ' ' + Value;
|
||||
Result := DoCommand(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.SelectGroup(const Value: string): Boolean;
|
||||
begin
|
||||
Result := DoCommand('GROUP ' + Value);
|
||||
end;
|
||||
|
||||
function TNNTPSend.IHave(const MessID: string): Boolean;
|
||||
begin
|
||||
Result := DoCommandWrite('IHAVE ' + MessID);
|
||||
end;
|
||||
|
||||
function TNNTPSend.GotoLast: Boolean;
|
||||
begin
|
||||
Result := DoCommand('LAST');
|
||||
end;
|
||||
|
||||
function TNNTPSend.GotoNext: Boolean;
|
||||
begin
|
||||
Result := DoCommand('NEXT');
|
||||
end;
|
||||
|
||||
function TNNTPSend.ListGroups: Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('LIST');
|
||||
end;
|
||||
|
||||
function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT');
|
||||
end;
|
||||
|
||||
function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT');
|
||||
end;
|
||||
|
||||
function TNNTPSend.PostArticle: Boolean;
|
||||
begin
|
||||
Result := DoCommandWrite('POST');
|
||||
end;
|
||||
|
||||
function TNNTPSend.SwitchToSlave: Boolean;
|
||||
begin
|
||||
Result := DoCommand('SLAVE');
|
||||
end;
|
||||
|
||||
function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := 'XOVER ' + xoStart;
|
||||
if xoEnd <> xoStart then
|
||||
s := s + '-' + xoEnd;
|
||||
Result := DoCommandRead(s);
|
||||
end;
|
||||
|
||||
function TNNTPSend.StartTLS: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if FindCap('STARTTLS') <> '' then
|
||||
begin
|
||||
if DoCommand('STARTTLS') then
|
||||
begin
|
||||
Fsock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TNNTPSend.ListExtensions: Boolean;
|
||||
begin
|
||||
Result := DoCommandRead('LIST EXTENSIONS');
|
||||
end;
|
||||
|
||||
function TNNTPSend.FindCap(const Value: string): string;
|
||||
var
|
||||
n: Integer;
|
||||
s: string;
|
||||
begin
|
||||
s := UpperCase(Value);
|
||||
Result := '';
|
||||
for n := 0 to FNNTPcap.Count - 1 do
|
||||
if Pos(s, UpperCase(FNNTPcap[n])) = 1 then
|
||||
begin
|
||||
Result := FNNTPcap[n];
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
end.
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -1,483 +1,483 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 002.006.002 |
|
||||
|==============================================================================|
|
||||
| Content: POP3 client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(POP3 protocol client)
|
||||
|
||||
Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
{$M+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit pop3send;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil, synacode;
|
||||
|
||||
const
|
||||
cPop3Protocol = '110';
|
||||
|
||||
type
|
||||
|
||||
{:The three types of possible authorization methods for "logging in" to a POP3
|
||||
server.}
|
||||
TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
|
||||
|
||||
{:@abstract(Implementation of POP3 client protocol.)
|
||||
|
||||
Note: Are you missing properties for setting Username and Password? Look to
|
||||
parent @link(TSynaClient) object!
|
||||
|
||||
Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TPOP3Send = class(TSynaClient)
|
||||
private
|
||||
FSock: TTCPBlockSocket;
|
||||
FResultCode: Integer;
|
||||
FResultString: string;
|
||||
FFullResult: TStringList;
|
||||
FStatCount: Integer;
|
||||
FStatSize: Integer;
|
||||
FListSize: Integer;
|
||||
FTimeStamp: string;
|
||||
FAuthType: TPOP3AuthType;
|
||||
FPOP3cap: TStringList;
|
||||
FAutoTLS: Boolean;
|
||||
FFullSSL: Boolean;
|
||||
function ReadResult(Full: Boolean): Integer;
|
||||
function Connect: Boolean;
|
||||
function AuthLogin: Boolean;
|
||||
function AuthApop: Boolean;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:You can call any custom by this method. Call Command without trailing CRLF.
|
||||
If MultiLine parameter is @true, multilined response are expected.
|
||||
Result is @true on sucess.}
|
||||
function CustomCommand(const Command: string; MultiLine: Boolean): boolean;
|
||||
|
||||
{:Call CAPA command for get POP3 server capabilites.
|
||||
note: not all servers support this command!}
|
||||
function Capability: Boolean;
|
||||
|
||||
{:Connect to remote POP3 host. If all OK, result is @true.}
|
||||
function Login: Boolean;
|
||||
|
||||
{:Disconnects from POP3 server.}
|
||||
function Logout: Boolean;
|
||||
|
||||
{:Send RSET command. If all OK, result is @true.}
|
||||
function Reset: Boolean;
|
||||
|
||||
{:Send NOOP command. If all OK, result is @true.}
|
||||
function NoOp: Boolean;
|
||||
|
||||
{:Send STAT command and fill @link(StatCount) and @link(StatSize) property.
|
||||
If all OK, result is @true.}
|
||||
function Stat: Boolean;
|
||||
|
||||
{:Send LIST command. If Value is 0, LIST is for all messages. After
|
||||
successful operation is listing in FullResult. If all OK, result is @True.}
|
||||
function List(Value: Integer): Boolean;
|
||||
|
||||
{:Send RETR command. After successful operation dowloaded message in
|
||||
@link(FullResult). If all OK, result is @true.}
|
||||
function Retr(Value: Integer): Boolean;
|
||||
|
||||
{:Send RETR command. After successful operation dowloaded message in
|
||||
@link(Stream). If all OK, result is @true.}
|
||||
function RetrStream(Value: Integer; Stream: TStream): Boolean;
|
||||
|
||||
{:Send DELE command for delete specified message. If all OK, result is @true.}
|
||||
function Dele(Value: Integer): Boolean;
|
||||
|
||||
{:Send TOP command. After successful operation dowloaded headers of message
|
||||
and maxlines count of message in @link(FullResult). If all OK, result is
|
||||
@true.}
|
||||
function Top(Value, Maxlines: Integer): Boolean;
|
||||
|
||||
{:Send UIDL command. If Value is 0, UIDL is for all messages. After
|
||||
successful operation is listing in FullResult. If all OK, result is @True.}
|
||||
function Uidl(Value: Integer): Boolean;
|
||||
|
||||
{:Call STLS command for upgrade connection to SSL/TLS mode.}
|
||||
function StartTLS: Boolean;
|
||||
|
||||
{:Try to find given capabily in capabilty string returned from POP3 server
|
||||
by CAPA command.}
|
||||
function FindCap(const Value: string): string;
|
||||
published
|
||||
{:Result code of last POP3 operation. 0 - error, 1 - OK.}
|
||||
property ResultCode: Integer read FResultCode;
|
||||
|
||||
{:Result string of last POP3 operation.}
|
||||
property ResultString: string read FResultString;
|
||||
|
||||
{:Stringlist with full lines returned as result of POP3 operation. I.e. if
|
||||
operation is LIST, this property is filled by list of messages. If
|
||||
operation is RETR, this property have downloaded message.}
|
||||
property FullResult: TStringList read FFullResult;
|
||||
|
||||
{:After STAT command is there count of messages in inbox.}
|
||||
property StatCount: Integer read FStatCount;
|
||||
|
||||
{:After STAT command is there size of all messages in inbox.}
|
||||
property StatSize: Integer read FStatSize;
|
||||
|
||||
{:After LIST 0 command size of all messages on server, After LIST x size of message x on server}
|
||||
property ListSize: Integer read FListSize;
|
||||
|
||||
{:If server support this, after comnnect is in this property timestamp of
|
||||
remote server.}
|
||||
property TimeStamp: string read FTimeStamp;
|
||||
|
||||
{:Type of authorisation for login to POP3 server. Dafault is autodetect one
|
||||
of possible authorisation. Autodetect do this:
|
||||
|
||||
If remote POP3 server support APOP, try login by APOP method. If APOP is
|
||||
not supported, or if APOP login failed, try classic USER+PASS login method.}
|
||||
property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
|
||||
|
||||
{:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.}
|
||||
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
|
||||
|
||||
{:SSL/TLS mode is used from first contact to server. Servers with full
|
||||
SSL/TLS mode usualy using non-standard TCP port!}
|
||||
property FullSSL: Boolean read FFullSSL Write FFullSSL;
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TPOP3Send.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FFullResult := TStringList.Create;
|
||||
FPOP3cap := TStringList.Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FSock.ConvertLineEnd := true;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cPop3Protocol;
|
||||
FStatCount := 0;
|
||||
FStatSize := 0;
|
||||
FListSize := 0;
|
||||
FAuthType := POP3AuthAll;
|
||||
FAutoTLS := False;
|
||||
FFullSSL := False;
|
||||
end;
|
||||
|
||||
destructor TPOP3Send.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FPOP3cap.Free;
|
||||
FullResult.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TPOP3Send.ReadResult(Full: Boolean): Integer;
|
||||
var
|
||||
s: AnsiString;
|
||||
begin
|
||||
Result := 0;
|
||||
FFullResult.Clear;
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if Pos('+OK', s) = 1 then
|
||||
Result := 1;
|
||||
FResultString := s;
|
||||
if Full and (Result = 1) then
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if s = '.' then
|
||||
Break;
|
||||
if s <> '' then
|
||||
if s[1] = '.' then
|
||||
Delete(s, 1, 1);
|
||||
FFullResult.Add(s);
|
||||
until FSock.LastError <> 0;
|
||||
if not Full and (Result = 1) then
|
||||
FFullResult.Add(SeparateRight(FResultString, ' '));
|
||||
if FSock.LastError <> 0 then
|
||||
Result := 0;
|
||||
FResultCode := Result;
|
||||
end;
|
||||
|
||||
function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean;
|
||||
begin
|
||||
FSock.SendString(Command + CRLF);
|
||||
Result := ReadResult(MultiLine) <> 0;
|
||||
end;
|
||||
|
||||
function TPOP3Send.AuthLogin: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if not CustomCommand('USER ' + FUserName, False) then
|
||||
exit;
|
||||
Result := CustomCommand('PASS ' + FPassword, False)
|
||||
end;
|
||||
|
||||
function TPOP3Send.AuthAPOP: Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := StrToHex(MD5(FTimeStamp + FPassWord));
|
||||
Result := CustomCommand('APOP ' + FUserName + ' ' + s, False);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Connect: Boolean;
|
||||
begin
|
||||
// Do not call this function! It is calling by LOGIN method!
|
||||
FStatCount := 0;
|
||||
FStatSize := 0;
|
||||
FSock.CloseSocket;
|
||||
FSock.LineBuffer := '';
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
if FSock.LastError = 0 then
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
if FSock.LastError = 0 then
|
||||
if FFullSSL then
|
||||
FSock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TPOP3Send.Capability: Boolean;
|
||||
begin
|
||||
FPOP3cap.Clear;
|
||||
Result := CustomCommand('CAPA', True);
|
||||
if Result then
|
||||
FPOP3cap.AddStrings(FFullResult);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Login: Boolean;
|
||||
var
|
||||
s, s1: string;
|
||||
begin
|
||||
Result := False;
|
||||
FTimeStamp := '';
|
||||
if not Connect then
|
||||
Exit;
|
||||
if ReadResult(False) <> 1 then
|
||||
Exit;
|
||||
s := SeparateRight(FResultString, '<');
|
||||
if s <> FResultString then
|
||||
begin
|
||||
s1 := Trim(SeparateLeft(s, '>'));
|
||||
if s1 <> s then
|
||||
FTimeStamp := '<' + s1 + '>';
|
||||
end;
|
||||
Result := False;
|
||||
if Capability then
|
||||
if FAutoTLS and (Findcap('STLS') <> '') then
|
||||
if StartTLS then
|
||||
Capability
|
||||
else
|
||||
begin
|
||||
Result := False;
|
||||
Exit;
|
||||
end;
|
||||
if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
|
||||
begin
|
||||
Result := AuthApop;
|
||||
if not Result then
|
||||
begin
|
||||
if not Connect then
|
||||
Exit;
|
||||
if ReadResult(False) <> 1 then
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
if not Result and not (FAuthType = POP3AuthAPOP) then
|
||||
Result := AuthLogin;
|
||||
end;
|
||||
|
||||
function TPOP3Send.Logout: Boolean;
|
||||
begin
|
||||
Result := CustomCommand('QUIT', False);
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TPOP3Send.Reset: Boolean;
|
||||
begin
|
||||
Result := CustomCommand('RSET', False);
|
||||
end;
|
||||
|
||||
function TPOP3Send.NoOp: Boolean;
|
||||
begin
|
||||
Result := CustomCommand('NOOP', False);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Stat: Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
Result := CustomCommand('STAT', False);
|
||||
if Result then
|
||||
begin
|
||||
s := SeparateRight(ResultString, '+OK ');
|
||||
FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
|
||||
FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPOP3Send.List(Value: Integer): Boolean;
|
||||
var
|
||||
s: string;
|
||||
n: integer;
|
||||
begin
|
||||
if Value = 0 then
|
||||
s := 'LIST'
|
||||
else
|
||||
s := 'LIST ' + IntToStr(Value);
|
||||
Result := CustomCommand(s, Value = 0);
|
||||
FListSize := 0;
|
||||
if Result then
|
||||
if Value <> 0 then
|
||||
begin
|
||||
s := SeparateRight(ResultString, '+OK ');
|
||||
FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
|
||||
end
|
||||
else
|
||||
for n := 0 to FFullResult.Count - 1 do
|
||||
FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Retr(Value: Integer): Boolean;
|
||||
begin
|
||||
Result := CustomCommand('RETR ' + IntToStr(Value), True);
|
||||
end;
|
||||
|
||||
//based on code by Miha Vrhovnik
|
||||
function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
Result := False;
|
||||
FFullResult.Clear;
|
||||
Stream.Size := 0;
|
||||
FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
|
||||
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if Pos('+OK', s) = 1 then
|
||||
Result := True;
|
||||
FResultString := s;
|
||||
if Result then begin
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if s = '.' then
|
||||
Break;
|
||||
if s <> '' then begin
|
||||
if s[1] = '.' then
|
||||
Delete(s, 1, 1);
|
||||
end;
|
||||
WriteStrToStream(Stream, s);
|
||||
WriteStrToStream(Stream, CRLF);
|
||||
until FSock.LastError <> 0;
|
||||
end;
|
||||
|
||||
if Result then
|
||||
FResultCode := 1
|
||||
else
|
||||
FResultCode := 0;
|
||||
end;
|
||||
|
||||
function TPOP3Send.Dele(Value: Integer): Boolean;
|
||||
begin
|
||||
Result := CustomCommand('DELE ' + IntToStr(Value), False);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
|
||||
begin
|
||||
Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Uidl(Value: Integer): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
if Value = 0 then
|
||||
s := 'UIDL'
|
||||
else
|
||||
s := 'UIDL ' + IntToStr(Value);
|
||||
Result := CustomCommand(s, Value = 0);
|
||||
end;
|
||||
|
||||
function TPOP3Send.StartTLS: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if CustomCommand('STLS', False) then
|
||||
begin
|
||||
Fsock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPOP3Send.FindCap(const Value: string): string;
|
||||
var
|
||||
n: Integer;
|
||||
s: string;
|
||||
begin
|
||||
s := UpperCase(Value);
|
||||
Result := '';
|
||||
for n := 0 to FPOP3cap.Count - 1 do
|
||||
if Pos(s, UpperCase(FPOP3cap[n])) = 1 then
|
||||
begin
|
||||
Result := FPOP3cap[n];
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 002.006.002 |
|
||||
|==============================================================================|
|
||||
| Content: POP3 client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(POP3 protocol client)
|
||||
|
||||
Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
{$M+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit pop3send;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil, synacode;
|
||||
|
||||
const
|
||||
cPop3Protocol = '110';
|
||||
|
||||
type
|
||||
|
||||
{:The three types of possible authorization methods for "logging in" to a POP3
|
||||
server.}
|
||||
TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
|
||||
|
||||
{:@abstract(Implementation of POP3 client protocol.)
|
||||
|
||||
Note: Are you missing properties for setting Username and Password? Look to
|
||||
parent @link(TSynaClient) object!
|
||||
|
||||
Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TPOP3Send = class(TSynaClient)
|
||||
private
|
||||
FSock: TTCPBlockSocket;
|
||||
FResultCode: Integer;
|
||||
FResultString: string;
|
||||
FFullResult: TStringList;
|
||||
FStatCount: Integer;
|
||||
FStatSize: Integer;
|
||||
FListSize: Integer;
|
||||
FTimeStamp: string;
|
||||
FAuthType: TPOP3AuthType;
|
||||
FPOP3cap: TStringList;
|
||||
FAutoTLS: Boolean;
|
||||
FFullSSL: Boolean;
|
||||
function ReadResult(Full: Boolean): Integer;
|
||||
function Connect: Boolean;
|
||||
function AuthLogin: Boolean;
|
||||
function AuthApop: Boolean;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:You can call any custom by this method. Call Command without trailing CRLF.
|
||||
If MultiLine parameter is @true, multilined response are expected.
|
||||
Result is @true on sucess.}
|
||||
function CustomCommand(const Command: string; MultiLine: Boolean): boolean;
|
||||
|
||||
{:Call CAPA command for get POP3 server capabilites.
|
||||
note: not all servers support this command!}
|
||||
function Capability: Boolean;
|
||||
|
||||
{:Connect to remote POP3 host. If all OK, result is @true.}
|
||||
function Login: Boolean;
|
||||
|
||||
{:Disconnects from POP3 server.}
|
||||
function Logout: Boolean;
|
||||
|
||||
{:Send RSET command. If all OK, result is @true.}
|
||||
function Reset: Boolean;
|
||||
|
||||
{:Send NOOP command. If all OK, result is @true.}
|
||||
function NoOp: Boolean;
|
||||
|
||||
{:Send STAT command and fill @link(StatCount) and @link(StatSize) property.
|
||||
If all OK, result is @true.}
|
||||
function Stat: Boolean;
|
||||
|
||||
{:Send LIST command. If Value is 0, LIST is for all messages. After
|
||||
successful operation is listing in FullResult. If all OK, result is @True.}
|
||||
function List(Value: Integer): Boolean;
|
||||
|
||||
{:Send RETR command. After successful operation dowloaded message in
|
||||
@link(FullResult). If all OK, result is @true.}
|
||||
function Retr(Value: Integer): Boolean;
|
||||
|
||||
{:Send RETR command. After successful operation dowloaded message in
|
||||
@link(Stream). If all OK, result is @true.}
|
||||
function RetrStream(Value: Integer; Stream: TStream): Boolean;
|
||||
|
||||
{:Send DELE command for delete specified message. If all OK, result is @true.}
|
||||
function Dele(Value: Integer): Boolean;
|
||||
|
||||
{:Send TOP command. After successful operation dowloaded headers of message
|
||||
and maxlines count of message in @link(FullResult). If all OK, result is
|
||||
@true.}
|
||||
function Top(Value, Maxlines: Integer): Boolean;
|
||||
|
||||
{:Send UIDL command. If Value is 0, UIDL is for all messages. After
|
||||
successful operation is listing in FullResult. If all OK, result is @True.}
|
||||
function Uidl(Value: Integer): Boolean;
|
||||
|
||||
{:Call STLS command for upgrade connection to SSL/TLS mode.}
|
||||
function StartTLS: Boolean;
|
||||
|
||||
{:Try to find given capabily in capabilty string returned from POP3 server
|
||||
by CAPA command.}
|
||||
function FindCap(const Value: string): string;
|
||||
published
|
||||
{:Result code of last POP3 operation. 0 - error, 1 - OK.}
|
||||
property ResultCode: Integer read FResultCode;
|
||||
|
||||
{:Result string of last POP3 operation.}
|
||||
property ResultString: string read FResultString;
|
||||
|
||||
{:Stringlist with full lines returned as result of POP3 operation. I.e. if
|
||||
operation is LIST, this property is filled by list of messages. If
|
||||
operation is RETR, this property have downloaded message.}
|
||||
property FullResult: TStringList read FFullResult;
|
||||
|
||||
{:After STAT command is there count of messages in inbox.}
|
||||
property StatCount: Integer read FStatCount;
|
||||
|
||||
{:After STAT command is there size of all messages in inbox.}
|
||||
property StatSize: Integer read FStatSize;
|
||||
|
||||
{:After LIST 0 command size of all messages on server, After LIST x size of message x on server}
|
||||
property ListSize: Integer read FListSize;
|
||||
|
||||
{:If server support this, after comnnect is in this property timestamp of
|
||||
remote server.}
|
||||
property TimeStamp: string read FTimeStamp;
|
||||
|
||||
{:Type of authorisation for login to POP3 server. Dafault is autodetect one
|
||||
of possible authorisation. Autodetect do this:
|
||||
|
||||
If remote POP3 server support APOP, try login by APOP method. If APOP is
|
||||
not supported, or if APOP login failed, try classic USER+PASS login method.}
|
||||
property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
|
||||
|
||||
{:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.}
|
||||
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
|
||||
|
||||
{:SSL/TLS mode is used from first contact to server. Servers with full
|
||||
SSL/TLS mode usualy using non-standard TCP port!}
|
||||
property FullSSL: Boolean read FFullSSL Write FFullSSL;
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TPOP3Send.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FFullResult := TStringList.Create;
|
||||
FPOP3cap := TStringList.Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FSock.ConvertLineEnd := true;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cPop3Protocol;
|
||||
FStatCount := 0;
|
||||
FStatSize := 0;
|
||||
FListSize := 0;
|
||||
FAuthType := POP3AuthAll;
|
||||
FAutoTLS := False;
|
||||
FFullSSL := False;
|
||||
end;
|
||||
|
||||
destructor TPOP3Send.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FPOP3cap.Free;
|
||||
FullResult.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TPOP3Send.ReadResult(Full: Boolean): Integer;
|
||||
var
|
||||
s: AnsiString;
|
||||
begin
|
||||
Result := 0;
|
||||
FFullResult.Clear;
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if Pos('+OK', s) = 1 then
|
||||
Result := 1;
|
||||
FResultString := s;
|
||||
if Full and (Result = 1) then
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if s = '.' then
|
||||
Break;
|
||||
if s <> '' then
|
||||
if s[1] = '.' then
|
||||
Delete(s, 1, 1);
|
||||
FFullResult.Add(s);
|
||||
until FSock.LastError <> 0;
|
||||
if not Full and (Result = 1) then
|
||||
FFullResult.Add(SeparateRight(FResultString, ' '));
|
||||
if FSock.LastError <> 0 then
|
||||
Result := 0;
|
||||
FResultCode := Result;
|
||||
end;
|
||||
|
||||
function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean;
|
||||
begin
|
||||
FSock.SendString(Command + CRLF);
|
||||
Result := ReadResult(MultiLine) <> 0;
|
||||
end;
|
||||
|
||||
function TPOP3Send.AuthLogin: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if not CustomCommand('USER ' + FUserName, False) then
|
||||
exit;
|
||||
Result := CustomCommand('PASS ' + FPassword, False)
|
||||
end;
|
||||
|
||||
function TPOP3Send.AuthAPOP: Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
s := StrToHex(MD5(FTimeStamp + FPassWord));
|
||||
Result := CustomCommand('APOP ' + FUserName + ' ' + s, False);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Connect: Boolean;
|
||||
begin
|
||||
// Do not call this function! It is calling by LOGIN method!
|
||||
FStatCount := 0;
|
||||
FStatSize := 0;
|
||||
FSock.CloseSocket;
|
||||
FSock.LineBuffer := '';
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
if FSock.LastError = 0 then
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
if FSock.LastError = 0 then
|
||||
if FFullSSL then
|
||||
FSock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TPOP3Send.Capability: Boolean;
|
||||
begin
|
||||
FPOP3cap.Clear;
|
||||
Result := CustomCommand('CAPA', True);
|
||||
if Result then
|
||||
FPOP3cap.AddStrings(FFullResult);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Login: Boolean;
|
||||
var
|
||||
s, s1: string;
|
||||
begin
|
||||
Result := False;
|
||||
FTimeStamp := '';
|
||||
if not Connect then
|
||||
Exit;
|
||||
if ReadResult(False) <> 1 then
|
||||
Exit;
|
||||
s := SeparateRight(FResultString, '<');
|
||||
if s <> FResultString then
|
||||
begin
|
||||
s1 := Trim(SeparateLeft(s, '>'));
|
||||
if s1 <> s then
|
||||
FTimeStamp := '<' + s1 + '>';
|
||||
end;
|
||||
Result := False;
|
||||
if Capability then
|
||||
if FAutoTLS and (Findcap('STLS') <> '') then
|
||||
if StartTLS then
|
||||
Capability
|
||||
else
|
||||
begin
|
||||
Result := False;
|
||||
Exit;
|
||||
end;
|
||||
if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
|
||||
begin
|
||||
Result := AuthApop;
|
||||
if not Result then
|
||||
begin
|
||||
if not Connect then
|
||||
Exit;
|
||||
if ReadResult(False) <> 1 then
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
if not Result and not (FAuthType = POP3AuthAPOP) then
|
||||
Result := AuthLogin;
|
||||
end;
|
||||
|
||||
function TPOP3Send.Logout: Boolean;
|
||||
begin
|
||||
Result := CustomCommand('QUIT', False);
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
function TPOP3Send.Reset: Boolean;
|
||||
begin
|
||||
Result := CustomCommand('RSET', False);
|
||||
end;
|
||||
|
||||
function TPOP3Send.NoOp: Boolean;
|
||||
begin
|
||||
Result := CustomCommand('NOOP', False);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Stat: Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
Result := CustomCommand('STAT', False);
|
||||
if Result then
|
||||
begin
|
||||
s := SeparateRight(ResultString, '+OK ');
|
||||
FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
|
||||
FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPOP3Send.List(Value: Integer): Boolean;
|
||||
var
|
||||
s: string;
|
||||
n: integer;
|
||||
begin
|
||||
if Value = 0 then
|
||||
s := 'LIST'
|
||||
else
|
||||
s := 'LIST ' + IntToStr(Value);
|
||||
Result := CustomCommand(s, Value = 0);
|
||||
FListSize := 0;
|
||||
if Result then
|
||||
if Value <> 0 then
|
||||
begin
|
||||
s := SeparateRight(ResultString, '+OK ');
|
||||
FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
|
||||
end
|
||||
else
|
||||
for n := 0 to FFullResult.Count - 1 do
|
||||
FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Retr(Value: Integer): Boolean;
|
||||
begin
|
||||
Result := CustomCommand('RETR ' + IntToStr(Value), True);
|
||||
end;
|
||||
|
||||
//based on code by Miha Vrhovnik
|
||||
function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
Result := False;
|
||||
FFullResult.Clear;
|
||||
Stream.Size := 0;
|
||||
FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
|
||||
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if Pos('+OK', s) = 1 then
|
||||
Result := True;
|
||||
FResultString := s;
|
||||
if Result then begin
|
||||
repeat
|
||||
s := FSock.RecvString(FTimeout);
|
||||
if s = '.' then
|
||||
Break;
|
||||
if s <> '' then begin
|
||||
if s[1] = '.' then
|
||||
Delete(s, 1, 1);
|
||||
end;
|
||||
WriteStrToStream(Stream, s);
|
||||
WriteStrToStream(Stream, CRLF);
|
||||
until FSock.LastError <> 0;
|
||||
end;
|
||||
|
||||
if Result then
|
||||
FResultCode := 1
|
||||
else
|
||||
FResultCode := 0;
|
||||
end;
|
||||
|
||||
function TPOP3Send.Dele(Value: Integer): Boolean;
|
||||
begin
|
||||
Result := CustomCommand('DELE ' + IntToStr(Value), False);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
|
||||
begin
|
||||
Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True);
|
||||
end;
|
||||
|
||||
function TPOP3Send.Uidl(Value: Integer): Boolean;
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
if Value = 0 then
|
||||
s := 'UIDL'
|
||||
else
|
||||
s := 'UIDL ' + IntToStr(Value);
|
||||
Result := CustomCommand(s, Value = 0);
|
||||
end;
|
||||
|
||||
function TPOP3Send.StartTLS: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if CustomCommand('STLS', False) then
|
||||
begin
|
||||
Fsock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPOP3Send.FindCap(const Value: string): string;
|
||||
var
|
||||
n: Integer;
|
||||
s: string;
|
||||
begin
|
||||
s := UpperCase(Value);
|
||||
Result := '';
|
||||
for n := 0 to FPOP3cap.Count - 1 do
|
||||
if Pos(s, UpperCase(FPOP3cap[n])) = 1 then
|
||||
begin
|
||||
Result := FPOP3cap[n];
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
|
@ -1,320 +1,320 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.002.003 |
|
||||
|==============================================================================|
|
||||
| Content: SysLog client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
| Christian Brosius |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(BSD SYSLOG protocol)
|
||||
|
||||
Used RFC: RFC-3164
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
unit slogsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cSysLogProtocol = '514';
|
||||
|
||||
FCL_Kernel = 0;
|
||||
FCL_UserLevel = 1;
|
||||
FCL_MailSystem = 2;
|
||||
FCL_System = 3;
|
||||
FCL_Security = 4;
|
||||
FCL_Syslogd = 5;
|
||||
FCL_Printer = 6;
|
||||
FCL_News = 7;
|
||||
FCL_UUCP = 8;
|
||||
FCL_Clock = 9;
|
||||
FCL_Authorization = 10;
|
||||
FCL_FTP = 11;
|
||||
FCL_NTP = 12;
|
||||
FCL_LogAudit = 13;
|
||||
FCL_LogAlert = 14;
|
||||
FCL_Time = 15;
|
||||
FCL_Local0 = 16;
|
||||
FCL_Local1 = 17;
|
||||
FCL_Local2 = 18;
|
||||
FCL_Local3 = 19;
|
||||
FCL_Local4 = 20;
|
||||
FCL_Local5 = 21;
|
||||
FCL_Local6 = 22;
|
||||
FCL_Local7 = 23;
|
||||
|
||||
type
|
||||
{:@abstract(Define possible priority of Syslog message)}
|
||||
TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
|
||||
Debug);
|
||||
|
||||
{:@abstract(encoding or decoding of SYSLOG message)}
|
||||
TSyslogMessage = class(TObject)
|
||||
private
|
||||
FFacility:Byte;
|
||||
FSeverity:TSyslogSeverity;
|
||||
FDateTime:TDateTime;
|
||||
FTag:String;
|
||||
FMessage:String;
|
||||
FLocalIP:String;
|
||||
function GetPacketBuf:String;
|
||||
procedure SetPacketBuf(Value:String);
|
||||
public
|
||||
{:Reset values to defaults}
|
||||
procedure Clear;
|
||||
published
|
||||
{:Define facilicity of Syslog message. For specify you may use predefined
|
||||
FCL_* constants. Default is "FCL_Local0".}
|
||||
property Facility:Byte read FFacility write FFacility;
|
||||
|
||||
{:Define possible priority of Syslog message. Default is "Debug".}
|
||||
property Severity:TSyslogSeverity read FSeverity write FSeverity;
|
||||
|
||||
{:date and time of Syslog message}
|
||||
property DateTime:TDateTime read FDateTime write FDateTime;
|
||||
|
||||
{:This is used for identify process of this message. Default is filename
|
||||
of your executable file.}
|
||||
property Tag:String read FTag write FTag;
|
||||
|
||||
{:Text of your message for log.}
|
||||
property LogMessage:String read FMessage write FMessage;
|
||||
|
||||
{:IP address of message sender.}
|
||||
property LocalIP:String read FLocalIP write FLocalIP;
|
||||
|
||||
{:This property holds encoded binary SYSLOG packet}
|
||||
property PacketBuf:String read GetPacketBuf write SetPacketBuf;
|
||||
end;
|
||||
|
||||
{:@abstract(This object implement BSD SysLog client)
|
||||
|
||||
Note: Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TSyslogSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TUDPBlockSocket;
|
||||
FSysLogMessage: TSysLogMessage;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
{:Send Syslog UDP packet defined by @link(SysLogMessage).}
|
||||
function DoIt: Boolean;
|
||||
published
|
||||
{:Syslog message for send}
|
||||
property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage;
|
||||
end;
|
||||
|
||||
{:Simply send packet to specified Syslog server.}
|
||||
function ToSysLog(const SyslogServer: string; Facil: Byte;
|
||||
Sever: TSyslogSeverity; const Content: string): Boolean;
|
||||
|
||||
implementation
|
||||
|
||||
function TSyslogMessage.GetPacketBuf:String;
|
||||
begin
|
||||
Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>';
|
||||
Result := Result + CDateTime(FDateTime) + ' ';
|
||||
Result := Result + FLocalIP + ' ';
|
||||
Result := Result + FTag + ': ' + FMessage;
|
||||
end;
|
||||
|
||||
procedure TSyslogMessage.SetPacketBuf(Value:String);
|
||||
var StrBuf:String;
|
||||
IntBuf,Pos:Integer;
|
||||
begin
|
||||
if Length(Value) < 1 then exit;
|
||||
Pos := 1;
|
||||
if Value[Pos] <> '<' then exit;
|
||||
Inc(Pos);
|
||||
// Facility and Severity
|
||||
StrBuf := '';
|
||||
while (Value[Pos] <> '>')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
IntBuf := StrToInt(StrBuf);
|
||||
FFacility := IntBuf div 8;
|
||||
case (IntBuf mod 8)of
|
||||
0:FSeverity := Emergency;
|
||||
1:FSeverity := Alert;
|
||||
2:FSeverity := Critical;
|
||||
3:FSeverity := Error;
|
||||
4:FSeverity := Warning;
|
||||
5:FSeverity := Notice;
|
||||
6:FSeverity := Info;
|
||||
7:FSeverity := Debug;
|
||||
end;
|
||||
// DateTime
|
||||
Inc(Pos);
|
||||
StrBuf := '';
|
||||
// Month
|
||||
while (Value[Pos] <> ' ')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
// Day
|
||||
while (Value[Pos] <> ' ')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
// Time
|
||||
while (Value[Pos] <> ' ')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
FDateTime := DecodeRFCDateTime(StrBuf);
|
||||
Inc(Pos);
|
||||
|
||||
// LocalIP
|
||||
StrBuf := '';
|
||||
while (Value[Pos] <> ' ')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
FLocalIP := StrBuf;
|
||||
Inc(Pos);
|
||||
// Tag
|
||||
StrBuf := '';
|
||||
while (Value[Pos] <> ':')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
FTag := StrBuf;
|
||||
// LogMessage
|
||||
Inc(Pos);
|
||||
StrBuf := '';
|
||||
while (Pos <= Length(Value))do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
FMessage := TrimSP(StrBuf);
|
||||
end;
|
||||
|
||||
procedure TSysLogMessage.Clear;
|
||||
begin
|
||||
FFacility := FCL_Local0;
|
||||
FSeverity := Debug;
|
||||
FTag := ExtractFileName(ParamStr(0));
|
||||
FMessage := '';
|
||||
FLocalIP := '0.0.0.0';
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
|
||||
constructor TSyslogSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TUDPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FSysLogMessage := TSysLogMessage.Create;
|
||||
FTargetPort := cSysLogProtocol;
|
||||
end;
|
||||
|
||||
destructor TSyslogSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FSysLogMessage.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TSyslogSend.DoIt: Boolean;
|
||||
var
|
||||
L: TStringList;
|
||||
begin
|
||||
Result := False;
|
||||
L := TStringList.Create;
|
||||
try
|
||||
FSock.ResolveNameToIP(FSock.Localname, L);
|
||||
if L.Count < 1 then
|
||||
FSysLogMessage.LocalIP := '0.0.0.0'
|
||||
else
|
||||
FSysLogMessage.LocalIP := L[0];
|
||||
finally
|
||||
L.Free;
|
||||
end;
|
||||
FSysLogMessage.DateTime := Now;
|
||||
if Length(FSysLogMessage.PacketBuf) <= 1024 then
|
||||
begin
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
FSock.SendString(FSysLogMessage.PacketBuf);
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function ToSysLog(const SyslogServer: string; Facil: Byte;
|
||||
Sever: TSyslogSeverity; const Content: string): Boolean;
|
||||
begin
|
||||
with TSyslogSend.Create do
|
||||
try
|
||||
TargetHost :=SyslogServer;
|
||||
SysLogMessage.Facility := Facil;
|
||||
SysLogMessage.Severity := Sever;
|
||||
SysLogMessage.LogMessage := Content;
|
||||
Result := DoIt;
|
||||
finally
|
||||
Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.002.003 |
|
||||
|==============================================================================|
|
||||
| Content: SysLog client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
| Christian Brosius |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(BSD SYSLOG protocol)
|
||||
|
||||
Used RFC: RFC-3164
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
unit slogsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cSysLogProtocol = '514';
|
||||
|
||||
FCL_Kernel = 0;
|
||||
FCL_UserLevel = 1;
|
||||
FCL_MailSystem = 2;
|
||||
FCL_System = 3;
|
||||
FCL_Security = 4;
|
||||
FCL_Syslogd = 5;
|
||||
FCL_Printer = 6;
|
||||
FCL_News = 7;
|
||||
FCL_UUCP = 8;
|
||||
FCL_Clock = 9;
|
||||
FCL_Authorization = 10;
|
||||
FCL_FTP = 11;
|
||||
FCL_NTP = 12;
|
||||
FCL_LogAudit = 13;
|
||||
FCL_LogAlert = 14;
|
||||
FCL_Time = 15;
|
||||
FCL_Local0 = 16;
|
||||
FCL_Local1 = 17;
|
||||
FCL_Local2 = 18;
|
||||
FCL_Local3 = 19;
|
||||
FCL_Local4 = 20;
|
||||
FCL_Local5 = 21;
|
||||
FCL_Local6 = 22;
|
||||
FCL_Local7 = 23;
|
||||
|
||||
type
|
||||
{:@abstract(Define possible priority of Syslog message)}
|
||||
TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
|
||||
Debug);
|
||||
|
||||
{:@abstract(encoding or decoding of SYSLOG message)}
|
||||
TSyslogMessage = class(TObject)
|
||||
private
|
||||
FFacility:Byte;
|
||||
FSeverity:TSyslogSeverity;
|
||||
FDateTime:TDateTime;
|
||||
FTag:String;
|
||||
FMessage:String;
|
||||
FLocalIP:String;
|
||||
function GetPacketBuf:String;
|
||||
procedure SetPacketBuf(Value:String);
|
||||
public
|
||||
{:Reset values to defaults}
|
||||
procedure Clear;
|
||||
published
|
||||
{:Define facilicity of Syslog message. For specify you may use predefined
|
||||
FCL_* constants. Default is "FCL_Local0".}
|
||||
property Facility:Byte read FFacility write FFacility;
|
||||
|
||||
{:Define possible priority of Syslog message. Default is "Debug".}
|
||||
property Severity:TSyslogSeverity read FSeverity write FSeverity;
|
||||
|
||||
{:date and time of Syslog message}
|
||||
property DateTime:TDateTime read FDateTime write FDateTime;
|
||||
|
||||
{:This is used for identify process of this message. Default is filename
|
||||
of your executable file.}
|
||||
property Tag:String read FTag write FTag;
|
||||
|
||||
{:Text of your message for log.}
|
||||
property LogMessage:String read FMessage write FMessage;
|
||||
|
||||
{:IP address of message sender.}
|
||||
property LocalIP:String read FLocalIP write FLocalIP;
|
||||
|
||||
{:This property holds encoded binary SYSLOG packet}
|
||||
property PacketBuf:String read GetPacketBuf write SetPacketBuf;
|
||||
end;
|
||||
|
||||
{:@abstract(This object implement BSD SysLog client)
|
||||
|
||||
Note: Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TSyslogSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TUDPBlockSocket;
|
||||
FSysLogMessage: TSysLogMessage;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
{:Send Syslog UDP packet defined by @link(SysLogMessage).}
|
||||
function DoIt: Boolean;
|
||||
published
|
||||
{:Syslog message for send}
|
||||
property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage;
|
||||
end;
|
||||
|
||||
{:Simply send packet to specified Syslog server.}
|
||||
function ToSysLog(const SyslogServer: string; Facil: Byte;
|
||||
Sever: TSyslogSeverity; const Content: string): Boolean;
|
||||
|
||||
implementation
|
||||
|
||||
function TSyslogMessage.GetPacketBuf:String;
|
||||
begin
|
||||
Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>';
|
||||
Result := Result + CDateTime(FDateTime) + ' ';
|
||||
Result := Result + FLocalIP + ' ';
|
||||
Result := Result + FTag + ': ' + FMessage;
|
||||
end;
|
||||
|
||||
procedure TSyslogMessage.SetPacketBuf(Value:String);
|
||||
var StrBuf:String;
|
||||
IntBuf,Pos:Integer;
|
||||
begin
|
||||
if Length(Value) < 1 then exit;
|
||||
Pos := 1;
|
||||
if Value[Pos] <> '<' then exit;
|
||||
Inc(Pos);
|
||||
// Facility and Severity
|
||||
StrBuf := '';
|
||||
while (Value[Pos] <> '>')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
IntBuf := StrToInt(StrBuf);
|
||||
FFacility := IntBuf div 8;
|
||||
case (IntBuf mod 8)of
|
||||
0:FSeverity := Emergency;
|
||||
1:FSeverity := Alert;
|
||||
2:FSeverity := Critical;
|
||||
3:FSeverity := Error;
|
||||
4:FSeverity := Warning;
|
||||
5:FSeverity := Notice;
|
||||
6:FSeverity := Info;
|
||||
7:FSeverity := Debug;
|
||||
end;
|
||||
// DateTime
|
||||
Inc(Pos);
|
||||
StrBuf := '';
|
||||
// Month
|
||||
while (Value[Pos] <> ' ')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
// Day
|
||||
while (Value[Pos] <> ' ')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
// Time
|
||||
while (Value[Pos] <> ' ')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
FDateTime := DecodeRFCDateTime(StrBuf);
|
||||
Inc(Pos);
|
||||
|
||||
// LocalIP
|
||||
StrBuf := '';
|
||||
while (Value[Pos] <> ' ')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
FLocalIP := StrBuf;
|
||||
Inc(Pos);
|
||||
// Tag
|
||||
StrBuf := '';
|
||||
while (Value[Pos] <> ':')do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
FTag := StrBuf;
|
||||
// LogMessage
|
||||
Inc(Pos);
|
||||
StrBuf := '';
|
||||
while (Pos <= Length(Value))do
|
||||
begin
|
||||
StrBuf := StrBuf + Value[Pos];
|
||||
Inc(Pos);
|
||||
end;
|
||||
FMessage := TrimSP(StrBuf);
|
||||
end;
|
||||
|
||||
procedure TSysLogMessage.Clear;
|
||||
begin
|
||||
FFacility := FCL_Local0;
|
||||
FSeverity := Debug;
|
||||
FTag := ExtractFileName(ParamStr(0));
|
||||
FMessage := '';
|
||||
FLocalIP := '0.0.0.0';
|
||||
end;
|
||||
|
||||
//------------------------------------------------------------------------------
|
||||
|
||||
constructor TSyslogSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TUDPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FSysLogMessage := TSysLogMessage.Create;
|
||||
FTargetPort := cSysLogProtocol;
|
||||
end;
|
||||
|
||||
destructor TSyslogSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
FSysLogMessage.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TSyslogSend.DoIt: Boolean;
|
||||
var
|
||||
L: TStringList;
|
||||
begin
|
||||
Result := False;
|
||||
L := TStringList.Create;
|
||||
try
|
||||
FSock.ResolveNameToIP(FSock.Localname, L);
|
||||
if L.Count < 1 then
|
||||
FSysLogMessage.LocalIP := '0.0.0.0'
|
||||
else
|
||||
FSysLogMessage.LocalIP := L[0];
|
||||
finally
|
||||
L.Free;
|
||||
end;
|
||||
FSysLogMessage.DateTime := Now;
|
||||
if Length(FSysLogMessage.PacketBuf) <= 1024 then
|
||||
begin
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
FSock.SendString(FSysLogMessage.PacketBuf);
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function ToSysLog(const SyslogServer: string; Facil: Byte;
|
||||
Sever: TSyslogSeverity; const Content: string): Boolean;
|
||||
begin
|
||||
with TSyslogSend.Create do
|
||||
try
|
||||
TargetHost :=SyslogServer;
|
||||
SysLogMessage.Facility := Facil;
|
||||
SysLogMessage.Severity := Sever;
|
||||
SysLogMessage.LogMessage := Content;
|
||||
Result := DoIt;
|
||||
finally
|
||||
Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -1,374 +1,374 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 003.000.003 |
|
||||
|==============================================================================|
|
||||
| Content: SNTP client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
| Patrick Chevalley |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract( NTP and SNTP client)
|
||||
|
||||
Used RFC: RFC-1305, RFC-2030
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
unit sntpsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils,
|
||||
synsock, blcksock, synautil;
|
||||
|
||||
const
|
||||
cNtpProtocol = '123';
|
||||
|
||||
type
|
||||
|
||||
{:@abstract(Record containing the NTP packet.)}
|
||||
TNtp = packed record
|
||||
mode: Byte;
|
||||
stratum: Byte;
|
||||
poll: Byte;
|
||||
Precision: Byte;
|
||||
RootDelay: Longint;
|
||||
RootDisperson: Longint;
|
||||
RefID: Longint;
|
||||
Ref1: Longint;
|
||||
Ref2: Longint;
|
||||
Org1: Longint;
|
||||
Org2: Longint;
|
||||
Rcv1: Longint;
|
||||
Rcv2: Longint;
|
||||
Xmit1: Longint;
|
||||
Xmit2: Longint;
|
||||
end;
|
||||
|
||||
{:@abstract(Implementation of NTP and SNTP client protocol),
|
||||
include time synchronisation. It can send NTP or SNTP time queries, or it
|
||||
can receive NTP broadcasts too.
|
||||
|
||||
Note: Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TSNTPSend = class(TSynaClient)
|
||||
private
|
||||
FNTPReply: TNtp;
|
||||
FNTPTime: TDateTime;
|
||||
FNTPOffset: double;
|
||||
FNTPDelay: double;
|
||||
FMaxSyncDiff: double;
|
||||
FSyncTime: Boolean;
|
||||
FSock: TUDPBlockSocket;
|
||||
FBuffer: AnsiString;
|
||||
FLi, FVn, Fmode : byte;
|
||||
function StrToNTP(const Value: AnsiString): TNtp;
|
||||
function NTPtoStr(const Value: Tntp): AnsiString;
|
||||
procedure ClearNTP(var Value: Tntp);
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Decode 128 bit timestamp used in NTP packet to TDateTime type.}
|
||||
function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
|
||||
|
||||
{:Decode TDateTime type to 128 bit timestamp used in NTP packet.}
|
||||
procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
|
||||
|
||||
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
|
||||
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
|
||||
valid.}
|
||||
function GetSNTP: Boolean;
|
||||
|
||||
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
|
||||
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
|
||||
valid. Result time is after all needed corrections.}
|
||||
function GetNTP: Boolean;
|
||||
|
||||
{:Wait for broadcast NTP packet. If all OK, result is @true and
|
||||
@link(NTPReply) and @link(NTPTime) are valid.}
|
||||
function GetBroadcastNTP: Boolean;
|
||||
|
||||
{:Holds last received NTP packet.}
|
||||
property NTPReply: TNtp read FNTPReply;
|
||||
published
|
||||
{:Date and time of remote NTP or SNTP server. (UTC time!!!)}
|
||||
property NTPTime: TDateTime read FNTPTime;
|
||||
|
||||
{:Offset between your computer and remote NTP or SNTP server.}
|
||||
property NTPOffset: Double read FNTPOffset;
|
||||
|
||||
{:Delay between your computer and remote NTP or SNTP server.}
|
||||
property NTPDelay: Double read FNTPDelay;
|
||||
|
||||
{:Define allowed maximum difference between your time and remote time for
|
||||
synchronising time. If difference is bigger, your system time is not
|
||||
changed!}
|
||||
property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
|
||||
|
||||
{:If @true, after successfull getting time is local computer clock
|
||||
synchronised to given time.
|
||||
For synchronising time you must have proper rights! (Usually Administrator)}
|
||||
property SyncTime: Boolean read FSyncTime write FSyncTime;
|
||||
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TUDPBlockSocket read FSock;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TSNTPSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TUDPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FTimeout := 5000;
|
||||
FTargetPort := cNtpProtocol;
|
||||
FMaxSyncDiff := 3600;
|
||||
FSyncTime := False;
|
||||
end;
|
||||
|
||||
destructor TSNTPSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp;
|
||||
begin
|
||||
if length(FBuffer) >= SizeOf(Result) then
|
||||
begin
|
||||
Result.mode := ord(Value[1]);
|
||||
Result.stratum := ord(Value[2]);
|
||||
Result.poll := ord(Value[3]);
|
||||
Result.Precision := ord(Value[4]);
|
||||
Result.RootDelay := DecodeLongInt(value, 5);
|
||||
Result.RootDisperson := DecodeLongInt(value, 9);
|
||||
Result.RefID := DecodeLongInt(value, 13);
|
||||
Result.Ref1 := DecodeLongInt(value, 17);
|
||||
Result.Ref2 := DecodeLongInt(value, 21);
|
||||
Result.Org1 := DecodeLongInt(value, 25);
|
||||
Result.Org2 := DecodeLongInt(value, 29);
|
||||
Result.Rcv1 := DecodeLongInt(value, 33);
|
||||
Result.Rcv2 := DecodeLongInt(value, 37);
|
||||
Result.Xmit1 := DecodeLongInt(value, 41);
|
||||
Result.Xmit2 := DecodeLongInt(value, 45);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString;
|
||||
begin
|
||||
SetLength(Result, 4);
|
||||
Result[1] := AnsiChar(Value.mode);
|
||||
Result[2] := AnsiChar(Value.stratum);
|
||||
Result[3] := AnsiChar(Value.poll);
|
||||
Result[4] := AnsiChar(Value.precision);
|
||||
Result := Result + CodeLongInt(Value.RootDelay);
|
||||
Result := Result + CodeLongInt(Value.RootDisperson);
|
||||
Result := Result + CodeLongInt(Value.RefID);
|
||||
Result := Result + CodeLongInt(Value.Ref1);
|
||||
Result := Result + CodeLongInt(Value.Ref2);
|
||||
Result := Result + CodeLongInt(Value.Org1);
|
||||
Result := Result + CodeLongInt(Value.Org2);
|
||||
Result := Result + CodeLongInt(Value.Rcv1);
|
||||
Result := Result + CodeLongInt(Value.Rcv2);
|
||||
Result := Result + CodeLongInt(Value.Xmit1);
|
||||
Result := Result + CodeLongInt(Value.Xmit2);
|
||||
end;
|
||||
|
||||
procedure TSNTPSend.ClearNTP(var Value: Tntp);
|
||||
begin
|
||||
Value.mode := 0;
|
||||
Value.stratum := 0;
|
||||
Value.poll := 0;
|
||||
Value.Precision := 0;
|
||||
Value.RootDelay := 0;
|
||||
Value.RootDisperson := 0;
|
||||
Value.RefID := 0;
|
||||
Value.Ref1 := 0;
|
||||
Value.Ref2 := 0;
|
||||
Value.Org1 := 0;
|
||||
Value.Org2 := 0;
|
||||
Value.Rcv1 := 0;
|
||||
Value.Rcv2 := 0;
|
||||
Value.Xmit1 := 0;
|
||||
Value.Xmit2 := 0;
|
||||
end;
|
||||
|
||||
function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
|
||||
const
|
||||
maxi = 4294967295.0;
|
||||
var
|
||||
d, d1: Double;
|
||||
begin
|
||||
d := Nsec;
|
||||
if d < 0 then
|
||||
d := maxi + d + 1;
|
||||
d1 := Nfrac;
|
||||
if d1 < 0 then
|
||||
d1 := maxi + d1 + 1;
|
||||
d1 := d1 / maxi;
|
||||
d1 := Trunc(d1 * 10000) / 10000;
|
||||
Result := (d + d1) / 86400;
|
||||
Result := Result + 2;
|
||||
end;
|
||||
|
||||
procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
|
||||
const
|
||||
maxi = 4294967295.0;
|
||||
maxilongint = 2147483647;
|
||||
var
|
||||
d, d1: Double;
|
||||
begin
|
||||
d := (dt - 2) * 86400;
|
||||
d1 := frac(d);
|
||||
if d > maxilongint then
|
||||
d := d - maxi - 1;
|
||||
d := trunc(d);
|
||||
d1 := Trunc(d1 * 10000) / 10000;
|
||||
d1 := d1 * maxi;
|
||||
if d1 > maxilongint then
|
||||
d1 := d1 - maxi - 1;
|
||||
Nsec:=trunc(d);
|
||||
Nfrac:=trunc(d1);
|
||||
end;
|
||||
|
||||
function TSNTPSend.GetBroadcastNTP: Boolean;
|
||||
var
|
||||
x: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
FSock.Bind(FIPInterface, FTargetPort);
|
||||
FBuffer := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
x := Length(FBuffer);
|
||||
if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
|
||||
if x >= SizeOf(NTPReply) then
|
||||
begin
|
||||
FNTPReply := StrToNTP(FBuffer);
|
||||
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
|
||||
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
|
||||
SetUTTime(FNTPTime);
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSNTPSend.GetSNTP: Boolean;
|
||||
var
|
||||
q: TNtp;
|
||||
x: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
ClearNtp(q);
|
||||
q.mode := $1B;
|
||||
FBuffer := NTPtoStr(q);
|
||||
FSock.SendString(FBuffer);
|
||||
FBuffer := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
x := Length(FBuffer);
|
||||
if x >= SizeOf(NTPReply) then
|
||||
begin
|
||||
FNTPReply := StrToNTP(FBuffer);
|
||||
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
|
||||
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
|
||||
SetUTTime(FNTPTime);
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSNTPSend.GetNTP: Boolean;
|
||||
var
|
||||
q: TNtp;
|
||||
x: Integer;
|
||||
t1, t2, t3, t4 : TDateTime;
|
||||
begin
|
||||
Result := False;
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
ClearNtp(q);
|
||||
q.mode := $1B;
|
||||
t1 := GetUTTime;
|
||||
EncodeTs(t1, q.org1, q.org2);
|
||||
FBuffer := NTPtoStr(q);
|
||||
FSock.SendString(FBuffer);
|
||||
FBuffer := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
x := Length(FBuffer);
|
||||
t4 := GetUTTime;
|
||||
if x >= SizeOf(NTPReply) then
|
||||
begin
|
||||
FNTPReply := StrToNTP(FBuffer);
|
||||
FLi := (NTPReply.mode and $C0) shr 6;
|
||||
FVn := (NTPReply.mode and $38) shr 3;
|
||||
Fmode := NTPReply.mode and $07;
|
||||
if (Fli < 3) and (Fmode = 4) and
|
||||
(NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and
|
||||
(NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0)
|
||||
then begin
|
||||
t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2);
|
||||
t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
|
||||
FNTPDelay := (T4 - T1) - (T2 - T3);
|
||||
FNTPTime := t3 + FNTPDelay / 2;
|
||||
FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400;
|
||||
FNTPDelay := FNTPDelay * 86400;
|
||||
if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then
|
||||
SetUTTime(FNTPTime);
|
||||
Result := True;
|
||||
end
|
||||
else result:=false;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 003.000.003 |
|
||||
|==============================================================================|
|
||||
| Content: SNTP client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
| Patrick Chevalley |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract( NTP and SNTP client)
|
||||
|
||||
Used RFC: RFC-1305, RFC-2030
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
unit sntpsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils,
|
||||
synsock, blcksock, synautil;
|
||||
|
||||
const
|
||||
cNtpProtocol = '123';
|
||||
|
||||
type
|
||||
|
||||
{:@abstract(Record containing the NTP packet.)}
|
||||
TNtp = packed record
|
||||
mode: Byte;
|
||||
stratum: Byte;
|
||||
poll: Byte;
|
||||
Precision: Byte;
|
||||
RootDelay: Longint;
|
||||
RootDisperson: Longint;
|
||||
RefID: Longint;
|
||||
Ref1: Longint;
|
||||
Ref2: Longint;
|
||||
Org1: Longint;
|
||||
Org2: Longint;
|
||||
Rcv1: Longint;
|
||||
Rcv2: Longint;
|
||||
Xmit1: Longint;
|
||||
Xmit2: Longint;
|
||||
end;
|
||||
|
||||
{:@abstract(Implementation of NTP and SNTP client protocol),
|
||||
include time synchronisation. It can send NTP or SNTP time queries, or it
|
||||
can receive NTP broadcasts too.
|
||||
|
||||
Note: Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TSNTPSend = class(TSynaClient)
|
||||
private
|
||||
FNTPReply: TNtp;
|
||||
FNTPTime: TDateTime;
|
||||
FNTPOffset: double;
|
||||
FNTPDelay: double;
|
||||
FMaxSyncDiff: double;
|
||||
FSyncTime: Boolean;
|
||||
FSock: TUDPBlockSocket;
|
||||
FBuffer: AnsiString;
|
||||
FLi, FVn, Fmode : byte;
|
||||
function StrToNTP(const Value: AnsiString): TNtp;
|
||||
function NTPtoStr(const Value: Tntp): AnsiString;
|
||||
procedure ClearNTP(var Value: Tntp);
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Decode 128 bit timestamp used in NTP packet to TDateTime type.}
|
||||
function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
|
||||
|
||||
{:Decode TDateTime type to 128 bit timestamp used in NTP packet.}
|
||||
procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
|
||||
|
||||
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
|
||||
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
|
||||
valid.}
|
||||
function GetSNTP: Boolean;
|
||||
|
||||
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
|
||||
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
|
||||
valid. Result time is after all needed corrections.}
|
||||
function GetNTP: Boolean;
|
||||
|
||||
{:Wait for broadcast NTP packet. If all OK, result is @true and
|
||||
@link(NTPReply) and @link(NTPTime) are valid.}
|
||||
function GetBroadcastNTP: Boolean;
|
||||
|
||||
{:Holds last received NTP packet.}
|
||||
property NTPReply: TNtp read FNTPReply;
|
||||
published
|
||||
{:Date and time of remote NTP or SNTP server. (UTC time!!!)}
|
||||
property NTPTime: TDateTime read FNTPTime;
|
||||
|
||||
{:Offset between your computer and remote NTP or SNTP server.}
|
||||
property NTPOffset: Double read FNTPOffset;
|
||||
|
||||
{:Delay between your computer and remote NTP or SNTP server.}
|
||||
property NTPDelay: Double read FNTPDelay;
|
||||
|
||||
{:Define allowed maximum difference between your time and remote time for
|
||||
synchronising time. If difference is bigger, your system time is not
|
||||
changed!}
|
||||
property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
|
||||
|
||||
{:If @true, after successfull getting time is local computer clock
|
||||
synchronised to given time.
|
||||
For synchronising time you must have proper rights! (Usually Administrator)}
|
||||
property SyncTime: Boolean read FSyncTime write FSyncTime;
|
||||
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TUDPBlockSocket read FSock;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TSNTPSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TUDPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FTimeout := 5000;
|
||||
FTargetPort := cNtpProtocol;
|
||||
FMaxSyncDiff := 3600;
|
||||
FSyncTime := False;
|
||||
end;
|
||||
|
||||
destructor TSNTPSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp;
|
||||
begin
|
||||
if length(FBuffer) >= SizeOf(Result) then
|
||||
begin
|
||||
Result.mode := ord(Value[1]);
|
||||
Result.stratum := ord(Value[2]);
|
||||
Result.poll := ord(Value[3]);
|
||||
Result.Precision := ord(Value[4]);
|
||||
Result.RootDelay := DecodeLongInt(value, 5);
|
||||
Result.RootDisperson := DecodeLongInt(value, 9);
|
||||
Result.RefID := DecodeLongInt(value, 13);
|
||||
Result.Ref1 := DecodeLongInt(value, 17);
|
||||
Result.Ref2 := DecodeLongInt(value, 21);
|
||||
Result.Org1 := DecodeLongInt(value, 25);
|
||||
Result.Org2 := DecodeLongInt(value, 29);
|
||||
Result.Rcv1 := DecodeLongInt(value, 33);
|
||||
Result.Rcv2 := DecodeLongInt(value, 37);
|
||||
Result.Xmit1 := DecodeLongInt(value, 41);
|
||||
Result.Xmit2 := DecodeLongInt(value, 45);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString;
|
||||
begin
|
||||
SetLength(Result, 4);
|
||||
Result[1] := AnsiChar(Value.mode);
|
||||
Result[2] := AnsiChar(Value.stratum);
|
||||
Result[3] := AnsiChar(Value.poll);
|
||||
Result[4] := AnsiChar(Value.precision);
|
||||
Result := Result + CodeLongInt(Value.RootDelay);
|
||||
Result := Result + CodeLongInt(Value.RootDisperson);
|
||||
Result := Result + CodeLongInt(Value.RefID);
|
||||
Result := Result + CodeLongInt(Value.Ref1);
|
||||
Result := Result + CodeLongInt(Value.Ref2);
|
||||
Result := Result + CodeLongInt(Value.Org1);
|
||||
Result := Result + CodeLongInt(Value.Org2);
|
||||
Result := Result + CodeLongInt(Value.Rcv1);
|
||||
Result := Result + CodeLongInt(Value.Rcv2);
|
||||
Result := Result + CodeLongInt(Value.Xmit1);
|
||||
Result := Result + CodeLongInt(Value.Xmit2);
|
||||
end;
|
||||
|
||||
procedure TSNTPSend.ClearNTP(var Value: Tntp);
|
||||
begin
|
||||
Value.mode := 0;
|
||||
Value.stratum := 0;
|
||||
Value.poll := 0;
|
||||
Value.Precision := 0;
|
||||
Value.RootDelay := 0;
|
||||
Value.RootDisperson := 0;
|
||||
Value.RefID := 0;
|
||||
Value.Ref1 := 0;
|
||||
Value.Ref2 := 0;
|
||||
Value.Org1 := 0;
|
||||
Value.Org2 := 0;
|
||||
Value.Rcv1 := 0;
|
||||
Value.Rcv2 := 0;
|
||||
Value.Xmit1 := 0;
|
||||
Value.Xmit2 := 0;
|
||||
end;
|
||||
|
||||
function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
|
||||
const
|
||||
maxi = 4294967295.0;
|
||||
var
|
||||
d, d1: Double;
|
||||
begin
|
||||
d := Nsec;
|
||||
if d < 0 then
|
||||
d := maxi + d + 1;
|
||||
d1 := Nfrac;
|
||||
if d1 < 0 then
|
||||
d1 := maxi + d1 + 1;
|
||||
d1 := d1 / maxi;
|
||||
d1 := Trunc(d1 * 10000) / 10000;
|
||||
Result := (d + d1) / 86400;
|
||||
Result := Result + 2;
|
||||
end;
|
||||
|
||||
procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
|
||||
const
|
||||
maxi = 4294967295.0;
|
||||
maxilongint = 2147483647;
|
||||
var
|
||||
d, d1: Double;
|
||||
begin
|
||||
d := (dt - 2) * 86400;
|
||||
d1 := frac(d);
|
||||
if d > maxilongint then
|
||||
d := d - maxi - 1;
|
||||
d := trunc(d);
|
||||
d1 := Trunc(d1 * 10000) / 10000;
|
||||
d1 := d1 * maxi;
|
||||
if d1 > maxilongint then
|
||||
d1 := d1 - maxi - 1;
|
||||
Nsec:=trunc(d);
|
||||
Nfrac:=trunc(d1);
|
||||
end;
|
||||
|
||||
function TSNTPSend.GetBroadcastNTP: Boolean;
|
||||
var
|
||||
x: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
FSock.Bind(FIPInterface, FTargetPort);
|
||||
FBuffer := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
x := Length(FBuffer);
|
||||
if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
|
||||
if x >= SizeOf(NTPReply) then
|
||||
begin
|
||||
FNTPReply := StrToNTP(FBuffer);
|
||||
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
|
||||
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
|
||||
SetUTTime(FNTPTime);
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSNTPSend.GetSNTP: Boolean;
|
||||
var
|
||||
q: TNtp;
|
||||
x: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
ClearNtp(q);
|
||||
q.mode := $1B;
|
||||
FBuffer := NTPtoStr(q);
|
||||
FSock.SendString(FBuffer);
|
||||
FBuffer := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
x := Length(FBuffer);
|
||||
if x >= SizeOf(NTPReply) then
|
||||
begin
|
||||
FNTPReply := StrToNTP(FBuffer);
|
||||
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
|
||||
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
|
||||
SetUTTime(FNTPTime);
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSNTPSend.GetNTP: Boolean;
|
||||
var
|
||||
q: TNtp;
|
||||
x: Integer;
|
||||
t1, t2, t3, t4 : TDateTime;
|
||||
begin
|
||||
Result := False;
|
||||
FSock.CloseSocket;
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
ClearNtp(q);
|
||||
q.mode := $1B;
|
||||
t1 := GetUTTime;
|
||||
EncodeTs(t1, q.org1, q.org2);
|
||||
FBuffer := NTPtoStr(q);
|
||||
FSock.SendString(FBuffer);
|
||||
FBuffer := FSock.RecvPacket(FTimeout);
|
||||
if FSock.LastError = 0 then
|
||||
begin
|
||||
x := Length(FBuffer);
|
||||
t4 := GetUTTime;
|
||||
if x >= SizeOf(NTPReply) then
|
||||
begin
|
||||
FNTPReply := StrToNTP(FBuffer);
|
||||
FLi := (NTPReply.mode and $C0) shr 6;
|
||||
FVn := (NTPReply.mode and $38) shr 3;
|
||||
Fmode := NTPReply.mode and $07;
|
||||
if (Fli < 3) and (Fmode = 4) and
|
||||
(NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and
|
||||
(NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0)
|
||||
then begin
|
||||
t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2);
|
||||
t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
|
||||
FNTPDelay := (T4 - T1) - (T2 - T3);
|
||||
FNTPTime := t3 + FNTPDelay / 2;
|
||||
FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400;
|
||||
FNTPDelay := FNTPDelay * 86400;
|
||||
if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then
|
||||
SetUTTime(FNTPTime);
|
||||
Result := True;
|
||||
end
|
||||
else result:=false;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -1,156 +1,156 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.001 |
|
||||
|==============================================================================|
|
||||
| Content: Socket debug tools |
|
||||
|==============================================================================|
|
||||
| Copyright (c)2008-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2008-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(Socket debug tools)
|
||||
|
||||
Routines for help with debugging of events on the Sockets.
|
||||
}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit synadbg;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
blcksock, synsock, synautil, classes, sysutils;
|
||||
|
||||
type
|
||||
TSynaDebug = class(TObject)
|
||||
class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
|
||||
class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
|
||||
end;
|
||||
|
||||
procedure AppendToLog(const value: Ansistring);
|
||||
|
||||
var
|
||||
LogFile: string;
|
||||
|
||||
implementation
|
||||
|
||||
procedure AppendToLog(const value: Ansistring);
|
||||
var
|
||||
st: TFileStream;
|
||||
s: string;
|
||||
h, m, ss, ms: word;
|
||||
dt: Tdatetime;
|
||||
begin
|
||||
if fileexists(LogFile) then
|
||||
st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite)
|
||||
else
|
||||
st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite);
|
||||
try
|
||||
st.Position := st.Size;
|
||||
dt := now;
|
||||
decodetime(dt, h, m, ss, ms);
|
||||
s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value;
|
||||
WriteStrToStream(st, s);
|
||||
finally
|
||||
st.free;
|
||||
end;
|
||||
end;
|
||||
|
||||
class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
case Reason of
|
||||
HR_ResolvingBegin:
|
||||
s := 'HR_ResolvingBegin';
|
||||
HR_ResolvingEnd:
|
||||
s := 'HR_ResolvingEnd';
|
||||
HR_SocketCreate:
|
||||
s := 'HR_SocketCreate';
|
||||
HR_SocketClose:
|
||||
s := 'HR_SocketClose';
|
||||
HR_Bind:
|
||||
s := 'HR_Bind';
|
||||
HR_Connect:
|
||||
s := 'HR_Connect';
|
||||
HR_CanRead:
|
||||
s := 'HR_CanRead';
|
||||
HR_CanWrite:
|
||||
s := 'HR_CanWrite';
|
||||
HR_Listen:
|
||||
s := 'HR_Listen';
|
||||
HR_Accept:
|
||||
s := 'HR_Accept';
|
||||
HR_ReadCount:
|
||||
s := 'HR_ReadCount';
|
||||
HR_WriteCount:
|
||||
s := 'HR_WriteCount';
|
||||
HR_Wait:
|
||||
s := 'HR_Wait';
|
||||
HR_Error:
|
||||
s := 'HR_Error';
|
||||
else
|
||||
s := '-unknown-';
|
||||
end;
|
||||
s := inttohex(integer(Sender), 8) + s + ': ' + value + CRLF;
|
||||
AppendToLog(s);
|
||||
end;
|
||||
|
||||
class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
|
||||
var
|
||||
s, d: Ansistring;
|
||||
begin
|
||||
setlength(s, len);
|
||||
move(Buffer^, pointer(s)^, len);
|
||||
if writing then
|
||||
d := '-> '
|
||||
else
|
||||
d := '<- ';
|
||||
s :=inttohex(integer(Sender), 8) + d + s + CRLF;
|
||||
AppendToLog(s);
|
||||
end;
|
||||
|
||||
initialization
|
||||
begin
|
||||
Logfile := changefileext(paramstr(0), '.slog');
|
||||
end;
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.001 |
|
||||
|==============================================================================|
|
||||
| Content: Socket debug tools |
|
||||
|==============================================================================|
|
||||
| Copyright (c)2008-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2008-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(Socket debug tools)
|
||||
|
||||
Routines for help with debugging of events on the Sockets.
|
||||
}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit synadbg;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
blcksock, synsock, synautil, classes, sysutils;
|
||||
|
||||
type
|
||||
TSynaDebug = class(TObject)
|
||||
class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
|
||||
class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
|
||||
end;
|
||||
|
||||
procedure AppendToLog(const value: Ansistring);
|
||||
|
||||
var
|
||||
LogFile: string;
|
||||
|
||||
implementation
|
||||
|
||||
procedure AppendToLog(const value: Ansistring);
|
||||
var
|
||||
st: TFileStream;
|
||||
s: string;
|
||||
h, m, ss, ms: word;
|
||||
dt: Tdatetime;
|
||||
begin
|
||||
if fileexists(LogFile) then
|
||||
st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite)
|
||||
else
|
||||
st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite);
|
||||
try
|
||||
st.Position := st.Size;
|
||||
dt := now;
|
||||
decodetime(dt, h, m, ss, ms);
|
||||
s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value;
|
||||
WriteStrToStream(st, s);
|
||||
finally
|
||||
st.free;
|
||||
end;
|
||||
end;
|
||||
|
||||
class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
|
||||
var
|
||||
s: string;
|
||||
begin
|
||||
case Reason of
|
||||
HR_ResolvingBegin:
|
||||
s := 'HR_ResolvingBegin';
|
||||
HR_ResolvingEnd:
|
||||
s := 'HR_ResolvingEnd';
|
||||
HR_SocketCreate:
|
||||
s := 'HR_SocketCreate';
|
||||
HR_SocketClose:
|
||||
s := 'HR_SocketClose';
|
||||
HR_Bind:
|
||||
s := 'HR_Bind';
|
||||
HR_Connect:
|
||||
s := 'HR_Connect';
|
||||
HR_CanRead:
|
||||
s := 'HR_CanRead';
|
||||
HR_CanWrite:
|
||||
s := 'HR_CanWrite';
|
||||
HR_Listen:
|
||||
s := 'HR_Listen';
|
||||
HR_Accept:
|
||||
s := 'HR_Accept';
|
||||
HR_ReadCount:
|
||||
s := 'HR_ReadCount';
|
||||
HR_WriteCount:
|
||||
s := 'HR_WriteCount';
|
||||
HR_Wait:
|
||||
s := 'HR_Wait';
|
||||
HR_Error:
|
||||
s := 'HR_Error';
|
||||
else
|
||||
s := '-unknown-';
|
||||
end;
|
||||
s := inttohex(integer(Sender), 8) + s + ': ' + value + CRLF;
|
||||
AppendToLog(s);
|
||||
end;
|
||||
|
||||
class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
|
||||
var
|
||||
s, d: Ansistring;
|
||||
begin
|
||||
setlength(s, len);
|
||||
move(Buffer^, pointer(s)^, len);
|
||||
if writing then
|
||||
d := '-> '
|
||||
else
|
||||
d := '<- ';
|
||||
s :=inttohex(integer(Sender), 8) + d + s + CRLF;
|
||||
AppendToLog(s);
|
||||
end;
|
||||
|
||||
initialization
|
||||
begin
|
||||
Logfile := changefileext(paramstr(0), '.slog');
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
|
@ -1,137 +1,137 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.002 |
|
||||
|==============================================================================|
|
||||
| Content: Utils for FreePascal compatibility |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@exclude}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
//old Delphi does not have MSWINDOWS define.
|
||||
{$IFDEF WIN32}
|
||||
{$IFNDEF MSWINDOWS}
|
||||
{$DEFINE MSWINDOWS}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
unit synafpc;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
dynlibs, sysutils;
|
||||
{$ELSE}
|
||||
{$IFDEF MSWINDOWS}
|
||||
Windows;
|
||||
{$ELSE}
|
||||
SysUtils;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF FPC}
|
||||
type
|
||||
TLibHandle = dynlibs.TLibHandle;
|
||||
|
||||
function LoadLibrary(ModuleName: PChar): TLibHandle;
|
||||
function FreeLibrary(Module: TLibHandle): LongBool;
|
||||
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
|
||||
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
|
||||
{$ELSE}
|
||||
type
|
||||
{$IFDEF CIL}
|
||||
TLibHandle = Integer;
|
||||
{$ELSE}
|
||||
TLibHandle = HModule;
|
||||
{$ENDIF}
|
||||
{$IFDEF VER100}
|
||||
LongWord = DWord;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
procedure Sleep(milliseconds: Cardinal);
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
{$IFDEF FPC}
|
||||
function LoadLibrary(ModuleName: PChar): TLibHandle;
|
||||
begin
|
||||
Result := dynlibs.LoadLibrary(Modulename);
|
||||
end;
|
||||
|
||||
function FreeLibrary(Module: TLibHandle): LongBool;
|
||||
begin
|
||||
Result := dynlibs.UnloadLibrary(Module);
|
||||
end;
|
||||
|
||||
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
|
||||
begin
|
||||
Result := dynlibs.GetProcedureAddress(Module, Proc);
|
||||
end;
|
||||
|
||||
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
{$ELSE}
|
||||
{$ENDIF}
|
||||
|
||||
procedure Sleep(milliseconds: Cardinal);
|
||||
begin
|
||||
{$IFDEF MSWINDOWS}
|
||||
{$IFDEF FPC}
|
||||
sysutils.sleep(milliseconds);
|
||||
{$ELSE}
|
||||
windows.sleep(milliseconds);
|
||||
{$ENDIF}
|
||||
{$ELSE}
|
||||
sysutils.sleep(milliseconds);
|
||||
{$ENDIF}
|
||||
|
||||
end;
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.002 |
|
||||
|==============================================================================|
|
||||
| Content: Utils for FreePascal compatibility |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@exclude}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
//old Delphi does not have MSWINDOWS define.
|
||||
{$IFDEF WIN32}
|
||||
{$IFNDEF MSWINDOWS}
|
||||
{$DEFINE MSWINDOWS}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
unit synafpc;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF FPC}
|
||||
dynlibs, sysutils;
|
||||
{$ELSE}
|
||||
{$IFDEF MSWINDOWS}
|
||||
Windows;
|
||||
{$ELSE}
|
||||
SysUtils;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF FPC}
|
||||
type
|
||||
TLibHandle = dynlibs.TLibHandle;
|
||||
|
||||
function LoadLibrary(ModuleName: PChar): TLibHandle;
|
||||
function FreeLibrary(Module: TLibHandle): LongBool;
|
||||
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
|
||||
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
|
||||
{$ELSE}
|
||||
type
|
||||
{$IFDEF CIL}
|
||||
TLibHandle = Integer;
|
||||
{$ELSE}
|
||||
TLibHandle = HModule;
|
||||
{$ENDIF}
|
||||
{$IFDEF VER100}
|
||||
LongWord = DWord;
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
procedure Sleep(milliseconds: Cardinal);
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
{$IFDEF FPC}
|
||||
function LoadLibrary(ModuleName: PChar): TLibHandle;
|
||||
begin
|
||||
Result := dynlibs.LoadLibrary(Modulename);
|
||||
end;
|
||||
|
||||
function FreeLibrary(Module: TLibHandle): LongBool;
|
||||
begin
|
||||
Result := dynlibs.UnloadLibrary(Module);
|
||||
end;
|
||||
|
||||
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
|
||||
begin
|
||||
Result := dynlibs.GetProcedureAddress(Module, Proc);
|
||||
end;
|
||||
|
||||
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
{$ELSE}
|
||||
{$ENDIF}
|
||||
|
||||
procedure Sleep(milliseconds: Cardinal);
|
||||
begin
|
||||
{$IFDEF MSWINDOWS}
|
||||
{$IFDEF FPC}
|
||||
sysutils.sleep(milliseconds);
|
||||
{$ELSE}
|
||||
windows.sleep(milliseconds);
|
||||
{$ENDIF}
|
||||
{$ELSE}
|
||||
sysutils.sleep(milliseconds);
|
||||
{$ENDIF}
|
||||
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
|
@ -1,363 +1,363 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.001 |
|
||||
|==============================================================================|
|
||||
| Content: ICONV support for Win32, Linux and .NET |
|
||||
|==============================================================================|
|
||||
| Copyright (c)2004-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2004-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
//old Delphi does not have MSWINDOWS define.
|
||||
{$IFDEF WIN32}
|
||||
{$IFNDEF MSWINDOWS}
|
||||
{$DEFINE MSWINDOWS}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
{:@abstract(LibIconv support)
|
||||
|
||||
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,
|
||||
requested LibIconv function just return errorcode.
|
||||
}
|
||||
unit synaicnv;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF CIL}
|
||||
System.Runtime.InteropServices,
|
||||
System.Text,
|
||||
{$ENDIF}
|
||||
synafpc,
|
||||
{$IFNDEF MSWINDOWS}
|
||||
{$IFNDEF FPC}
|
||||
Libc,
|
||||
{$ENDIF}
|
||||
SysUtils;
|
||||
{$ELSE}
|
||||
Windows;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
const
|
||||
{$IFNDEF MSWINDOWS}
|
||||
DLLIconvName = 'libiconv.so';
|
||||
{$ELSE}
|
||||
DLLIconvName = 'iconv.dll';
|
||||
{$ENDIF}
|
||||
|
||||
type
|
||||
size_t = Cardinal;
|
||||
{$IFDEF CIL}
|
||||
iconv_t = IntPtr;
|
||||
{$ELSE}
|
||||
iconv_t = Pointer;
|
||||
{$ENDIF}
|
||||
argptr = iconv_t;
|
||||
|
||||
var
|
||||
iconvLibHandle: TLibHandle = 0;
|
||||
|
||||
function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t;
|
||||
function SynaIconvOpenTranslit(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 SynaIconvClose(var cd: iconv_t): integer;
|
||||
function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer;
|
||||
|
||||
function IsIconvloaded: Boolean;
|
||||
function InitIconvInterface: Boolean;
|
||||
function DestroyIconvInterface: Boolean;
|
||||
|
||||
const
|
||||
ICONV_TRIVIALP = 0; // int *argument
|
||||
ICONV_GET_TRANSLITERATE = 1; // int *argument
|
||||
ICONV_SET_TRANSLITERATE = 2; // const int *argument
|
||||
ICONV_GET_DISCARD_ILSEQ = 3; // int *argument
|
||||
ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
uses SyncObjs;
|
||||
|
||||
{$IFDEF CIL}
|
||||
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
|
||||
SetLastError = False, CallingConvention= CallingConvention.cdecl,
|
||||
EntryPoint = 'libiconv_open')]
|
||||
function _iconv_open(tocode: string; fromcode: string): iconv_t; external;
|
||||
|
||||
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
|
||||
SetLastError = False, CallingConvention= CallingConvention.cdecl,
|
||||
EntryPoint = 'libiconv')]
|
||||
function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t;
|
||||
var outbuf: IntPtr; var outbytesleft: size_t): size_t; external;
|
||||
|
||||
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
|
||||
SetLastError = False, CallingConvention= CallingConvention.cdecl,
|
||||
EntryPoint = 'libiconv_close')]
|
||||
function _iconv_close(cd: iconv_t): integer; external;
|
||||
|
||||
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
|
||||
SetLastError = False, CallingConvention= CallingConvention.cdecl,
|
||||
EntryPoint = 'libiconvctl')]
|
||||
function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external;
|
||||
|
||||
{$ELSE}
|
||||
type
|
||||
Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl;
|
||||
Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t;
|
||||
var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl;
|
||||
Ticonv_close = function(cd: iconv_t): integer; cdecl;
|
||||
Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl;
|
||||
var
|
||||
_iconv_open: Ticonv_open = nil;
|
||||
_iconv: Ticonv = nil;
|
||||
_iconv_close: Ticonv_close = nil;
|
||||
_iconvctl: Ticonvctl = nil;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
var
|
||||
IconvCS: TCriticalSection;
|
||||
Iconvloaded: boolean = false;
|
||||
|
||||
function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t;
|
||||
begin
|
||||
{$IFDEF CIL}
|
||||
try
|
||||
Result := _iconv_open(tocode, fromcode);
|
||||
except
|
||||
on Exception do
|
||||
Result := iconv_t(-1);
|
||||
end;
|
||||
{$ELSE}
|
||||
if InitIconvInterface and Assigned(_iconv_open) then
|
||||
Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode))
|
||||
else
|
||||
Result := iconv_t(-1);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t;
|
||||
begin
|
||||
Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode);
|
||||
end;
|
||||
|
||||
function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t;
|
||||
begin
|
||||
Result := SynaIconvOpen(tocode + '//IGNORE', fromcode);
|
||||
end;
|
||||
|
||||
function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
|
||||
var
|
||||
{$IFDEF CIL}
|
||||
ib, ob: IntPtr;
|
||||
ibsave, obsave: IntPtr;
|
||||
l: integer;
|
||||
{$ELSE}
|
||||
ib, ob: Pointer;
|
||||
{$ENDIF}
|
||||
ix, ox: size_t;
|
||||
begin
|
||||
{$IFDEF CIL}
|
||||
l := Length(inbuf) * 4;
|
||||
ibsave := IntPtr.Zero;
|
||||
obsave := IntPtr.Zero;
|
||||
try
|
||||
ibsave := Marshal.StringToHGlobalAnsi(inbuf);
|
||||
obsave := Marshal.AllocHGlobal(l);
|
||||
ib := ibsave;
|
||||
ob := obsave;
|
||||
ix := Length(inbuf);
|
||||
ox := l;
|
||||
_iconv(cd, ib, ix, ob, ox);
|
||||
Outbuf := Marshal.PtrToStringAnsi(obsave, l);
|
||||
setlength(Outbuf, l - ox);
|
||||
Result := Length(inbuf) - ix;
|
||||
finally
|
||||
Marshal.FreeCoTaskMem(ibsave);
|
||||
Marshal.FreeHGlobal(obsave);
|
||||
end;
|
||||
{$ELSE}
|
||||
if InitIconvInterface and Assigned(_iconv) then
|
||||
begin
|
||||
setlength(Outbuf, Length(inbuf) * 4);
|
||||
ib := Pointer(inbuf);
|
||||
ob := Pointer(Outbuf);
|
||||
ix := Length(inbuf);
|
||||
ox := Length(Outbuf);
|
||||
_iconv(cd, ib, ix, ob, ox);
|
||||
setlength(Outbuf, cardinal(Length(Outbuf)) - ox);
|
||||
Result := Cardinal(Length(inbuf)) - ix;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Outbuf := '';
|
||||
Result := 0;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function SynaIconvClose(var cd: iconv_t): integer;
|
||||
begin
|
||||
if cd = iconv_t(-1) then
|
||||
begin
|
||||
Result := 0;
|
||||
Exit;
|
||||
end;
|
||||
{$IFDEF CIL}
|
||||
try;
|
||||
Result := _iconv_close(cd)
|
||||
except
|
||||
on Exception do
|
||||
Result := -1;
|
||||
end;
|
||||
cd := iconv_t(-1);
|
||||
{$ELSE}
|
||||
if InitIconvInterface and Assigned(_iconv_close) then
|
||||
Result := _iconv_close(cd)
|
||||
else
|
||||
Result := -1;
|
||||
cd := iconv_t(-1);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer;
|
||||
begin
|
||||
{$IFDEF CIL}
|
||||
Result := _iconvctl(cd, request, argument)
|
||||
{$ELSE}
|
||||
if InitIconvInterface and Assigned(_iconvctl) then
|
||||
Result := _iconvctl(cd, request, argument)
|
||||
else
|
||||
Result := 0;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function InitIconvInterface: Boolean;
|
||||
begin
|
||||
IconvCS.Enter;
|
||||
try
|
||||
if not IsIconvloaded then
|
||||
begin
|
||||
{$IFDEF CIL}
|
||||
IconvLibHandle := 1;
|
||||
{$ELSE}
|
||||
IconvLibHandle := LoadLibrary(PChar(DLLIconvName));
|
||||
{$ENDIF}
|
||||
if (IconvLibHandle <> 0) then
|
||||
begin
|
||||
{$IFNDEF CIL}
|
||||
_iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open')));
|
||||
_iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv')));
|
||||
_iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close')));
|
||||
_iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl')));
|
||||
{$ENDIF}
|
||||
Result := True;
|
||||
Iconvloaded := True;
|
||||
end
|
||||
else
|
||||
begin
|
||||
//load failed!
|
||||
if IconvLibHandle <> 0 then
|
||||
begin
|
||||
{$IFNDEF CIL}
|
||||
FreeLibrary(IconvLibHandle);
|
||||
{$ENDIF}
|
||||
IconvLibHandle := 0;
|
||||
end;
|
||||
Result := False;
|
||||
end;
|
||||
end
|
||||
else
|
||||
//loaded before...
|
||||
Result := true;
|
||||
finally
|
||||
IconvCS.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
function DestroyIconvInterface: Boolean;
|
||||
begin
|
||||
IconvCS.Enter;
|
||||
try
|
||||
Iconvloaded := false;
|
||||
if IconvLibHandle <> 0 then
|
||||
begin
|
||||
{$IFNDEF CIL}
|
||||
FreeLibrary(IconvLibHandle);
|
||||
{$ENDIF}
|
||||
IconvLibHandle := 0;
|
||||
end;
|
||||
{$IFNDEF CIL}
|
||||
_iconv_open := nil;
|
||||
_iconv := nil;
|
||||
_iconv_close := nil;
|
||||
_iconvctl := nil;
|
||||
{$ENDIF}
|
||||
finally
|
||||
IconvCS.Leave;
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function IsIconvloaded: Boolean;
|
||||
begin
|
||||
Result := IconvLoaded;
|
||||
end;
|
||||
|
||||
initialization
|
||||
begin
|
||||
IconvCS:= TCriticalSection.Create;
|
||||
end;
|
||||
|
||||
finalization
|
||||
begin
|
||||
{$IFNDEF CIL}
|
||||
DestroyIconvInterface;
|
||||
{$ENDIF}
|
||||
IconvCS.Free;
|
||||
end;
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.001.001 |
|
||||
|==============================================================================|
|
||||
| Content: ICONV support for Win32, Linux and .NET |
|
||||
|==============================================================================|
|
||||
| Copyright (c)2004-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2004-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
//old Delphi does not have MSWINDOWS define.
|
||||
{$IFDEF WIN32}
|
||||
{$IFNDEF MSWINDOWS}
|
||||
{$DEFINE MSWINDOWS}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
{:@abstract(LibIconv support)
|
||||
|
||||
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,
|
||||
requested LibIconv function just return errorcode.
|
||||
}
|
||||
unit synaicnv;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF CIL}
|
||||
System.Runtime.InteropServices,
|
||||
System.Text,
|
||||
{$ENDIF}
|
||||
synafpc,
|
||||
{$IFNDEF MSWINDOWS}
|
||||
{$IFNDEF FPC}
|
||||
Libc,
|
||||
{$ENDIF}
|
||||
SysUtils;
|
||||
{$ELSE}
|
||||
Windows;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
const
|
||||
{$IFNDEF MSWINDOWS}
|
||||
DLLIconvName = 'libiconv.so';
|
||||
{$ELSE}
|
||||
DLLIconvName = 'iconv.dll';
|
||||
{$ENDIF}
|
||||
|
||||
type
|
||||
size_t = Cardinal;
|
||||
{$IFDEF CIL}
|
||||
iconv_t = IntPtr;
|
||||
{$ELSE}
|
||||
iconv_t = Pointer;
|
||||
{$ENDIF}
|
||||
argptr = iconv_t;
|
||||
|
||||
var
|
||||
iconvLibHandle: TLibHandle = 0;
|
||||
|
||||
function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t;
|
||||
function SynaIconvOpenTranslit(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 SynaIconvClose(var cd: iconv_t): integer;
|
||||
function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer;
|
||||
|
||||
function IsIconvloaded: Boolean;
|
||||
function InitIconvInterface: Boolean;
|
||||
function DestroyIconvInterface: Boolean;
|
||||
|
||||
const
|
||||
ICONV_TRIVIALP = 0; // int *argument
|
||||
ICONV_GET_TRANSLITERATE = 1; // int *argument
|
||||
ICONV_SET_TRANSLITERATE = 2; // const int *argument
|
||||
ICONV_GET_DISCARD_ILSEQ = 3; // int *argument
|
||||
ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
uses SyncObjs;
|
||||
|
||||
{$IFDEF CIL}
|
||||
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
|
||||
SetLastError = False, CallingConvention= CallingConvention.cdecl,
|
||||
EntryPoint = 'libiconv_open')]
|
||||
function _iconv_open(tocode: string; fromcode: string): iconv_t; external;
|
||||
|
||||
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
|
||||
SetLastError = False, CallingConvention= CallingConvention.cdecl,
|
||||
EntryPoint = 'libiconv')]
|
||||
function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t;
|
||||
var outbuf: IntPtr; var outbytesleft: size_t): size_t; external;
|
||||
|
||||
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
|
||||
SetLastError = False, CallingConvention= CallingConvention.cdecl,
|
||||
EntryPoint = 'libiconv_close')]
|
||||
function _iconv_close(cd: iconv_t): integer; external;
|
||||
|
||||
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
|
||||
SetLastError = False, CallingConvention= CallingConvention.cdecl,
|
||||
EntryPoint = 'libiconvctl')]
|
||||
function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external;
|
||||
|
||||
{$ELSE}
|
||||
type
|
||||
Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl;
|
||||
Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t;
|
||||
var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl;
|
||||
Ticonv_close = function(cd: iconv_t): integer; cdecl;
|
||||
Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl;
|
||||
var
|
||||
_iconv_open: Ticonv_open = nil;
|
||||
_iconv: Ticonv = nil;
|
||||
_iconv_close: Ticonv_close = nil;
|
||||
_iconvctl: Ticonvctl = nil;
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
var
|
||||
IconvCS: TCriticalSection;
|
||||
Iconvloaded: boolean = false;
|
||||
|
||||
function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t;
|
||||
begin
|
||||
{$IFDEF CIL}
|
||||
try
|
||||
Result := _iconv_open(tocode, fromcode);
|
||||
except
|
||||
on Exception do
|
||||
Result := iconv_t(-1);
|
||||
end;
|
||||
{$ELSE}
|
||||
if InitIconvInterface and Assigned(_iconv_open) then
|
||||
Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode))
|
||||
else
|
||||
Result := iconv_t(-1);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t;
|
||||
begin
|
||||
Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode);
|
||||
end;
|
||||
|
||||
function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t;
|
||||
begin
|
||||
Result := SynaIconvOpen(tocode + '//IGNORE', fromcode);
|
||||
end;
|
||||
|
||||
function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
|
||||
var
|
||||
{$IFDEF CIL}
|
||||
ib, ob: IntPtr;
|
||||
ibsave, obsave: IntPtr;
|
||||
l: integer;
|
||||
{$ELSE}
|
||||
ib, ob: Pointer;
|
||||
{$ENDIF}
|
||||
ix, ox: size_t;
|
||||
begin
|
||||
{$IFDEF CIL}
|
||||
l := Length(inbuf) * 4;
|
||||
ibsave := IntPtr.Zero;
|
||||
obsave := IntPtr.Zero;
|
||||
try
|
||||
ibsave := Marshal.StringToHGlobalAnsi(inbuf);
|
||||
obsave := Marshal.AllocHGlobal(l);
|
||||
ib := ibsave;
|
||||
ob := obsave;
|
||||
ix := Length(inbuf);
|
||||
ox := l;
|
||||
_iconv(cd, ib, ix, ob, ox);
|
||||
Outbuf := Marshal.PtrToStringAnsi(obsave, l);
|
||||
setlength(Outbuf, l - ox);
|
||||
Result := Length(inbuf) - ix;
|
||||
finally
|
||||
Marshal.FreeCoTaskMem(ibsave);
|
||||
Marshal.FreeHGlobal(obsave);
|
||||
end;
|
||||
{$ELSE}
|
||||
if InitIconvInterface and Assigned(_iconv) then
|
||||
begin
|
||||
setlength(Outbuf, Length(inbuf) * 4);
|
||||
ib := Pointer(inbuf);
|
||||
ob := Pointer(Outbuf);
|
||||
ix := Length(inbuf);
|
||||
ox := Length(Outbuf);
|
||||
_iconv(cd, ib, ix, ob, ox);
|
||||
setlength(Outbuf, cardinal(Length(Outbuf)) - ox);
|
||||
Result := Cardinal(Length(inbuf)) - ix;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Outbuf := '';
|
||||
Result := 0;
|
||||
end;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function SynaIconvClose(var cd: iconv_t): integer;
|
||||
begin
|
||||
if cd = iconv_t(-1) then
|
||||
begin
|
||||
Result := 0;
|
||||
Exit;
|
||||
end;
|
||||
{$IFDEF CIL}
|
||||
try;
|
||||
Result := _iconv_close(cd)
|
||||
except
|
||||
on Exception do
|
||||
Result := -1;
|
||||
end;
|
||||
cd := iconv_t(-1);
|
||||
{$ELSE}
|
||||
if InitIconvInterface and Assigned(_iconv_close) then
|
||||
Result := _iconv_close(cd)
|
||||
else
|
||||
Result := -1;
|
||||
cd := iconv_t(-1);
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer;
|
||||
begin
|
||||
{$IFDEF CIL}
|
||||
Result := _iconvctl(cd, request, argument)
|
||||
{$ELSE}
|
||||
if InitIconvInterface and Assigned(_iconvctl) then
|
||||
Result := _iconvctl(cd, request, argument)
|
||||
else
|
||||
Result := 0;
|
||||
{$ENDIF}
|
||||
end;
|
||||
|
||||
function InitIconvInterface: Boolean;
|
||||
begin
|
||||
IconvCS.Enter;
|
||||
try
|
||||
if not IsIconvloaded then
|
||||
begin
|
||||
{$IFDEF CIL}
|
||||
IconvLibHandle := 1;
|
||||
{$ELSE}
|
||||
IconvLibHandle := LoadLibrary(PChar(DLLIconvName));
|
||||
{$ENDIF}
|
||||
if (IconvLibHandle <> 0) then
|
||||
begin
|
||||
{$IFNDEF CIL}
|
||||
_iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open')));
|
||||
_iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv')));
|
||||
_iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close')));
|
||||
_iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl')));
|
||||
{$ENDIF}
|
||||
Result := True;
|
||||
Iconvloaded := True;
|
||||
end
|
||||
else
|
||||
begin
|
||||
//load failed!
|
||||
if IconvLibHandle <> 0 then
|
||||
begin
|
||||
{$IFNDEF CIL}
|
||||
FreeLibrary(IconvLibHandle);
|
||||
{$ENDIF}
|
||||
IconvLibHandle := 0;
|
||||
end;
|
||||
Result := False;
|
||||
end;
|
||||
end
|
||||
else
|
||||
//loaded before...
|
||||
Result := true;
|
||||
finally
|
||||
IconvCS.Leave;
|
||||
end;
|
||||
end;
|
||||
|
||||
function DestroyIconvInterface: Boolean;
|
||||
begin
|
||||
IconvCS.Enter;
|
||||
try
|
||||
Iconvloaded := false;
|
||||
if IconvLibHandle <> 0 then
|
||||
begin
|
||||
{$IFNDEF CIL}
|
||||
FreeLibrary(IconvLibHandle);
|
||||
{$ENDIF}
|
||||
IconvLibHandle := 0;
|
||||
end;
|
||||
{$IFNDEF CIL}
|
||||
_iconv_open := nil;
|
||||
_iconv := nil;
|
||||
_iconv_close := nil;
|
||||
_iconvctl := nil;
|
||||
{$ENDIF}
|
||||
finally
|
||||
IconvCS.Leave;
|
||||
end;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function IsIconvloaded: Boolean;
|
||||
begin
|
||||
Result := IconvLoaded;
|
||||
end;
|
||||
|
||||
initialization
|
||||
begin
|
||||
IconvCS:= TCriticalSection.Create;
|
||||
end;
|
||||
|
||||
finalization
|
||||
begin
|
||||
{$IFNDEF CIL}
|
||||
DestroyIconvInterface;
|
||||
{$ENDIF}
|
||||
IconvCS.Free;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
|
|
@ -1,422 +1,422 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.002.001 |
|
||||
|==============================================================================|
|
||||
| Content: IP address support procedures and functions |
|
||||
|==============================================================================|
|
||||
| Copyright (c)2006-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c) 2006-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(IP adress support procedures and functions)}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$R-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$WARN SUSPICIOUS_TYPECAST OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit synaip;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, SynaUtil;
|
||||
|
||||
type
|
||||
{:binary form of IPv6 adress (for string conversion routines)}
|
||||
TIp6Bytes = array [0..15] of Byte;
|
||||
{:binary form of IPv6 adress (for string conversion routines)}
|
||||
TIp6Words = array [0..7] of Word;
|
||||
|
||||
{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
|
||||
function IsIP(const Value: string): Boolean;
|
||||
|
||||
{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
|
||||
function IsIP6(const Value: string): Boolean;
|
||||
|
||||
{:Returns a string with the "Host" ip address converted to binary form.}
|
||||
function IPToID(Host: string): Ansistring;
|
||||
|
||||
{:Convert IPv6 address from their string form to binary byte array.}
|
||||
function StrToIp6(value: string): TIp6Bytes;
|
||||
|
||||
{:Convert IPv6 address from binary byte array to string form.}
|
||||
function Ip6ToStr(value: TIp6Bytes): string;
|
||||
|
||||
{:Convert IPv4 address from their string form to binary.}
|
||||
function StrToIp(value: string): integer;
|
||||
|
||||
{:Convert IPv4 address from binary to string form.}
|
||||
function IpToStr(value: integer): string;
|
||||
|
||||
{:Convert IPv4 address to reverse form.}
|
||||
function ReverseIP(Value: AnsiString): AnsiString;
|
||||
|
||||
{:Convert IPv6 address to reverse form.}
|
||||
function ReverseIP6(Value: AnsiString): AnsiString;
|
||||
|
||||
{:Expand short form of IPv6 address to long form.}
|
||||
function ExpandIP6(Value: AnsiString): AnsiString;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function IsIP(const Value: string): Boolean;
|
||||
var
|
||||
TempIP: string;
|
||||
function ByteIsOk(const Value: string): Boolean;
|
||||
var
|
||||
x, n: integer;
|
||||
begin
|
||||
x := StrToIntDef(Value, -1);
|
||||
Result := (x >= 0) and (x < 256);
|
||||
// X may be in correct range, but value still may not be correct value!
|
||||
// i.e. "$80"
|
||||
if Result then
|
||||
for n := 1 to length(Value) do
|
||||
if not (AnsiChar(Value[n]) in ['0'..'9']) then
|
||||
begin
|
||||
Result := False;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
begin
|
||||
TempIP := Value;
|
||||
Result := False;
|
||||
if not ByteIsOk(Fetch(TempIP, '.')) then
|
||||
Exit;
|
||||
if not ByteIsOk(Fetch(TempIP, '.')) then
|
||||
Exit;
|
||||
if not ByteIsOk(Fetch(TempIP, '.')) then
|
||||
Exit;
|
||||
if ByteIsOk(TempIP) then
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function IsIP6(const Value: string): Boolean;
|
||||
var
|
||||
TempIP: string;
|
||||
s,t: string;
|
||||
x: integer;
|
||||
partcount: integer;
|
||||
zerocount: integer;
|
||||
First: Boolean;
|
||||
begin
|
||||
TempIP := Value;
|
||||
Result := False;
|
||||
if Value = '::' then
|
||||
begin
|
||||
Result := True;
|
||||
Exit;
|
||||
end;
|
||||
partcount := 0;
|
||||
zerocount := 0;
|
||||
First := True;
|
||||
while tempIP <> '' do
|
||||
begin
|
||||
s := fetch(TempIP, ':');
|
||||
if not(First) and (s = '') then
|
||||
Inc(zerocount);
|
||||
First := False;
|
||||
if zerocount > 1 then
|
||||
break;
|
||||
Inc(partCount);
|
||||
if s = '' then
|
||||
Continue;
|
||||
if partCount > 8 then
|
||||
break;
|
||||
if tempIP = '' then
|
||||
begin
|
||||
t := SeparateRight(s, '%');
|
||||
s := SeparateLeft(s, '%');
|
||||
x := StrToIntDef('$' + t, -1);
|
||||
if (x < 0) or (x > $ffff) then
|
||||
break;
|
||||
end;
|
||||
x := StrToIntDef('$' + s, -1);
|
||||
if (x < 0) or (x > $ffff) then
|
||||
break;
|
||||
if tempIP = '' then
|
||||
if not((PartCount = 1) and (ZeroCount = 0)) then
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function IPToID(Host: string): Ansistring;
|
||||
var
|
||||
s: string;
|
||||
i, x: Integer;
|
||||
begin
|
||||
Result := '';
|
||||
for x := 0 to 3 do
|
||||
begin
|
||||
s := Fetch(Host, '.');
|
||||
i := StrToIntDef(s, 0);
|
||||
Result := Result + AnsiChar(i);
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function StrToIp(value: string): integer;
|
||||
var
|
||||
s: string;
|
||||
i, x: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
for x := 0 to 3 do
|
||||
begin
|
||||
s := Fetch(value, '.');
|
||||
i := StrToIntDef(s, 0);
|
||||
Result := (256 * Result) + i;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function IpToStr(value: integer): string;
|
||||
var
|
||||
x1, x2: word;
|
||||
y1, y2: byte;
|
||||
begin
|
||||
Result := '';
|
||||
x1 := value shr 16;
|
||||
x2 := value and $FFFF;
|
||||
y1 := x1 div $100;
|
||||
y2 := x1 mod $100;
|
||||
Result := inttostr(y1) + '.' + inttostr(y2) + '.';
|
||||
y1 := x2 div $100;
|
||||
y2 := x2 mod $100;
|
||||
Result := Result + inttostr(y1) + '.' + inttostr(y2);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function ExpandIP6(Value: AnsiString): AnsiString;
|
||||
var
|
||||
n: integer;
|
||||
s: ansistring;
|
||||
x: integer;
|
||||
begin
|
||||
Result := '';
|
||||
if value = '' then
|
||||
exit;
|
||||
x := countofchar(value, ':');
|
||||
if x > 7 then
|
||||
exit;
|
||||
if value[1] = ':' then
|
||||
value := '0' + value;
|
||||
if value[length(value)] = ':' then
|
||||
value := value + '0';
|
||||
x := 8 - x;
|
||||
s := '';
|
||||
for n := 1 to x do
|
||||
s := s + ':0';
|
||||
s := s + ':';
|
||||
Result := replacestring(value, '::', s);
|
||||
end;
|
||||
{==============================================================================}
|
||||
|
||||
function StrToIp6(Value: string): TIp6Bytes;
|
||||
var
|
||||
IPv6: TIp6Words;
|
||||
Index: Integer;
|
||||
n: integer;
|
||||
b1, b2: byte;
|
||||
s: string;
|
||||
x: integer;
|
||||
begin
|
||||
for n := 0 to 15 do
|
||||
Result[n] := 0;
|
||||
for n := 0 to 7 do
|
||||
Ipv6[n] := 0;
|
||||
Index := 0;
|
||||
Value := ExpandIP6(value);
|
||||
if value = '' then
|
||||
exit;
|
||||
while Value <> '' do
|
||||
begin
|
||||
if Index > 7 then
|
||||
Exit;
|
||||
s := fetch(value, ':');
|
||||
if s = '@' then
|
||||
break;
|
||||
if s = '' then
|
||||
begin
|
||||
IPv6[Index] := 0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
x := StrToIntDef('$' + s, -1);
|
||||
if (x > 65535) or (x < 0) then
|
||||
Exit;
|
||||
IPv6[Index] := x;
|
||||
end;
|
||||
Inc(Index);
|
||||
end;
|
||||
for n := 0 to 7 do
|
||||
begin
|
||||
b1 := ipv6[n] div 256;
|
||||
b2 := ipv6[n] mod 256;
|
||||
Result[n * 2] := b1;
|
||||
Result[(n * 2) + 1] := b2;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
//based on routine by the Free Pascal development team
|
||||
function Ip6ToStr(value: TIp6Bytes): string;
|
||||
var
|
||||
i, x: byte;
|
||||
zr1,zr2: set of byte;
|
||||
zc1,zc2: byte;
|
||||
have_skipped: boolean;
|
||||
ip6w: TIp6words;
|
||||
begin
|
||||
zr1 := [];
|
||||
zr2 := [];
|
||||
zc1 := 0;
|
||||
zc2 := 0;
|
||||
for i := 0 to 7 do
|
||||
begin
|
||||
x := i * 2;
|
||||
ip6w[i] := value[x] * 256 + value[x + 1];
|
||||
if ip6w[i] = 0 then
|
||||
begin
|
||||
include(zr2, i);
|
||||
inc(zc2);
|
||||
end
|
||||
else
|
||||
begin
|
||||
if zc1 < zc2 then
|
||||
begin
|
||||
zc1 := zc2;
|
||||
zr1 := zr2;
|
||||
zc2 := 0;
|
||||
zr2 := [];
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if zc1 < zc2 then
|
||||
begin
|
||||
zr1 := zr2;
|
||||
end;
|
||||
SetLength(Result, 8*5-1);
|
||||
SetLength(Result, 0);
|
||||
have_skipped := false;
|
||||
for i := 0 to 7 do
|
||||
begin
|
||||
if not(i in zr1) then
|
||||
begin
|
||||
if have_skipped then
|
||||
begin
|
||||
if Result = '' then
|
||||
Result := '::'
|
||||
else
|
||||
Result := Result + ':';
|
||||
have_skipped := false;
|
||||
end;
|
||||
Result := Result + IntToHex(Ip6w[i], 1) + ':';
|
||||
end
|
||||
else
|
||||
begin
|
||||
have_skipped := true;
|
||||
end;
|
||||
end;
|
||||
if have_skipped then
|
||||
if Result = '' then
|
||||
Result := '::0'
|
||||
else
|
||||
Result := Result + ':';
|
||||
|
||||
if Result = '' then
|
||||
Result := '::0';
|
||||
if not (7 in zr1) then
|
||||
SetLength(Result, Length(Result)-1);
|
||||
Result := LowerCase(result);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ReverseIP(Value: AnsiString): AnsiString;
|
||||
var
|
||||
x: Integer;
|
||||
begin
|
||||
Result := '';
|
||||
repeat
|
||||
x := LastDelimiter('.', Value);
|
||||
Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
|
||||
Delete(Value, x, Length(Value) - x + 1);
|
||||
until x < 1;
|
||||
if Length(Result) > 0 then
|
||||
if Result[1] = '.' then
|
||||
Delete(Result, 1, 1);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ReverseIP6(Value: AnsiString): AnsiString;
|
||||
var
|
||||
ip6: TIp6bytes;
|
||||
n: integer;
|
||||
x, y: integer;
|
||||
begin
|
||||
ip6 := StrToIP6(Value);
|
||||
x := ip6[15] div 16;
|
||||
y := ip6[15] mod 16;
|
||||
Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
|
||||
for n := 14 downto 0 do
|
||||
begin
|
||||
x := ip6[n] div 16;
|
||||
y := ip6[n] mod 16;
|
||||
Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.002.001 |
|
||||
|==============================================================================|
|
||||
| Content: IP address support procedures and functions |
|
||||
|==============================================================================|
|
||||
| Copyright (c)2006-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c) 2006-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(IP adress support procedures and functions)}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$R-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$WARN SUSPICIOUS_TYPECAST OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit synaip;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, SynaUtil;
|
||||
|
||||
type
|
||||
{:binary form of IPv6 adress (for string conversion routines)}
|
||||
TIp6Bytes = array [0..15] of Byte;
|
||||
{:binary form of IPv6 adress (for string conversion routines)}
|
||||
TIp6Words = array [0..7] of Word;
|
||||
|
||||
{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
|
||||
function IsIP(const Value: string): Boolean;
|
||||
|
||||
{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
|
||||
function IsIP6(const Value: string): Boolean;
|
||||
|
||||
{:Returns a string with the "Host" ip address converted to binary form.}
|
||||
function IPToID(Host: string): Ansistring;
|
||||
|
||||
{:Convert IPv6 address from their string form to binary byte array.}
|
||||
function StrToIp6(value: string): TIp6Bytes;
|
||||
|
||||
{:Convert IPv6 address from binary byte array to string form.}
|
||||
function Ip6ToStr(value: TIp6Bytes): string;
|
||||
|
||||
{:Convert IPv4 address from their string form to binary.}
|
||||
function StrToIp(value: string): integer;
|
||||
|
||||
{:Convert IPv4 address from binary to string form.}
|
||||
function IpToStr(value: integer): string;
|
||||
|
||||
{:Convert IPv4 address to reverse form.}
|
||||
function ReverseIP(Value: AnsiString): AnsiString;
|
||||
|
||||
{:Convert IPv6 address to reverse form.}
|
||||
function ReverseIP6(Value: AnsiString): AnsiString;
|
||||
|
||||
{:Expand short form of IPv6 address to long form.}
|
||||
function ExpandIP6(Value: AnsiString): AnsiString;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function IsIP(const Value: string): Boolean;
|
||||
var
|
||||
TempIP: string;
|
||||
function ByteIsOk(const Value: string): Boolean;
|
||||
var
|
||||
x, n: integer;
|
||||
begin
|
||||
x := StrToIntDef(Value, -1);
|
||||
Result := (x >= 0) and (x < 256);
|
||||
// X may be in correct range, but value still may not be correct value!
|
||||
// i.e. "$80"
|
||||
if Result then
|
||||
for n := 1 to length(Value) do
|
||||
if not (AnsiChar(Value[n]) in ['0'..'9']) then
|
||||
begin
|
||||
Result := False;
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
begin
|
||||
TempIP := Value;
|
||||
Result := False;
|
||||
if not ByteIsOk(Fetch(TempIP, '.')) then
|
||||
Exit;
|
||||
if not ByteIsOk(Fetch(TempIP, '.')) then
|
||||
Exit;
|
||||
if not ByteIsOk(Fetch(TempIP, '.')) then
|
||||
Exit;
|
||||
if ByteIsOk(TempIP) then
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function IsIP6(const Value: string): Boolean;
|
||||
var
|
||||
TempIP: string;
|
||||
s,t: string;
|
||||
x: integer;
|
||||
partcount: integer;
|
||||
zerocount: integer;
|
||||
First: Boolean;
|
||||
begin
|
||||
TempIP := Value;
|
||||
Result := False;
|
||||
if Value = '::' then
|
||||
begin
|
||||
Result := True;
|
||||
Exit;
|
||||
end;
|
||||
partcount := 0;
|
||||
zerocount := 0;
|
||||
First := True;
|
||||
while tempIP <> '' do
|
||||
begin
|
||||
s := fetch(TempIP, ':');
|
||||
if not(First) and (s = '') then
|
||||
Inc(zerocount);
|
||||
First := False;
|
||||
if zerocount > 1 then
|
||||
break;
|
||||
Inc(partCount);
|
||||
if s = '' then
|
||||
Continue;
|
||||
if partCount > 8 then
|
||||
break;
|
||||
if tempIP = '' then
|
||||
begin
|
||||
t := SeparateRight(s, '%');
|
||||
s := SeparateLeft(s, '%');
|
||||
x := StrToIntDef('$' + t, -1);
|
||||
if (x < 0) or (x > $ffff) then
|
||||
break;
|
||||
end;
|
||||
x := StrToIntDef('$' + s, -1);
|
||||
if (x < 0) or (x > $ffff) then
|
||||
break;
|
||||
if tempIP = '' then
|
||||
if not((PartCount = 1) and (ZeroCount = 0)) then
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function IPToID(Host: string): Ansistring;
|
||||
var
|
||||
s: string;
|
||||
i, x: Integer;
|
||||
begin
|
||||
Result := '';
|
||||
for x := 0 to 3 do
|
||||
begin
|
||||
s := Fetch(Host, '.');
|
||||
i := StrToIntDef(s, 0);
|
||||
Result := Result + AnsiChar(i);
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function StrToIp(value: string): integer;
|
||||
var
|
||||
s: string;
|
||||
i, x: Integer;
|
||||
begin
|
||||
Result := 0;
|
||||
for x := 0 to 3 do
|
||||
begin
|
||||
s := Fetch(value, '.');
|
||||
i := StrToIntDef(s, 0);
|
||||
Result := (256 * Result) + i;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function IpToStr(value: integer): string;
|
||||
var
|
||||
x1, x2: word;
|
||||
y1, y2: byte;
|
||||
begin
|
||||
Result := '';
|
||||
x1 := value shr 16;
|
||||
x2 := value and $FFFF;
|
||||
y1 := x1 div $100;
|
||||
y2 := x1 mod $100;
|
||||
Result := inttostr(y1) + '.' + inttostr(y2) + '.';
|
||||
y1 := x2 div $100;
|
||||
y2 := x2 mod $100;
|
||||
Result := Result + inttostr(y1) + '.' + inttostr(y2);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function ExpandIP6(Value: AnsiString): AnsiString;
|
||||
var
|
||||
n: integer;
|
||||
s: ansistring;
|
||||
x: integer;
|
||||
begin
|
||||
Result := '';
|
||||
if value = '' then
|
||||
exit;
|
||||
x := countofchar(value, ':');
|
||||
if x > 7 then
|
||||
exit;
|
||||
if value[1] = ':' then
|
||||
value := '0' + value;
|
||||
if value[length(value)] = ':' then
|
||||
value := value + '0';
|
||||
x := 8 - x;
|
||||
s := '';
|
||||
for n := 1 to x do
|
||||
s := s + ':0';
|
||||
s := s + ':';
|
||||
Result := replacestring(value, '::', s);
|
||||
end;
|
||||
{==============================================================================}
|
||||
|
||||
function StrToIp6(Value: string): TIp6Bytes;
|
||||
var
|
||||
IPv6: TIp6Words;
|
||||
Index: Integer;
|
||||
n: integer;
|
||||
b1, b2: byte;
|
||||
s: string;
|
||||
x: integer;
|
||||
begin
|
||||
for n := 0 to 15 do
|
||||
Result[n] := 0;
|
||||
for n := 0 to 7 do
|
||||
Ipv6[n] := 0;
|
||||
Index := 0;
|
||||
Value := ExpandIP6(value);
|
||||
if value = '' then
|
||||
exit;
|
||||
while Value <> '' do
|
||||
begin
|
||||
if Index > 7 then
|
||||
Exit;
|
||||
s := fetch(value, ':');
|
||||
if s = '@' then
|
||||
break;
|
||||
if s = '' then
|
||||
begin
|
||||
IPv6[Index] := 0;
|
||||
end
|
||||
else
|
||||
begin
|
||||
x := StrToIntDef('$' + s, -1);
|
||||
if (x > 65535) or (x < 0) then
|
||||
Exit;
|
||||
IPv6[Index] := x;
|
||||
end;
|
||||
Inc(Index);
|
||||
end;
|
||||
for n := 0 to 7 do
|
||||
begin
|
||||
b1 := ipv6[n] div 256;
|
||||
b2 := ipv6[n] mod 256;
|
||||
Result[n * 2] := b1;
|
||||
Result[(n * 2) + 1] := b2;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
//based on routine by the Free Pascal development team
|
||||
function Ip6ToStr(value: TIp6Bytes): string;
|
||||
var
|
||||
i, x: byte;
|
||||
zr1,zr2: set of byte;
|
||||
zc1,zc2: byte;
|
||||
have_skipped: boolean;
|
||||
ip6w: TIp6words;
|
||||
begin
|
||||
zr1 := [];
|
||||
zr2 := [];
|
||||
zc1 := 0;
|
||||
zc2 := 0;
|
||||
for i := 0 to 7 do
|
||||
begin
|
||||
x := i * 2;
|
||||
ip6w[i] := value[x] * 256 + value[x + 1];
|
||||
if ip6w[i] = 0 then
|
||||
begin
|
||||
include(zr2, i);
|
||||
inc(zc2);
|
||||
end
|
||||
else
|
||||
begin
|
||||
if zc1 < zc2 then
|
||||
begin
|
||||
zc1 := zc2;
|
||||
zr1 := zr2;
|
||||
zc2 := 0;
|
||||
zr2 := [];
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
if zc1 < zc2 then
|
||||
begin
|
||||
zr1 := zr2;
|
||||
end;
|
||||
SetLength(Result, 8*5-1);
|
||||
SetLength(Result, 0);
|
||||
have_skipped := false;
|
||||
for i := 0 to 7 do
|
||||
begin
|
||||
if not(i in zr1) then
|
||||
begin
|
||||
if have_skipped then
|
||||
begin
|
||||
if Result = '' then
|
||||
Result := '::'
|
||||
else
|
||||
Result := Result + ':';
|
||||
have_skipped := false;
|
||||
end;
|
||||
Result := Result + IntToHex(Ip6w[i], 1) + ':';
|
||||
end
|
||||
else
|
||||
begin
|
||||
have_skipped := true;
|
||||
end;
|
||||
end;
|
||||
if have_skipped then
|
||||
if Result = '' then
|
||||
Result := '::0'
|
||||
else
|
||||
Result := Result + ':';
|
||||
|
||||
if Result = '' then
|
||||
Result := '::0';
|
||||
if not (7 in zr1) then
|
||||
SetLength(Result, Length(Result)-1);
|
||||
Result := LowerCase(result);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ReverseIP(Value: AnsiString): AnsiString;
|
||||
var
|
||||
x: Integer;
|
||||
begin
|
||||
Result := '';
|
||||
repeat
|
||||
x := LastDelimiter('.', Value);
|
||||
Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
|
||||
Delete(Value, x, Length(Value) - x + 1);
|
||||
until x < 1;
|
||||
if Length(Result) > 0 then
|
||||
if Result[1] = '.' then
|
||||
Delete(Result, 1, 1);
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
function ReverseIP6(Value: AnsiString): AnsiString;
|
||||
var
|
||||
ip6: TIp6bytes;
|
||||
n: integer;
|
||||
x, y: integer;
|
||||
begin
|
||||
ip6 := StrToIP6(Value);
|
||||
x := ip6[15] div 16;
|
||||
y := ip6[15] mod 16;
|
||||
Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
|
||||
for n := 14 downto 0 do
|
||||
begin
|
||||
x := ip6[n] div 16;
|
||||
y := ip6[n] mod 16;
|
||||
Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
end.
|
||||
|
|
|
@ -1,394 +1,394 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.003.000 |
|
||||
|==============================================================================|
|
||||
| Content: misc. procedures and functions |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c) 2002-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(Misc. network based utilities)}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit synamisc;
|
||||
|
||||
interface
|
||||
|
||||
{$IFDEF VER125}
|
||||
{$DEFINE BCB}
|
||||
{$ENDIF}
|
||||
{$IFDEF BCB}
|
||||
{$ObjExportAll On}
|
||||
{$HPPEMIT '#pragma comment( lib , "wininet.lib" )'}
|
||||
{$ENDIF}
|
||||
|
||||
uses
|
||||
synautil, blcksock, SysUtils, Classes,
|
||||
{$IFDEF LINUX}
|
||||
Libc;
|
||||
{$ELSE}
|
||||
Windows;
|
||||
{$ENDIF}
|
||||
|
||||
Type
|
||||
{:@abstract(This record contains information about proxy setting.)}
|
||||
TProxySetting = record
|
||||
Host: string;
|
||||
Port: string;
|
||||
Bypass: string;
|
||||
end;
|
||||
|
||||
{:By this function you can turn-on computer on network, if this computer
|
||||
supporting Wake-on-lan feature. You need MAC number (network card indentifier)
|
||||
of computer for turn-on. You can also assign target IP addres. If you not
|
||||
specify it, then is used broadcast for delivery magic wake-on packet. However
|
||||
broadcasts workinh only on your local network. When you need to wake-up
|
||||
computer on another network, you must specify any existing IP addres on same
|
||||
network segment as targeting computer.}
|
||||
procedure WakeOnLan(MAC, IP: string);
|
||||
|
||||
{:Autodetect current DNS servers used by system. If is defined more then one DNS
|
||||
server, then result is comma-delimited.}
|
||||
function GetDNS: string;
|
||||
|
||||
{:Autodetect InternetExplorer proxy setting for given protocol. This function
|
||||
working only on windows!}
|
||||
function GetIEProxy(protocol: string): TProxySetting;
|
||||
|
||||
{:Return all known IP addresses on local system. Addresses are divided by comma.}
|
||||
function GetLocalIPs: string;
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
procedure WakeOnLan(MAC, IP: string);
|
||||
var
|
||||
sock: TUDPBlockSocket;
|
||||
HexMac: Ansistring;
|
||||
data: Ansistring;
|
||||
n: integer;
|
||||
b: Byte;
|
||||
begin
|
||||
if MAC <> '' then
|
||||
begin
|
||||
MAC := ReplaceString(MAC, '-', '');
|
||||
MAC := ReplaceString(MAC, ':', '');
|
||||
if Length(MAC) < 12 then
|
||||
Exit;
|
||||
HexMac := '';
|
||||
for n := 0 to 5 do
|
||||
begin
|
||||
b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0);
|
||||
HexMac := HexMac + char(b);
|
||||
end;
|
||||
if IP = '' then
|
||||
IP := cBroadcast;
|
||||
sock := TUDPBlockSocket.Create;
|
||||
try
|
||||
sock.CreateSocket;
|
||||
sock.EnableBroadcast(true);
|
||||
sock.Connect(IP, '9');
|
||||
data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF;
|
||||
for n := 1 to 16 do
|
||||
data := data + HexMac;
|
||||
sock.SendString(data);
|
||||
finally
|
||||
sock.Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
{$IFNDEF LINUX}
|
||||
function GetDNSbyIpHlp: string;
|
||||
type
|
||||
PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING;
|
||||
TIP_ADDRESS_STRING = array[0..15] of Ansichar;
|
||||
PTIP_ADDR_STRING = ^TIP_ADDR_STRING;
|
||||
TIP_ADDR_STRING = packed record
|
||||
Next: PTIP_ADDR_STRING;
|
||||
IpAddress: TIP_ADDRESS_STRING;
|
||||
IpMask: TIP_ADDRESS_STRING;
|
||||
Context: DWORD;
|
||||
end;
|
||||
PTFixedInfo = ^TFixedInfo;
|
||||
TFixedInfo = packed record
|
||||
HostName: array[1..128 + 4] of Ansichar;
|
||||
DomainName: array[1..128 + 4] of Ansichar;
|
||||
CurrentDNSServer: PTIP_ADDR_STRING;
|
||||
DNSServerList: TIP_ADDR_STRING;
|
||||
NodeType: UINT;
|
||||
ScopeID: array[1..256 + 4] of Ansichar;
|
||||
EnableRouting: UINT;
|
||||
EnableProxy: UINT;
|
||||
EnableDNS: UINT;
|
||||
end;
|
||||
const
|
||||
IpHlpDLL = 'IPHLPAPI.DLL';
|
||||
var
|
||||
IpHlpModule: THandle;
|
||||
FixedInfo: PTFixedInfo;
|
||||
InfoSize: Longint;
|
||||
PDnsServer: PTIP_ADDR_STRING;
|
||||
err: integer;
|
||||
GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall;
|
||||
begin
|
||||
InfoSize := 0;
|
||||
Result := '...';
|
||||
IpHlpModule := LoadLibrary(IpHlpDLL);
|
||||
if IpHlpModule = 0 then
|
||||
exit;
|
||||
try
|
||||
GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams')));
|
||||
if @GetNetworkParams = nil then
|
||||
Exit;
|
||||
err := GetNetworkParams(Nil, @InfoSize);
|
||||
if err <> ERROR_BUFFER_OVERFLOW then
|
||||
Exit;
|
||||
Result := '';
|
||||
GetMem (FixedInfo, InfoSize);
|
||||
try
|
||||
err := GetNetworkParams(FixedInfo, @InfoSize);
|
||||
if err <> ERROR_SUCCESS then
|
||||
exit;
|
||||
with FixedInfo^ do
|
||||
begin
|
||||
Result := DnsServerList.IpAddress;
|
||||
PDnsServer := DnsServerList.Next;
|
||||
while PDnsServer <> Nil do
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ',';
|
||||
Result := Result + PDnsServer^.IPAddress;
|
||||
PDnsServer := PDnsServer.Next;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
FreeMem(FixedInfo);
|
||||
end;
|
||||
finally
|
||||
FreeLibrary(IpHlpModule);
|
||||
end;
|
||||
end;
|
||||
|
||||
function ReadReg(SubKey, Vn: PChar): string;
|
||||
var
|
||||
OpenKey: HKEY;
|
||||
DataType, DataSize: integer;
|
||||
Temp: array [0..2048] of char;
|
||||
begin
|
||||
Result := '';
|
||||
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE,
|
||||
KEY_READ, OpenKey) = ERROR_SUCCESS then
|
||||
begin
|
||||
DataType := REG_SZ;
|
||||
DataSize := SizeOf(Temp);
|
||||
if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then
|
||||
SetString(Result, Temp, DataSize div SizeOf(Char) - 1);
|
||||
RegCloseKey(OpenKey);
|
||||
end;
|
||||
end ;
|
||||
{$ENDIF}
|
||||
|
||||
function GetDNS: string;
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
l: TStringList;
|
||||
n: integer;
|
||||
begin
|
||||
Result := '';
|
||||
l := TStringList.Create;
|
||||
try
|
||||
l.LoadFromFile('/etc/resolv.conf');
|
||||
for n := 0 to l.Count - 1 do
|
||||
if Pos('NAMESERVER', uppercase(l[n])) = 1 then
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ',';
|
||||
Result := Result + SeparateRight(l[n], ' ');
|
||||
end;
|
||||
finally
|
||||
l.Free;
|
||||
end;
|
||||
end;
|
||||
{$ELSE}
|
||||
const
|
||||
NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary';
|
||||
NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters';
|
||||
W9xfix = 'System\CurrentControlSet\Services\MSTCP';
|
||||
begin
|
||||
Result := GetDNSbyIpHlp;
|
||||
if Result = '...' then
|
||||
begin
|
||||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||||
begin
|
||||
Result := ReadReg(NTdyn, 'NameServer');
|
||||
if result = '' then
|
||||
Result := ReadReg(NTfix, 'NameServer');
|
||||
if result = '' then
|
||||
Result := ReadReg(NTfix, 'DhcpNameServer');
|
||||
end
|
||||
else
|
||||
Result := ReadReg(W9xfix, 'NameServer');
|
||||
Result := ReplaceString(trim(Result), ' ', ',');
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function GetIEProxy(protocol: string): TProxySetting;
|
||||
{$IFDEF LINUX}
|
||||
begin
|
||||
Result.Host := '';
|
||||
Result.Port := '';
|
||||
Result.Bypass := '';
|
||||
end;
|
||||
{$ELSE}
|
||||
type
|
||||
PInternetProxyInfo = ^TInternetProxyInfo;
|
||||
TInternetProxyInfo = packed record
|
||||
dwAccessType: DWORD;
|
||||
lpszProxy: LPCSTR;
|
||||
lpszProxyBypass: LPCSTR;
|
||||
end;
|
||||
const
|
||||
INTERNET_OPTION_PROXY = 38;
|
||||
INTERNET_OPEN_TYPE_PROXY = 3;
|
||||
WininetDLL = 'WININET.DLL';
|
||||
var
|
||||
WininetModule: THandle;
|
||||
ProxyInfo: PInternetProxyInfo;
|
||||
Err: Boolean;
|
||||
Len: DWORD;
|
||||
Proxy: string;
|
||||
DefProxy: string;
|
||||
ProxyList: TStringList;
|
||||
n: integer;
|
||||
InternetQueryOption: function (hInet: Pointer; dwOption: DWORD;
|
||||
lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall;
|
||||
begin
|
||||
Result.Host := '';
|
||||
Result.Port := '';
|
||||
Result.Bypass := '';
|
||||
WininetModule := LoadLibrary(WininetDLL);
|
||||
if WininetModule = 0 then
|
||||
exit;
|
||||
try
|
||||
InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA')));
|
||||
if @InternetQueryOption = nil then
|
||||
Exit;
|
||||
|
||||
if protocol = '' then
|
||||
protocol := 'http';
|
||||
Len := 4096;
|
||||
GetMem(ProxyInfo, Len);
|
||||
ProxyList := TStringList.Create;
|
||||
try
|
||||
Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
|
||||
if Err then
|
||||
if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
|
||||
begin
|
||||
ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
|
||||
Proxy := '';
|
||||
DefProxy := '';
|
||||
for n := 0 to ProxyList.Count -1 do
|
||||
begin
|
||||
if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then
|
||||
begin
|
||||
Proxy := SeparateRight(ProxyList[n], '=');
|
||||
break;
|
||||
end;
|
||||
if Pos('=', ProxyList[n]) < 1 then
|
||||
DefProxy := ProxyList[n];
|
||||
end;
|
||||
if Proxy = '' then
|
||||
Proxy := DefProxy;
|
||||
if Proxy <> '' then
|
||||
begin
|
||||
Result.Host := Trim(SeparateLeft(Proxy, ':'));
|
||||
Result.Port := Trim(SeparateRight(Proxy, ':'));
|
||||
end;
|
||||
Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
|
||||
end;
|
||||
finally
|
||||
ProxyList.Free;
|
||||
FreeMem(ProxyInfo);
|
||||
end;
|
||||
finally
|
||||
FreeLibrary(WininetModule);
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function GetLocalIPs: string;
|
||||
var
|
||||
TcpSock: TTCPBlockSocket;
|
||||
ipList: TStringList;
|
||||
begin
|
||||
Result := '';
|
||||
ipList := TStringList.Create;
|
||||
try
|
||||
TcpSock := TTCPBlockSocket.create;
|
||||
try
|
||||
TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
|
||||
Result := ipList.CommaText;
|
||||
finally
|
||||
TcpSock.Free;
|
||||
end;
|
||||
finally
|
||||
ipList.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.003.000 |
|
||||
|==============================================================================|
|
||||
| Content: misc. procedures and functions |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c) 2002-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(Misc. network based utilities)}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$Q-}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit synamisc;
|
||||
|
||||
interface
|
||||
|
||||
{$IFDEF VER125}
|
||||
{$DEFINE BCB}
|
||||
{$ENDIF}
|
||||
{$IFDEF BCB}
|
||||
{$ObjExportAll On}
|
||||
{$HPPEMIT '#pragma comment( lib , "wininet.lib" )'}
|
||||
{$ENDIF}
|
||||
|
||||
uses
|
||||
synautil, blcksock, SysUtils, Classes,
|
||||
{$IFDEF LINUX}
|
||||
Libc;
|
||||
{$ELSE}
|
||||
Windows;
|
||||
{$ENDIF}
|
||||
|
||||
Type
|
||||
{:@abstract(This record contains information about proxy setting.)}
|
||||
TProxySetting = record
|
||||
Host: string;
|
||||
Port: string;
|
||||
Bypass: string;
|
||||
end;
|
||||
|
||||
{:By this function you can turn-on computer on network, if this computer
|
||||
supporting Wake-on-lan feature. You need MAC number (network card indentifier)
|
||||
of computer for turn-on. You can also assign target IP addres. If you not
|
||||
specify it, then is used broadcast for delivery magic wake-on packet. However
|
||||
broadcasts workinh only on your local network. When you need to wake-up
|
||||
computer on another network, you must specify any existing IP addres on same
|
||||
network segment as targeting computer.}
|
||||
procedure WakeOnLan(MAC, IP: string);
|
||||
|
||||
{:Autodetect current DNS servers used by system. If is defined more then one DNS
|
||||
server, then result is comma-delimited.}
|
||||
function GetDNS: string;
|
||||
|
||||
{:Autodetect InternetExplorer proxy setting for given protocol. This function
|
||||
working only on windows!}
|
||||
function GetIEProxy(protocol: string): TProxySetting;
|
||||
|
||||
{:Return all known IP addresses on local system. Addresses are divided by comma.}
|
||||
function GetLocalIPs: string;
|
||||
|
||||
implementation
|
||||
|
||||
{==============================================================================}
|
||||
procedure WakeOnLan(MAC, IP: string);
|
||||
var
|
||||
sock: TUDPBlockSocket;
|
||||
HexMac: Ansistring;
|
||||
data: Ansistring;
|
||||
n: integer;
|
||||
b: Byte;
|
||||
begin
|
||||
if MAC <> '' then
|
||||
begin
|
||||
MAC := ReplaceString(MAC, '-', '');
|
||||
MAC := ReplaceString(MAC, ':', '');
|
||||
if Length(MAC) < 12 then
|
||||
Exit;
|
||||
HexMac := '';
|
||||
for n := 0 to 5 do
|
||||
begin
|
||||
b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0);
|
||||
HexMac := HexMac + char(b);
|
||||
end;
|
||||
if IP = '' then
|
||||
IP := cBroadcast;
|
||||
sock := TUDPBlockSocket.Create;
|
||||
try
|
||||
sock.CreateSocket;
|
||||
sock.EnableBroadcast(true);
|
||||
sock.Connect(IP, '9');
|
||||
data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF;
|
||||
for n := 1 to 16 do
|
||||
data := data + HexMac;
|
||||
sock.SendString(data);
|
||||
finally
|
||||
sock.Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
{$IFNDEF LINUX}
|
||||
function GetDNSbyIpHlp: string;
|
||||
type
|
||||
PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING;
|
||||
TIP_ADDRESS_STRING = array[0..15] of Ansichar;
|
||||
PTIP_ADDR_STRING = ^TIP_ADDR_STRING;
|
||||
TIP_ADDR_STRING = packed record
|
||||
Next: PTIP_ADDR_STRING;
|
||||
IpAddress: TIP_ADDRESS_STRING;
|
||||
IpMask: TIP_ADDRESS_STRING;
|
||||
Context: DWORD;
|
||||
end;
|
||||
PTFixedInfo = ^TFixedInfo;
|
||||
TFixedInfo = packed record
|
||||
HostName: array[1..128 + 4] of Ansichar;
|
||||
DomainName: array[1..128 + 4] of Ansichar;
|
||||
CurrentDNSServer: PTIP_ADDR_STRING;
|
||||
DNSServerList: TIP_ADDR_STRING;
|
||||
NodeType: UINT;
|
||||
ScopeID: array[1..256 + 4] of Ansichar;
|
||||
EnableRouting: UINT;
|
||||
EnableProxy: UINT;
|
||||
EnableDNS: UINT;
|
||||
end;
|
||||
const
|
||||
IpHlpDLL = 'IPHLPAPI.DLL';
|
||||
var
|
||||
IpHlpModule: THandle;
|
||||
FixedInfo: PTFixedInfo;
|
||||
InfoSize: Longint;
|
||||
PDnsServer: PTIP_ADDR_STRING;
|
||||
err: integer;
|
||||
GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall;
|
||||
begin
|
||||
InfoSize := 0;
|
||||
Result := '...';
|
||||
IpHlpModule := LoadLibrary(IpHlpDLL);
|
||||
if IpHlpModule = 0 then
|
||||
exit;
|
||||
try
|
||||
GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams')));
|
||||
if @GetNetworkParams = nil then
|
||||
Exit;
|
||||
err := GetNetworkParams(Nil, @InfoSize);
|
||||
if err <> ERROR_BUFFER_OVERFLOW then
|
||||
Exit;
|
||||
Result := '';
|
||||
GetMem (FixedInfo, InfoSize);
|
||||
try
|
||||
err := GetNetworkParams(FixedInfo, @InfoSize);
|
||||
if err <> ERROR_SUCCESS then
|
||||
exit;
|
||||
with FixedInfo^ do
|
||||
begin
|
||||
Result := DnsServerList.IpAddress;
|
||||
PDnsServer := DnsServerList.Next;
|
||||
while PDnsServer <> Nil do
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ',';
|
||||
Result := Result + PDnsServer^.IPAddress;
|
||||
PDnsServer := PDnsServer.Next;
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
FreeMem(FixedInfo);
|
||||
end;
|
||||
finally
|
||||
FreeLibrary(IpHlpModule);
|
||||
end;
|
||||
end;
|
||||
|
||||
function ReadReg(SubKey, Vn: PChar): string;
|
||||
var
|
||||
OpenKey: HKEY;
|
||||
DataType, DataSize: integer;
|
||||
Temp: array [0..2048] of char;
|
||||
begin
|
||||
Result := '';
|
||||
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE,
|
||||
KEY_READ, OpenKey) = ERROR_SUCCESS then
|
||||
begin
|
||||
DataType := REG_SZ;
|
||||
DataSize := SizeOf(Temp);
|
||||
if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then
|
||||
SetString(Result, Temp, DataSize div SizeOf(Char) - 1);
|
||||
RegCloseKey(OpenKey);
|
||||
end;
|
||||
end ;
|
||||
{$ENDIF}
|
||||
|
||||
function GetDNS: string;
|
||||
{$IFDEF LINUX}
|
||||
var
|
||||
l: TStringList;
|
||||
n: integer;
|
||||
begin
|
||||
Result := '';
|
||||
l := TStringList.Create;
|
||||
try
|
||||
l.LoadFromFile('/etc/resolv.conf');
|
||||
for n := 0 to l.Count - 1 do
|
||||
if Pos('NAMESERVER', uppercase(l[n])) = 1 then
|
||||
begin
|
||||
if Result <> '' then
|
||||
Result := Result + ',';
|
||||
Result := Result + SeparateRight(l[n], ' ');
|
||||
end;
|
||||
finally
|
||||
l.Free;
|
||||
end;
|
||||
end;
|
||||
{$ELSE}
|
||||
const
|
||||
NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary';
|
||||
NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters';
|
||||
W9xfix = 'System\CurrentControlSet\Services\MSTCP';
|
||||
begin
|
||||
Result := GetDNSbyIpHlp;
|
||||
if Result = '...' then
|
||||
begin
|
||||
if Win32Platform = VER_PLATFORM_WIN32_NT then
|
||||
begin
|
||||
Result := ReadReg(NTdyn, 'NameServer');
|
||||
if result = '' then
|
||||
Result := ReadReg(NTfix, 'NameServer');
|
||||
if result = '' then
|
||||
Result := ReadReg(NTfix, 'DhcpNameServer');
|
||||
end
|
||||
else
|
||||
Result := ReadReg(W9xfix, 'NameServer');
|
||||
Result := ReplaceString(trim(Result), ' ', ',');
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function GetIEProxy(protocol: string): TProxySetting;
|
||||
{$IFDEF LINUX}
|
||||
begin
|
||||
Result.Host := '';
|
||||
Result.Port := '';
|
||||
Result.Bypass := '';
|
||||
end;
|
||||
{$ELSE}
|
||||
type
|
||||
PInternetProxyInfo = ^TInternetProxyInfo;
|
||||
TInternetProxyInfo = packed record
|
||||
dwAccessType: DWORD;
|
||||
lpszProxy: LPCSTR;
|
||||
lpszProxyBypass: LPCSTR;
|
||||
end;
|
||||
const
|
||||
INTERNET_OPTION_PROXY = 38;
|
||||
INTERNET_OPEN_TYPE_PROXY = 3;
|
||||
WininetDLL = 'WININET.DLL';
|
||||
var
|
||||
WininetModule: THandle;
|
||||
ProxyInfo: PInternetProxyInfo;
|
||||
Err: Boolean;
|
||||
Len: DWORD;
|
||||
Proxy: string;
|
||||
DefProxy: string;
|
||||
ProxyList: TStringList;
|
||||
n: integer;
|
||||
InternetQueryOption: function (hInet: Pointer; dwOption: DWORD;
|
||||
lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall;
|
||||
begin
|
||||
Result.Host := '';
|
||||
Result.Port := '';
|
||||
Result.Bypass := '';
|
||||
WininetModule := LoadLibrary(WininetDLL);
|
||||
if WininetModule = 0 then
|
||||
exit;
|
||||
try
|
||||
InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA')));
|
||||
if @InternetQueryOption = nil then
|
||||
Exit;
|
||||
|
||||
if protocol = '' then
|
||||
protocol := 'http';
|
||||
Len := 4096;
|
||||
GetMem(ProxyInfo, Len);
|
||||
ProxyList := TStringList.Create;
|
||||
try
|
||||
Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
|
||||
if Err then
|
||||
if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
|
||||
begin
|
||||
ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
|
||||
Proxy := '';
|
||||
DefProxy := '';
|
||||
for n := 0 to ProxyList.Count -1 do
|
||||
begin
|
||||
if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then
|
||||
begin
|
||||
Proxy := SeparateRight(ProxyList[n], '=');
|
||||
break;
|
||||
end;
|
||||
if Pos('=', ProxyList[n]) < 1 then
|
||||
DefProxy := ProxyList[n];
|
||||
end;
|
||||
if Proxy = '' then
|
||||
Proxy := DefProxy;
|
||||
if Proxy <> '' then
|
||||
begin
|
||||
Result.Host := Trim(SeparateLeft(Proxy, ':'));
|
||||
Result.Port := Trim(SeparateRight(Proxy, ':'));
|
||||
end;
|
||||
Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
|
||||
end;
|
||||
finally
|
||||
ProxyList.Free;
|
||||
FreeMem(ProxyInfo);
|
||||
end;
|
||||
finally
|
||||
FreeLibrary(WininetModule);
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
function GetLocalIPs: string;
|
||||
var
|
||||
TcpSock: TTCPBlockSocket;
|
||||
ipList: TStringList;
|
||||
begin
|
||||
Result := '';
|
||||
ipList := TStringList.Create;
|
||||
try
|
||||
TcpSock := TTCPBlockSocket.create;
|
||||
try
|
||||
TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
|
||||
Result := ipList.CommaText;
|
||||
finally
|
||||
TcpSock.Free;
|
||||
end;
|
||||
finally
|
||||
ipList.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{==============================================================================}
|
||||
|
||||
end.
|
||||
|
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -1,77 +1,77 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 005.002.000 |
|
||||
|==============================================================================|
|
||||
| Content: Socket Independent Platform Layer |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2001-20010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@exclude}
|
||||
|
||||
unit synsock;
|
||||
|
||||
{$MINENUMSIZE 4}
|
||||
|
||||
//old Delphi does not have MSWINDOWS define.
|
||||
{$IFDEF WIN32}
|
||||
{$IFNDEF MSWINDOWS}
|
||||
{$DEFINE MSWINDOWS}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF CIL}
|
||||
{$I ssdotnet.pas}
|
||||
{$ELSE}
|
||||
{$IFDEF MSWINDOWS}
|
||||
{$I sswin32.pas}
|
||||
{$ELSE}
|
||||
{$IFDEF WINCE}
|
||||
{$I sswin32.pas} //not complete yet!
|
||||
{$ELSE}
|
||||
{$IFDEF FPC}
|
||||
{$I ssfpc.pas}
|
||||
{$ELSE}
|
||||
{$I sslinux.pas}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
end.
|
||||
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 005.002.000 |
|
||||
|==============================================================================|
|
||||
| Content: Socket Independent Platform Layer |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2001-20010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@exclude}
|
||||
|
||||
unit synsock;
|
||||
|
||||
{$MINENUMSIZE 4}
|
||||
|
||||
//old Delphi does not have MSWINDOWS define.
|
||||
{$IFDEF WIN32}
|
||||
{$IFNDEF MSWINDOWS}
|
||||
{$DEFINE MSWINDOWS}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
{$IFDEF CIL}
|
||||
{$I ssdotnet.pas}
|
||||
{$ELSE}
|
||||
{$IFDEF MSWINDOWS}
|
||||
{$I sswin32.pas}
|
||||
{$ELSE}
|
||||
{$IFDEF WINCE}
|
||||
{$I sswin32.pas} //not complete yet!
|
||||
{$ELSE}
|
||||
{$IFDEF FPC}
|
||||
{$I ssfpc.pas}
|
||||
{$ELSE}
|
||||
{$I sslinux.pas}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
{$ENDIF}
|
||||
|
||||
end.
|
||||
|
||||
|
|
|
@ -1,364 +1,364 @@
|
|||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.003.001 |
|
||||
|==============================================================================|
|
||||
| Content: TELNET and SSH2 client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2002-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(Telnet script client)
|
||||
|
||||
Used RFC: RFC-854
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit tlntsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cTelnetProtocol = '23';
|
||||
cSSHProtocol = '22';
|
||||
|
||||
TLNT_EOR = #239;
|
||||
TLNT_SE = #240;
|
||||
TLNT_NOP = #241;
|
||||
TLNT_DATA_MARK = #242;
|
||||
TLNT_BREAK = #243;
|
||||
TLNT_IP = #244;
|
||||
TLNT_AO = #245;
|
||||
TLNT_AYT = #246;
|
||||
TLNT_EC = #247;
|
||||
TLNT_EL = #248;
|
||||
TLNT_GA = #249;
|
||||
TLNT_SB = #250;
|
||||
TLNT_WILL = #251;
|
||||
TLNT_WONT = #252;
|
||||
TLNT_DO = #253;
|
||||
TLNT_DONT = #254;
|
||||
TLNT_IAC = #255;
|
||||
|
||||
type
|
||||
{:@abstract(State of telnet protocol). Used internaly by TTelnetSend.}
|
||||
TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
|
||||
tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
|
||||
|
||||
{:@abstract(Class with implementation of Telnet/SSH script client.)
|
||||
|
||||
Note: Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TTelnetSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TTCPBlockSocket;
|
||||
FBuffer: Ansistring;
|
||||
FState: TTelnetState;
|
||||
FSessionLog: Ansistring;
|
||||
FSubNeg: Ansistring;
|
||||
FSubType: Ansichar;
|
||||
FTermType: Ansistring;
|
||||
function Connect: Boolean;
|
||||
function Negotiate(const Buf: Ansistring): Ansistring;
|
||||
procedure FilterHook(Sender: TObject; var Value: AnsiString);
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Connects to Telnet server.}
|
||||
function Login: Boolean;
|
||||
|
||||
{:Connects to SSH2 server and login by Username and Password properties.
|
||||
|
||||
You must use some of SSL plugins with SSH support. For exammple CryptLib.}
|
||||
function SSHLogin: Boolean;
|
||||
|
||||
{:Logout from telnet server.}
|
||||
procedure Logout;
|
||||
|
||||
{:Send this data to telnet server.}
|
||||
procedure Send(const Value: string);
|
||||
|
||||
{:Reading data from telnet server until Value is readed. If it is not readed
|
||||
until timeout, result is @false. Otherwise result is @true.}
|
||||
function WaitFor(const Value: string): Boolean;
|
||||
|
||||
{:Read data terminated by terminator from telnet server.}
|
||||
function RecvTerminated(const Terminator: string): string;
|
||||
|
||||
{:Read string from telnet server.}
|
||||
function RecvString: string;
|
||||
published
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
|
||||
{:all readed datas in this session (from connect) is stored in this large
|
||||
string.}
|
||||
property SessionLog: Ansistring read FSessionLog write FSessionLog;
|
||||
|
||||
{:Terminal type indentification. By default is 'SYNAPSE'.}
|
||||
property TermType: Ansistring read FTermType write FTermType;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TTelnetSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FSock.OnReadFilter := FilterHook;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cTelnetProtocol;
|
||||
FSubNeg := '';
|
||||
FSubType := #0;
|
||||
FTermType := 'SYNAPSE';
|
||||
end;
|
||||
|
||||
destructor TTelnetSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TTelnetSend.Connect: Boolean;
|
||||
begin
|
||||
// Do not call this function! It is calling by LOGIN method!
|
||||
FBuffer := '';
|
||||
FSessionLog := '';
|
||||
FState := tsDATA;
|
||||
FSock.CloseSocket;
|
||||
FSock.LineBuffer := '';
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TTelnetSend.RecvTerminated(const Terminator: string): string;
|
||||
begin
|
||||
Result := FSock.RecvTerminated(FTimeout, Terminator);
|
||||
end;
|
||||
|
||||
function TTelnetSend.RecvString: string;
|
||||
begin
|
||||
Result := FSock.RecvTerminated(FTimeout, CRLF);
|
||||
end;
|
||||
|
||||
function TTelnetSend.WaitFor(const Value: string): Boolean;
|
||||
begin
|
||||
Result := FSock.RecvTerminated(FTimeout, Value) <> '';
|
||||
end;
|
||||
|
||||
procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString);
|
||||
begin
|
||||
Value := Negotiate(Value);
|
||||
FSessionLog := FSessionLog + Value;
|
||||
end;
|
||||
|
||||
function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring;
|
||||
var
|
||||
n: integer;
|
||||
c: Ansichar;
|
||||
Reply: Ansistring;
|
||||
SubReply: Ansistring;
|
||||
begin
|
||||
Result := '';
|
||||
for n := 1 to Length(Buf) do
|
||||
begin
|
||||
c := Buf[n];
|
||||
Reply := '';
|
||||
case FState of
|
||||
tsData:
|
||||
if c = TLNT_IAC then
|
||||
FState := tsIAC
|
||||
else
|
||||
Result := Result + c;
|
||||
|
||||
tsIAC:
|
||||
case c of
|
||||
TLNT_IAC:
|
||||
begin
|
||||
FState := tsData;
|
||||
Result := Result + TLNT_IAC;
|
||||
end;
|
||||
TLNT_WILL:
|
||||
FState := tsIAC_WILL;
|
||||
TLNT_WONT:
|
||||
FState := tsIAC_WONT;
|
||||
TLNT_DONT:
|
||||
FState := tsIAC_DONT;
|
||||
TLNT_DO:
|
||||
FState := tsIAC_DO;
|
||||
TLNT_EOR:
|
||||
FState := tsDATA;
|
||||
TLNT_SB:
|
||||
begin
|
||||
FState := tsIAC_SB;
|
||||
FSubType := #0;
|
||||
FSubNeg := '';
|
||||
end;
|
||||
else
|
||||
FState := tsData;
|
||||
end;
|
||||
|
||||
tsIAC_WILL:
|
||||
begin
|
||||
case c of
|
||||
#3: //suppress GA
|
||||
Reply := TLNT_DO;
|
||||
else
|
||||
Reply := TLNT_DONT;
|
||||
end;
|
||||
FState := tsData;
|
||||
end;
|
||||
|
||||
tsIAC_WONT:
|
||||
begin
|
||||
Reply := TLNT_DONT;
|
||||
FState := tsData;
|
||||
end;
|
||||
|
||||
tsIAC_DO:
|
||||
begin
|
||||
case c of
|
||||
#24: //termtype
|
||||
Reply := TLNT_WILL;
|
||||
else
|
||||
Reply := TLNT_WONT;
|
||||
end;
|
||||
FState := tsData;
|
||||
end;
|
||||
|
||||
tsIAC_DONT:
|
||||
begin
|
||||
Reply := TLNT_WONT;
|
||||
FState := tsData;
|
||||
end;
|
||||
|
||||
tsIAC_SB:
|
||||
begin
|
||||
FSubType := c;
|
||||
FState := tsIAC_SBDATA;
|
||||
end;
|
||||
|
||||
tsIAC_SBDATA:
|
||||
begin
|
||||
if c = TLNT_IAC then
|
||||
FState := tsSBDATA_IAC
|
||||
else
|
||||
FSubNeg := FSubNeg + c;
|
||||
end;
|
||||
|
||||
tsSBDATA_IAC:
|
||||
case c of
|
||||
TLNT_IAC:
|
||||
begin
|
||||
FState := tsIAC_SBDATA;
|
||||
FSubNeg := FSubNeg + c;
|
||||
end;
|
||||
TLNT_SE:
|
||||
begin
|
||||
SubReply := '';
|
||||
case FSubType of
|
||||
#24: //termtype
|
||||
begin
|
||||
if (FSubNeg <> '') and (FSubNeg[1] = #1) then
|
||||
SubReply := #0 + FTermType;
|
||||
end;
|
||||
end;
|
||||
Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE);
|
||||
FState := tsDATA;
|
||||
end;
|
||||
else
|
||||
FState := tsDATA;
|
||||
end;
|
||||
|
||||
else
|
||||
FState := tsData;
|
||||
end;
|
||||
if Reply <> '' then
|
||||
Sock.SendString(TLNT_IAC + Reply + c);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure TTelnetSend.Send(const Value: string);
|
||||
begin
|
||||
Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC));
|
||||
end;
|
||||
|
||||
function TTelnetSend.Login: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if not Connect then
|
||||
Exit;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function TTelnetSend.SSHLogin: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if Connect then
|
||||
begin
|
||||
FSock.SSL.SSLType := LT_SSHv2;
|
||||
FSock.SSL.Username := FUsername;
|
||||
FSock.SSL.Password := FPassword;
|
||||
FSock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTelnetSend.Logout;
|
||||
begin
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
{==============================================================================|
|
||||
| Project : Ararat Synapse | 001.003.001 |
|
||||
|==============================================================================|
|
||||
| Content: TELNET and SSH2 client |
|
||||
|==============================================================================|
|
||||
| Copyright (c)1999-2010, Lukas Gebauer |
|
||||
| All rights reserved. |
|
||||
| |
|
||||
| Redistribution and use in source and binary forms, with or without |
|
||||
| modification, are permitted provided that the following conditions are met: |
|
||||
| |
|
||||
| Redistributions of source code must retain the above copyright notice, this |
|
||||
| list of conditions and the following disclaimer. |
|
||||
| |
|
||||
| Redistributions in binary form must reproduce the above copyright notice, |
|
||||
| this list of conditions and the following disclaimer in the documentation |
|
||||
| and/or other materials provided with the distribution. |
|
||||
| |
|
||||
| Neither the name of Lukas Gebauer nor the names of its contributors may |
|
||||
| be used to endorse or promote products derived from this software without |
|
||||
| specific prior written permission. |
|
||||
| |
|
||||
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
|
||||
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
|
||||
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|
||||
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
|
||||
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|
||||
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
|
||||
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
|
||||
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
|
||||
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
|
||||
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
|
||||
| DAMAGE. |
|
||||
|==============================================================================|
|
||||
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
|
||||
| Portions created by Lukas Gebauer are Copyright (c)2002-2010. |
|
||||
| All Rights Reserved. |
|
||||
|==============================================================================|
|
||||
| Contributor(s): |
|
||||
|==============================================================================|
|
||||
| History: see HISTORY.HTM from distribution package |
|
||||
| (Found at URL: http://www.ararat.cz/synapse/) |
|
||||
|==============================================================================}
|
||||
|
||||
{:@abstract(Telnet script client)
|
||||
|
||||
Used RFC: RFC-854
|
||||
}
|
||||
|
||||
{$IFDEF FPC}
|
||||
{$MODE DELPHI}
|
||||
{$ENDIF}
|
||||
{$H+}
|
||||
|
||||
{$IFDEF UNICODE}
|
||||
{$WARN IMPLICIT_STRING_CAST OFF}
|
||||
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
|
||||
{$ENDIF}
|
||||
|
||||
unit tlntsend;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
blcksock, synautil;
|
||||
|
||||
const
|
||||
cTelnetProtocol = '23';
|
||||
cSSHProtocol = '22';
|
||||
|
||||
TLNT_EOR = #239;
|
||||
TLNT_SE = #240;
|
||||
TLNT_NOP = #241;
|
||||
TLNT_DATA_MARK = #242;
|
||||
TLNT_BREAK = #243;
|
||||
TLNT_IP = #244;
|
||||
TLNT_AO = #245;
|
||||
TLNT_AYT = #246;
|
||||
TLNT_EC = #247;
|
||||
TLNT_EL = #248;
|
||||
TLNT_GA = #249;
|
||||
TLNT_SB = #250;
|
||||
TLNT_WILL = #251;
|
||||
TLNT_WONT = #252;
|
||||
TLNT_DO = #253;
|
||||
TLNT_DONT = #254;
|
||||
TLNT_IAC = #255;
|
||||
|
||||
type
|
||||
{:@abstract(State of telnet protocol). Used internaly by TTelnetSend.}
|
||||
TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
|
||||
tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
|
||||
|
||||
{:@abstract(Class with implementation of Telnet/SSH script client.)
|
||||
|
||||
Note: Are you missing properties for specify server address and port? Look to
|
||||
parent @link(TSynaClient) too!}
|
||||
TTelnetSend = class(TSynaClient)
|
||||
private
|
||||
FSock: TTCPBlockSocket;
|
||||
FBuffer: Ansistring;
|
||||
FState: TTelnetState;
|
||||
FSessionLog: Ansistring;
|
||||
FSubNeg: Ansistring;
|
||||
FSubType: Ansichar;
|
||||
FTermType: Ansistring;
|
||||
function Connect: Boolean;
|
||||
function Negotiate(const Buf: Ansistring): Ansistring;
|
||||
procedure FilterHook(Sender: TObject; var Value: AnsiString);
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
|
||||
{:Connects to Telnet server.}
|
||||
function Login: Boolean;
|
||||
|
||||
{:Connects to SSH2 server and login by Username and Password properties.
|
||||
|
||||
You must use some of SSL plugins with SSH support. For exammple CryptLib.}
|
||||
function SSHLogin: Boolean;
|
||||
|
||||
{:Logout from telnet server.}
|
||||
procedure Logout;
|
||||
|
||||
{:Send this data to telnet server.}
|
||||
procedure Send(const Value: string);
|
||||
|
||||
{:Reading data from telnet server until Value is readed. If it is not readed
|
||||
until timeout, result is @false. Otherwise result is @true.}
|
||||
function WaitFor(const Value: string): Boolean;
|
||||
|
||||
{:Read data terminated by terminator from telnet server.}
|
||||
function RecvTerminated(const Terminator: string): string;
|
||||
|
||||
{:Read string from telnet server.}
|
||||
function RecvString: string;
|
||||
published
|
||||
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
|
||||
property Sock: TTCPBlockSocket read FSock;
|
||||
|
||||
{:all readed datas in this session (from connect) is stored in this large
|
||||
string.}
|
||||
property SessionLog: Ansistring read FSessionLog write FSessionLog;
|
||||
|
||||
{:Terminal type indentification. By default is 'SYNAPSE'.}
|
||||
property TermType: Ansistring read FTermType write FTermType;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
constructor TTelnetSend.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FSock := TTCPBlockSocket.Create;
|
||||
FSock.Owner := self;
|
||||
FSock.OnReadFilter := FilterHook;
|
||||
FTimeout := 60000;
|
||||
FTargetPort := cTelnetProtocol;
|
||||
FSubNeg := '';
|
||||
FSubType := #0;
|
||||
FTermType := 'SYNAPSE';
|
||||
end;
|
||||
|
||||
destructor TTelnetSend.Destroy;
|
||||
begin
|
||||
FSock.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TTelnetSend.Connect: Boolean;
|
||||
begin
|
||||
// Do not call this function! It is calling by LOGIN method!
|
||||
FBuffer := '';
|
||||
FSessionLog := '';
|
||||
FState := tsDATA;
|
||||
FSock.CloseSocket;
|
||||
FSock.LineBuffer := '';
|
||||
FSock.Bind(FIPInterface, cAnyPort);
|
||||
FSock.Connect(FTargetHost, FTargetPort);
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
|
||||
function TTelnetSend.RecvTerminated(const Terminator: string): string;
|
||||
begin
|
||||
Result := FSock.RecvTerminated(FTimeout, Terminator);
|
||||
end;
|
||||
|
||||
function TTelnetSend.RecvString: string;
|
||||
begin
|
||||
Result := FSock.RecvTerminated(FTimeout, CRLF);
|
||||
end;
|
||||
|
||||
function TTelnetSend.WaitFor(const Value: string): Boolean;
|
||||
begin
|
||||
Result := FSock.RecvTerminated(FTimeout, Value) <> '';
|
||||
end;
|
||||
|
||||
procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString);
|
||||
begin
|
||||
Value := Negotiate(Value);
|
||||
FSessionLog := FSessionLog + Value;
|
||||
end;
|
||||
|
||||
function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring;
|
||||
var
|
||||
n: integer;
|
||||
c: Ansichar;
|
||||
Reply: Ansistring;
|
||||
SubReply: Ansistring;
|
||||
begin
|
||||
Result := '';
|
||||
for n := 1 to Length(Buf) do
|
||||
begin
|
||||
c := Buf[n];
|
||||
Reply := '';
|
||||
case FState of
|
||||
tsData:
|
||||
if c = TLNT_IAC then
|
||||
FState := tsIAC
|
||||
else
|
||||
Result := Result + c;
|
||||
|
||||
tsIAC:
|
||||
case c of
|
||||
TLNT_IAC:
|
||||
begin
|
||||
FState := tsData;
|
||||
Result := Result + TLNT_IAC;
|
||||
end;
|
||||
TLNT_WILL:
|
||||
FState := tsIAC_WILL;
|
||||
TLNT_WONT:
|
||||
FState := tsIAC_WONT;
|
||||
TLNT_DONT:
|
||||
FState := tsIAC_DONT;
|
||||
TLNT_DO:
|
||||
FState := tsIAC_DO;
|
||||
TLNT_EOR:
|
||||
FState := tsDATA;
|
||||
TLNT_SB:
|
||||
begin
|
||||
FState := tsIAC_SB;
|
||||
FSubType := #0;
|
||||
FSubNeg := '';
|
||||
end;
|
||||
else
|
||||
FState := tsData;
|
||||
end;
|
||||
|
||||
tsIAC_WILL:
|
||||
begin
|
||||
case c of
|
||||
#3: //suppress GA
|
||||
Reply := TLNT_DO;
|
||||
else
|
||||
Reply := TLNT_DONT;
|
||||
end;
|
||||
FState := tsData;
|
||||
end;
|
||||
|
||||
tsIAC_WONT:
|
||||
begin
|
||||
Reply := TLNT_DONT;
|
||||
FState := tsData;
|
||||
end;
|
||||
|
||||
tsIAC_DO:
|
||||
begin
|
||||
case c of
|
||||
#24: //termtype
|
||||
Reply := TLNT_WILL;
|
||||
else
|
||||
Reply := TLNT_WONT;
|
||||
end;
|
||||
FState := tsData;
|
||||
end;
|
||||
|
||||
tsIAC_DONT:
|
||||
begin
|
||||
Reply := TLNT_WONT;
|
||||
FState := tsData;
|
||||
end;
|
||||
|
||||
tsIAC_SB:
|
||||
begin
|
||||
FSubType := c;
|
||||
FState := tsIAC_SBDATA;
|
||||
end;
|
||||
|
||||
tsIAC_SBDATA:
|
||||
begin
|
||||
if c = TLNT_IAC then
|
||||
FState := tsSBDATA_IAC
|
||||
else
|
||||
FSubNeg := FSubNeg + c;
|
||||
end;
|
||||
|
||||
tsSBDATA_IAC:
|
||||
case c of
|
||||
TLNT_IAC:
|
||||
begin
|
||||
FState := tsIAC_SBDATA;
|
||||
FSubNeg := FSubNeg + c;
|
||||
end;
|
||||
TLNT_SE:
|
||||
begin
|
||||
SubReply := '';
|
||||
case FSubType of
|
||||
#24: //termtype
|
||||
begin
|
||||
if (FSubNeg <> '') and (FSubNeg[1] = #1) then
|
||||
SubReply := #0 + FTermType;
|
||||
end;
|
||||
end;
|
||||
Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE);
|
||||
FState := tsDATA;
|
||||
end;
|
||||
else
|
||||
FState := tsDATA;
|
||||
end;
|
||||
|
||||
else
|
||||
FState := tsData;
|
||||
end;
|
||||
if Reply <> '' then
|
||||
Sock.SendString(TLNT_IAC + Reply + c);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure TTelnetSend.Send(const Value: string);
|
||||
begin
|
||||
Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC));
|
||||
end;
|
||||
|
||||
function TTelnetSend.Login: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if not Connect then
|
||||
Exit;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function TTelnetSend.SSHLogin: Boolean;
|
||||
begin
|
||||
Result := False;
|
||||
if Connect then
|
||||
begin
|
||||
FSock.SSL.SSLType := LT_SSHv2;
|
||||
FSock.SSL.Username := FUsername;
|
||||
FSock.SSL.Password := FPassword;
|
||||
FSock.SSLDoConnect;
|
||||
Result := FSock.LastError = 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTelnetSend.Logout;
|
||||
begin
|
||||
FSock.CloseSocket;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
|
|
Loading…
Reference in New Issue