609 lines
15 KiB
ObjectPascal
609 lines
15 KiB
ObjectPascal
{ ****************************************************************************** }
|
|
{ * Status IO writen by QQ 600585@qq.com * }
|
|
{ * https://zpascal.net * }
|
|
{ * https://github.com/PassByYou888/zAI * }
|
|
{ * https://github.com/PassByYou888/ZServer4D * }
|
|
{ * https://github.com/PassByYou888/PascalString * }
|
|
{ * https://github.com/PassByYou888/zRasterization * }
|
|
{ * https://github.com/PassByYou888/CoreCipher * }
|
|
{ * https://github.com/PassByYou888/zSound * }
|
|
{ * https://github.com/PassByYou888/zChinese * }
|
|
{ * https://github.com/PassByYou888/zExpression * }
|
|
{ * https://github.com/PassByYou888/zGameWare * }
|
|
{ * https://github.com/PassByYou888/zAnalysis * }
|
|
{ * https://github.com/PassByYou888/FFMPEG-Header * }
|
|
{ * https://github.com/PassByYou888/zTranslate * }
|
|
{ * https://github.com/PassByYou888/InfiniteIoT * }
|
|
{ * https://github.com/PassByYou888/FastMD5 * }
|
|
{ ****************************************************************************** }
|
|
|
|
unit DoStatusIO;
|
|
|
|
{$INCLUDE zDefine.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFNDEF FPC}
|
|
{$IF Defined(WIN32) or Defined(WIN64)}
|
|
Windows,
|
|
{$ELSEIF not Defined(Linux)}
|
|
FMX.Types,
|
|
{$IFEND}
|
|
{$IFEND FPC}
|
|
SysUtils, Classes, SyncObjs,
|
|
{$IFDEF FPC}
|
|
FPCGenericStructlist, fgl,
|
|
{$ELSE FPC}
|
|
System.Generics.Collections,
|
|
{$ENDIF FPC}
|
|
PascalStrings, UPascalStrings, UnicodeMixedLib, CoreClasses;
|
|
|
|
type
|
|
{$IFDEF FPC}
|
|
TDoStatusProc = procedure(Text_: SystemString; const ID: Integer) is nested;
|
|
{$ELSE FPC}
|
|
TDoStatusProc = reference to procedure(Text_: SystemString; const ID: Integer);
|
|
{$ENDIF FPC}
|
|
TDoStatusMethod = procedure(Text_: SystemString; const ID: Integer) of object;
|
|
TDoStatusCall = procedure(Text_: SystemString; const ID: Integer);
|
|
|
|
procedure AddDoStatusHook(TokenObj: TCoreClassObject; CallProc: TDoStatusMethod);
|
|
procedure AddDoStatusHookM(TokenObj: TCoreClassObject; CallProc: TDoStatusMethod);
|
|
procedure AddDoStatusHookC(TokenObj: TCoreClassObject; CallProc: TDoStatusCall);
|
|
procedure AddDoStatusHookP(TokenObj: TCoreClassObject; CallProc: TDoStatusProc);
|
|
procedure DeleteDoStatusHook(TokenObj: TCoreClassObject);
|
|
procedure DisableStatus;
|
|
procedure EnabledStatus;
|
|
|
|
procedure DoStatus(Text_: SystemString; const ID: Integer); overload;
|
|
procedure DoStatus(const v: Pointer; siz, width: NativeInt); overload;
|
|
procedure DoStatus(prefix: SystemString; v: Pointer; siz, width: NativeInt); overload;
|
|
procedure DoStatus(const v: TCoreClassStrings); overload;
|
|
procedure DoStatus(const v: Int64); overload;
|
|
procedure DoStatus(const v: Integer); overload;
|
|
procedure DoStatus(const v: Single); overload;
|
|
procedure DoStatus(const v: Double); overload;
|
|
procedure DoStatus(const v: Pointer); overload;
|
|
procedure DoStatus(const v: SystemString; const Args: array of const); overload;
|
|
procedure DoError(v: SystemString; const Args: array of const); overload;
|
|
procedure DoStatus(const v: SystemString); overload;
|
|
procedure DoStatus(const v: TPascalString); overload;
|
|
procedure DoStatus(const v: TUPascalString); overload;
|
|
procedure DoStatus(const v: TMD5); overload;
|
|
procedure DoStatus; overload;
|
|
|
|
procedure DoStatusNoLn(const v: TPascalString); overload;
|
|
procedure DoStatusNoLn(const v: SystemString; const Args: array of const); overload;
|
|
procedure DoStatusNoLn; overload;
|
|
|
|
function StrInfo(s: TPascalString): string; overload;
|
|
function StrInfo(s: TUPascalString): string; overload;
|
|
function BytesInfo(s: TBytes): string; overload;
|
|
|
|
var
|
|
LastDoStatus: SystemString;
|
|
IDEOutput: Boolean;
|
|
ConsoleOutput: Boolean;
|
|
OnDoStatusHook: TDoStatusCall;
|
|
|
|
implementation
|
|
|
|
procedure bufHashToString(hash: Pointer; Size: NativeInt; var output: TPascalString);
|
|
const
|
|
HexArr: array [0 .. 15] of SystemChar = ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
|
|
var
|
|
i: Integer;
|
|
begin
|
|
output.Len := Size * 2;
|
|
for i := 0 to Size - 1 do
|
|
begin
|
|
output.buff[i * 2] := HexArr[(PByte(nativeUInt(hash) + i)^ shr 4) and $0F];
|
|
output.buff[i * 2 + 1] := HexArr[PByte(nativeUInt(hash) + i)^ and $0F];
|
|
end;
|
|
end;
|
|
|
|
procedure DoStatus(Text_: SystemString; const ID: Integer);
|
|
begin
|
|
try
|
|
OnDoStatusHook(Text_, ID);
|
|
except
|
|
end;
|
|
end;
|
|
|
|
procedure DoStatus(const v: Pointer; siz, width: NativeInt);
|
|
var
|
|
s: TPascalString;
|
|
i: Integer;
|
|
n: SystemString;
|
|
begin
|
|
bufHashToString(v, siz, s);
|
|
n := '';
|
|
for i := 1 to s.Len div 2 do
|
|
begin
|
|
if n <> '' then
|
|
n := n + #32 + s[i * 2 - 1] + s[i * 2]
|
|
else
|
|
n := s[i * 2 - 1] + s[i * 2];
|
|
|
|
if i mod (width div 2) = 0 then
|
|
begin
|
|
DoStatus(n);
|
|
n := '';
|
|
end;
|
|
end;
|
|
if n <> '' then
|
|
DoStatus(n);
|
|
end;
|
|
|
|
procedure DoStatus(prefix: SystemString; v: Pointer; siz, width: NativeInt);
|
|
var
|
|
s: TPascalString;
|
|
i: Integer;
|
|
n: SystemString;
|
|
begin
|
|
bufHashToString(v, siz, s);
|
|
n := '';
|
|
for i := 1 to s.Len div 2 do
|
|
begin
|
|
if n <> '' then
|
|
n := n + #32 + s[i * 2 - 1] + s[i * 2]
|
|
else
|
|
n := s[i * 2 - 1] + s[i * 2];
|
|
|
|
if i mod (width div 2) = 0 then
|
|
begin
|
|
DoStatus(prefix + n);
|
|
n := '';
|
|
end;
|
|
end;
|
|
if n <> '' then
|
|
DoStatus(prefix + n);
|
|
end;
|
|
|
|
procedure DoStatus(const v: TCoreClassStrings);
|
|
var
|
|
i: Integer;
|
|
o: TCoreClassObject;
|
|
begin
|
|
for i := 0 to v.Count - 1 do
|
|
begin
|
|
o := v.Objects[i];
|
|
if o <> nil then
|
|
DoStatus('%s<%s>', [v[i], o.ClassName])
|
|
else
|
|
DoStatus(v[i]);
|
|
end;
|
|
end;
|
|
|
|
procedure DoStatus(const v: Int64);
|
|
begin
|
|
DoStatus(IntToStr(v));
|
|
end;
|
|
|
|
procedure DoStatus(const v: Integer);
|
|
begin
|
|
DoStatus(IntToStr(v));
|
|
end;
|
|
|
|
procedure DoStatus(const v: Single);
|
|
begin
|
|
DoStatus(FloatToStr(v));
|
|
end;
|
|
|
|
procedure DoStatus(const v: Double);
|
|
begin
|
|
DoStatus(FloatToStr(v));
|
|
end;
|
|
|
|
procedure DoStatus(const v: Pointer);
|
|
begin
|
|
DoStatus(Format('0x%p', [v]));
|
|
end;
|
|
|
|
procedure DoStatus(const v: SystemString; const Args: array of const);
|
|
begin
|
|
DoStatus(Format(v, Args));
|
|
end;
|
|
|
|
procedure DoError(v: SystemString; const Args: array of const);
|
|
begin
|
|
DoStatus(Format(v, Args), 2);
|
|
end;
|
|
|
|
procedure DoStatus(const v: SystemString);
|
|
begin
|
|
DoStatus(v, 0);
|
|
end;
|
|
|
|
procedure DoStatus(const v: TPascalString);
|
|
begin
|
|
DoStatus(v.Text, 0);
|
|
end;
|
|
|
|
procedure DoStatus(const v: TUPascalString);
|
|
begin
|
|
DoStatus(v.Text, 0);
|
|
end;
|
|
|
|
procedure DoStatus(const v: TMD5);
|
|
begin
|
|
DoStatus(umlMD5ToString(v).Text);
|
|
end;
|
|
|
|
type
|
|
TStatusProcStruct = record
|
|
TokenObj: TCoreClassObject;
|
|
OnStatusM: TDoStatusMethod;
|
|
OnStatusC: TDoStatusCall;
|
|
OnStatusP: TDoStatusProc;
|
|
end;
|
|
|
|
PStatusProcStruct = ^TStatusProcStruct;
|
|
|
|
TStatusStruct = record
|
|
s: SystemString;
|
|
th: TCoreClassThread;
|
|
TriggerTime: TTimeTick;
|
|
end;
|
|
|
|
PStatusStruct = ^TStatusStruct;
|
|
|
|
TStatusNoLnStruct = record
|
|
s: TPascalString;
|
|
th: TCoreClassThread;
|
|
TriggerTime: TTimeTick;
|
|
end;
|
|
|
|
PStatusNoLnStruct = ^TStatusNoLnStruct;
|
|
|
|
TStatusProcList = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList<PStatusProcStruct>;
|
|
TStatusStructList = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList<PStatusStruct>;
|
|
TStatusNoLnStructList = {$IFDEF FPC}specialize {$ENDIF FPC} TGenericsList<PStatusNoLnStruct>;
|
|
|
|
var
|
|
StatusActive: Boolean;
|
|
HookStatusProcs: TStatusProcList;
|
|
StatusStructList: TStatusStructList;
|
|
StatusCritical: TCriticalSection;
|
|
StatusNoLnStructList: TStatusNoLnStructList;
|
|
Hooked_OnCheckThreadSynchronize: TCheckThreadSynchronize;
|
|
|
|
function GetOrCreateStatusNoLnData_(th_: TCoreClassThread): PStatusNoLnStruct;
|
|
var
|
|
tk: TTimeTick;
|
|
i: Integer;
|
|
begin
|
|
tk := GetTimeTick();
|
|
Result := nil;
|
|
i := 0;
|
|
while i < StatusNoLnStructList.Count do
|
|
begin
|
|
if StatusNoLnStructList[i]^.th = th_ then
|
|
begin
|
|
Result := StatusNoLnStructList[i];
|
|
Result^.TriggerTime := tk;
|
|
|
|
if i > 0 then
|
|
StatusNoLnStructList.Exchange(i, 0);
|
|
inc(i);
|
|
end
|
|
else if tk - StatusNoLnStructList[i]^.TriggerTime > C_Tick_Minute then
|
|
begin
|
|
Dispose(StatusNoLnStructList[i]);
|
|
StatusNoLnStructList.Delete(i);
|
|
end
|
|
else
|
|
inc(i);
|
|
end;
|
|
|
|
if Result = nil then
|
|
begin
|
|
new(Result);
|
|
Result^.s := '';
|
|
Result^.th := th_;
|
|
Result^.TriggerTime := tk;
|
|
StatusNoLnStructList.Add(Result);
|
|
end;
|
|
end;
|
|
|
|
function GetOrCreateStatusNoLnData(): PStatusNoLnStruct;
|
|
begin
|
|
Result := GetOrCreateStatusNoLnData_(TCoreClassThread.CurrentThread);
|
|
end;
|
|
|
|
procedure DoStatusNoLn(const v: TPascalString);
|
|
var
|
|
L, i: Integer;
|
|
StatusNoLnData: PStatusNoLnStruct;
|
|
pSS: PStatusStruct;
|
|
begin
|
|
StatusCritical.Acquire;
|
|
StatusNoLnData := GetOrCreateStatusNoLnData();
|
|
try
|
|
L := v.Len;
|
|
i := 1;
|
|
while i <= L do
|
|
begin
|
|
if CharIn(v[i], [#13, #10]) then
|
|
begin
|
|
if StatusNoLnData^.s.Len > 0 then
|
|
begin
|
|
new(pSS);
|
|
pSS^.s := StatusNoLnData^.s.Text;
|
|
pSS^.th := TCoreClassThread.CurrentThread;
|
|
pSS^.TriggerTime := GetTimeTick;
|
|
StatusStructList.Add(pSS);
|
|
StatusNoLnData^.s := '';
|
|
end;
|
|
repeat
|
|
inc(i);
|
|
until (i > L) or (not CharIn(v[i], [#13, #10]));
|
|
end
|
|
else
|
|
begin
|
|
StatusNoLnData^.s.Append(v[i]);
|
|
inc(i);
|
|
end;
|
|
end;
|
|
finally
|
|
StatusCritical.Release;
|
|
end;
|
|
end;
|
|
|
|
procedure DoStatusNoLn(const v: SystemString; const Args: array of const);
|
|
begin
|
|
DoStatusNoLn(Format(v, Args));
|
|
end;
|
|
|
|
procedure DoStatusNoLn;
|
|
var
|
|
StatusNoLnData: PStatusNoLnStruct;
|
|
a: SystemString;
|
|
begin
|
|
StatusCritical.Acquire;
|
|
StatusNoLnData := GetOrCreateStatusNoLnData();
|
|
a := StatusNoLnData^.s;
|
|
StatusNoLnData^.s := '';
|
|
StatusCritical.Release;
|
|
if Length(a) > 0 then
|
|
DoStatus(a);
|
|
end;
|
|
|
|
function StrInfo(s: TPascalString): string;
|
|
begin
|
|
Result := BytesInfo(s.Bytes);
|
|
end;
|
|
|
|
function StrInfo(s: TUPascalString): string;
|
|
begin
|
|
Result := BytesInfo(s.Bytes);
|
|
end;
|
|
|
|
function BytesInfo(s: TBytes): string;
|
|
begin
|
|
Result := umlStringOf(s);
|
|
end;
|
|
|
|
procedure _InternalOutput(const Text_: SystemString; const ID: Integer);
|
|
var
|
|
i: Integer;
|
|
p: PStatusProcStruct;
|
|
begin
|
|
if (StatusActive) and (HookStatusProcs.Count > 0) then
|
|
begin
|
|
LastDoStatus := Text_;
|
|
for i := HookStatusProcs.Count - 1 downto 0 do
|
|
begin
|
|
p := HookStatusProcs[i];
|
|
try
|
|
if Assigned(p^.OnStatusM) then
|
|
p^.OnStatusM(Text_, ID);
|
|
if Assigned(p^.OnStatusC) then
|
|
p^.OnStatusC(Text_, ID);
|
|
if Assigned(p^.OnStatusP) then
|
|
p^.OnStatusP(Text_, ID);
|
|
except
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$IFNDEF FPC}
|
|
if ((IDEOutput) or (ID = 2)) and (DebugHook <> 0) then
|
|
begin
|
|
{$IF Defined(WIN32) or Defined(WIN64)}
|
|
OutputDebugString(PWideChar('"' + Text_ + '"'));
|
|
{$ELSEIF not Defined(Linux)}
|
|
FMX.Types.Log.d('"' + Text_ + '"');
|
|
{$IFEND}
|
|
end;
|
|
{$IFEND FPC}
|
|
if ((ConsoleOutput) or (ID = 2)) and (IsConsole) then
|
|
Writeln(Text_);
|
|
end;
|
|
|
|
procedure CheckDoStatus(th: TCoreClassThread);
|
|
var
|
|
i: Integer;
|
|
pSS: PStatusStruct;
|
|
begin
|
|
if StatusCritical = nil then
|
|
exit;
|
|
if (th = nil) or (th.ThreadID <> MainThreadID) then
|
|
exit;
|
|
StatusCritical.Acquire;
|
|
try
|
|
if StatusStructList.Count > 0 then
|
|
begin
|
|
for i := 0 to StatusStructList.Count - 1 do
|
|
begin
|
|
pSS := StatusStructList[i];
|
|
_InternalOutput(pSS^.s, 0);
|
|
pSS^.s := '';
|
|
Dispose(pSS);
|
|
end;
|
|
StatusStructList.Clear;
|
|
end;
|
|
finally
|
|
StatusCritical.Release;
|
|
end;
|
|
end;
|
|
|
|
procedure DoStatus;
|
|
begin
|
|
CheckDoStatus(TCoreClassThread.CurrentThread);
|
|
end;
|
|
|
|
procedure InternalDoStatus(Text_: SystemString; const ID: Integer);
|
|
var
|
|
th: TCoreClassThread;
|
|
pSS: PStatusStruct;
|
|
begin
|
|
th := TCoreClassThread.CurrentThread;
|
|
if (th = nil) or (th.ThreadID <> MainThreadID) then
|
|
begin
|
|
new(pSS);
|
|
pSS^.s := '[' + IntToStr(th.ThreadID) + '] ' + Text_;;
|
|
pSS^.th := th;
|
|
pSS^.TriggerTime := GetTimeTick();
|
|
StatusCritical.Acquire;
|
|
StatusStructList.Add(pSS);
|
|
StatusCritical.Release;
|
|
exit;
|
|
end;
|
|
|
|
CheckDoStatus(th);
|
|
_InternalOutput(Text_, ID);
|
|
end;
|
|
|
|
procedure AddDoStatusHook(TokenObj: TCoreClassObject; CallProc: TDoStatusMethod);
|
|
begin
|
|
AddDoStatusHookM(TokenObj, CallProc);
|
|
end;
|
|
|
|
procedure AddDoStatusHookM(TokenObj: TCoreClassObject; CallProc: TDoStatusMethod);
|
|
var
|
|
p: PStatusProcStruct;
|
|
begin
|
|
new(p);
|
|
p^.TokenObj := TokenObj;
|
|
p^.OnStatusM := CallProc;
|
|
p^.OnStatusC := nil;
|
|
p^.OnStatusP := nil;
|
|
HookStatusProcs.Add(p);
|
|
end;
|
|
|
|
procedure AddDoStatusHookC(TokenObj: TCoreClassObject; CallProc: TDoStatusCall);
|
|
var
|
|
p: PStatusProcStruct;
|
|
begin
|
|
new(p);
|
|
p^.TokenObj := TokenObj;
|
|
p^.OnStatusM := nil;
|
|
p^.OnStatusC := CallProc;
|
|
p^.OnStatusP := nil;
|
|
HookStatusProcs.Add(p);
|
|
end;
|
|
|
|
procedure AddDoStatusHookP(TokenObj: TCoreClassObject; CallProc: TDoStatusProc);
|
|
var
|
|
p: PStatusProcStruct;
|
|
begin
|
|
new(p);
|
|
p^.TokenObj := TokenObj;
|
|
p^.OnStatusM := nil;
|
|
p^.OnStatusC := nil;
|
|
p^.OnStatusP := CallProc;
|
|
HookStatusProcs.Add(p);
|
|
end;
|
|
|
|
procedure DeleteDoStatusHook(TokenObj: TCoreClassObject);
|
|
var
|
|
i: Integer;
|
|
p: PStatusProcStruct;
|
|
begin
|
|
i := 0;
|
|
while i < HookStatusProcs.Count do
|
|
begin
|
|
p := HookStatusProcs[i];
|
|
if p^.TokenObj = TokenObj then
|
|
begin
|
|
Dispose(p);
|
|
HookStatusProcs.Delete(i);
|
|
end
|
|
else
|
|
inc(i);
|
|
end;
|
|
end;
|
|
|
|
procedure DisableStatus;
|
|
begin
|
|
StatusActive := False;
|
|
end;
|
|
|
|
procedure EnabledStatus;
|
|
begin
|
|
StatusActive := True;
|
|
end;
|
|
|
|
procedure DoCheckThreadSynchronize;
|
|
begin
|
|
DoStatus();
|
|
if Assigned(Hooked_OnCheckThreadSynchronize) then
|
|
Hooked_OnCheckThreadSynchronize();
|
|
end;
|
|
|
|
procedure _DoInit;
|
|
begin
|
|
HookStatusProcs := TStatusProcList.Create;
|
|
StatusStructList := TStatusStructList.Create;
|
|
StatusCritical := TCriticalSection.Create;
|
|
StatusNoLnStructList := TStatusNoLnStructList.Create;
|
|
|
|
StatusActive := True;
|
|
LastDoStatus := '';
|
|
IDEOutput := False;
|
|
ConsoleOutput := True;
|
|
OnDoStatusHook := {$IFDEF FPC}@{$ENDIF FPC}InternalDoStatus;
|
|
|
|
Hooked_OnCheckThreadSynchronize := CoreClasses.OnCheckThreadSynchronize;
|
|
CoreClasses.OnCheckThreadSynchronize := {$IFDEF FPC}@{$ENDIF FPC}DoCheckThreadSynchronize;
|
|
end;
|
|
|
|
procedure _DoFree;
|
|
var
|
|
i: Integer;
|
|
pSS: PStatusStruct;
|
|
begin
|
|
for i := 0 to HookStatusProcs.Count - 1 do
|
|
Dispose(PStatusProcStruct(HookStatusProcs[i]));
|
|
DisposeObject(HookStatusProcs);
|
|
|
|
for i := 0 to StatusStructList.Count - 1 do
|
|
begin
|
|
pSS := StatusStructList[i];
|
|
pSS^.s := '';
|
|
Dispose(pSS);
|
|
end;
|
|
DisposeObject(StatusStructList);
|
|
|
|
for i := 0 to StatusNoLnStructList.Count - 1 do
|
|
Dispose(StatusNoLnStructList[i]);
|
|
DisposeObject(StatusNoLnStructList);
|
|
|
|
DisposeObject(StatusCritical);
|
|
|
|
StatusActive := True;
|
|
StatusCritical := nil;
|
|
end;
|
|
|
|
initialization
|
|
|
|
_DoInit;
|
|
|
|
finalization
|
|
|
|
_DoFree;
|
|
|
|
end.
|