Delphi Новый вид много потока для эмулятора нокс или мемо работа с адб

[kazann116]

unit DAA_ThTh;
{$A4}
{$H+,O+,X+,J+,B+,P+,V+,T-}
{$ALIGN ON}
{$MINENUMSIZE 4}
{$WEAKPACKAGEUNIT}

interface
uses Windows;
const
AllThreads=MAXDWORD; // Идентификатор для всех потоков.
kernel='Kernel32.dll';
user='user32.dll';

function GetTickCount64:UInt64;stdcall;external kernel name 'GetTickCount64';
procedure RtlZeroMemory(Obj:pointer;Size:SIZE_T);stdcall;external kernel name 'RtlZeroMemory';
procedure DisableProcessWindowsGhosting;external user name 'DisableProcessWindowsGhosting';



type
{TDTProc = Функция обработки данных (Многопоток)}
{Это функция обратного вызова.}
{Если функция возвращает False, то происходит выход из потока}
TDTProc=function(Param:pointer):bool;stdcall;

{Функция создаёт поток и вызывает TDTProc до тех пор, пока она не вернёт False}
{ID - Идентификатор потока. Может иметь любое значение, отличное от нуля и от $FFFFFFFF.}
{lpStart - функция обратного вызова. (Рабочее тело потока)}
{Param - указатель на что-либо, который будет передан функции обратного вызова.}
{Suspended - состояние после создания. Если True, то поток будет создан, но остановлен.}
{При успешном выполнении возвращает ID, при неудаче - возвращает 0.}
function CreateDTH(ID:dword;lpStart:TDTProc;Param:pointer;Suspended:bool):integer;

{Функция возвращает количество потоков.}
function NumDTH:dword;

{Функция проверяет, является ли ID рабочим потоком.}
{Если поток с таким ID существует, то возвращает True.}
function isDTH(ID:dword):bool;

{Функция останавливает поток с индексом ID, если такой существует.}
function SuspendDTH(ID:dword):bool;

{Функция возобновляет работу потока с индексом ID, если такой существует.}
function ResumeDTH(ID:dword):bool;

{Функция уничтожает поток с индексом ID.}
{ID - идентификатор потока или AllThreads для всех потоков}
{Wait - Если True, то функция вернёт управление в lpStart и будет ждать её завершения с любым результатом.}
{Если Wait=False, тогда функция уничтожит поток немедленно.}
{ExitCode - код завершения для потока.}
function DestroyDTH(ID:dword;Wait:bool;ExitCode:dword):bool;

{Замена EnterCriticalSection. Возвращает число миллисекунд, которые пришлось ждать освобождения области.}
function EnterSync:dword;

{Замена LeaveCriticalSection. Возвращает число миллисекунд, требуемых на обработку секции.}
function LeaveSync:dword;

{Принудительно закрывает открытую критическую секцию.}
procedure CancelSync;

{Возвращает текстовую информацию о последней операции}
function LastErrorText:string;

implementation
procedure CloseH(var Handle:tHandle);inline; // Вспомогательная.
begin CloseHandle(Handle);Handle:=0 end;

type
PDTHList=^TDTHList;
TDTHList=packed record
cbSize:dword; // Размер структуры в байтах.
IDThread:dword; // Пользовательский идентификатор потока.
RealID:dword; // Внутренний идентификатор потока.
RealTh:tHandle; // Ручка потока.
Proc:TDTProc; // Адрес функции обратного вызова.
Param:Pointer; // Параметр функции.
DoExit:bool; // Признак принудительного закрытия потока.
Next:PDTHList; // Указатель на следующую структуру.
end;
PDTHArr=^TDTHArr;
TDTHArr=packed array[0..0]of TDTHList;
const
DTHErrs:array[0..7]of PWideChar=(
'Операция выполнена успешно.'#0,
'Невозможно создать поток с данным индексом.'#0,
'Поток с данным индексом не найден.'#0,
'Нет ни одного активного или остановленного потока.'#0,
'НЕТ ИНФОРМАЦИИ.'#0,
'Поток не был создан из-за ошибки системы.'#0,
'Поток с данным индексом уже существует.'#0,
'Некорректный индекс потока для запроса.'#0);
var
StartDTH:PDTHList=nil;
CurrentDTH:PDTHList=nil;
DTHArr:PDTHArr absolute StartDTH;
LastError:dword;
Evt:tHandle;

threadvar
TC1,TC2:UInt64;

function EnterSync:dword;
begin
if StartDTH<>nil then begin
TC1:=GetTickCount64;
WaitForSingleObject(Evt,INFINITE);
TC2:=GetTickCount64;
Result:=dword(TC2-TC1);
ResetEvent(Evt);LastError:=0;
end else begin Result:=0;LastError:=3 end;
end;

function LeaveSync:dword;
begin
if StartDTH<>nil then begin
TC1:=GetTickCount64;
Result:=dword(TC1-TC2);
SetEvent(Evt);LastError:=0;
end else begin Result:=0;LastError:=3 end;
end;

procedure CancelSync;begin LastError:=0;PulseEvent(Evt);WaitForSingleObject(Evt,1);SetEvent(Evt)end;

function LastErrorText:string;begin Result:=DTHErrs[LastError]end;

threadvar CurID:dword;

function ThreadFunc(Param:PDTHList):Integer;stdcall;
var doNextCycle:bool;CurDTH,PrevDTH:PDTHList;
begin
CurID:=0;
Result:=0;
if Param<>nil then begin
if CurID=0 then begin
CurID:=GetCurrentThreadID;
repeat
doNextCycle:=False;
if Assigned(Param^.Proc)then begin
doNextCycle:=not Param^.Proc(Param^.Param);
Sleep(500);
end else doNextCycle:=True;
if Param^.DoExit then doNextCycle:=True;
until doNextCycle;
end else exit;
Result:=0;
SwitchToThread;
SetEvent(Evt);
CurDTH:=StartDTH;
if CurDTH<>nil then begin
PrevDTH:=nil;
while CurDTH<>nil do begin
if Param^.IDThread=CurDTH^.IDThread then begin
if PrevDTH<>nil then PrevDTH^.Next:=CurDTH^.Next else StartDTH:=nil;
Dispose(CurDTH);
CurDTH:=nil;
end;
if CurDTH<>nil then begin
PrevDTH:=CurDTH;CurDTH:=CurDTH^.Next;
end;
end;
end;
ResetEvent(Evt);
end;
EndThread(Result);
end;
{Функция проверяет, существует ли поток с соответствующим ID}
function TestToExist(ID:dword):bool;
begin Result:=False;
if StartDTH<>nil then begin
LastError:=2;
CurrentDTH:=StartDTH;
while CurrentDTH<>nil do begin
if CurrentDTH^.IDThread=ID then begin Result:=True;LastError:=0;break end;
CurrentDTH:=CurrentDTH^.Next;
end;
end else LastError:=3;
end;

function CreateDTH(ID:dword;lpStart:TDTProc;Param:pointer;Suspended:bool):integer;
var PrevDTH:PDTHList;
begin
Result:=0;PrevDTH:=nil;LastError:=0;
if(ID=AllThreads)or(ID=0)then begin LastError:=1;exit end;
if TestToExist(ID)then begin LastError:=6;exit end;

if StartDTH=nil then begin
New(CurrentDTH);StartDTH:=CurrentDTH
end else begin
CurrentDTH:=StartDTH;
while CurrentDTH^.Next<>nil do CurrentDTH:=CurrentDTH^.Next;
New(CurrentDTH^.Next);
PrevDTH:=CurrentDTH;
CurrentDTH:=CurrentDTH^.Next;
PrevDTH^.Next:=CurrentDTH;
end;
if CurrentDTH<>nil then begin
CurrentDTH^.cbSize:=SizeOf(TDTHList);
CurrentDTH^.IDThread:=ID;
CurrentDTH^.Proc:=lpStart;
CurrentDTH^.Param:=Param;
CurrentDTH^.DoExit:=False;
CurrentDTH^.Next:=nil;
if Suspended then dword(Suspended):=MAXDWORD;
CurrentDTH^.RealTh:=BeginThread(nil,1048576,@ThreadFunc,CurrentDTH,CREATE_SUSPENDED and dword(Suspended),CurrentDTH^.RealID);
if CurrentDTH^.RealTh=0 then begin
if PrevDTH<>nil then PrevDTH^.Next:=nil else StartDTH:=nil;
Dispose(CurrentDTH);LastError:=5
end else begin LastError:=0;Result:=CurrentDTH^.IDThread end
end else exit;
end;

function NumDTH:dword;
begin
Result:=0;
if StartDTH=nil then begin LastError:=3;exit end;
WaitForSingleObject(Evt,500);
CurrentDTH:=StartDTH;
while CurrentDTH<>nil do begin
Result:=Result+1;
CurrentDTH:=CurrentDTH^.Next
end;
end;

function isDTH(ID:dword):bool;
begin
Result:=False;
if(ID=MAXDWORD)or(ID=0)then begin LastError:=7;exit end;
if StartDTH=nil then begin LastError:=3;exit end;
WaitForSingleObject(Evt,500);
LastError:=2;CurrentDTH:=StartDTH;
while CurrentDTH<>nil do begin
if CurrentDTH^.IDThread=ID then begin LastError:=0;Result:=True;break end;
CurrentDTH:=CurrentDTH^.Next
end;
end;

function SuspendDTH(ID:dword):bool;
begin
Result:=False;
if StartDTH=nil then begin LastError:=3;exit end;
if ID=0 then begin LastError:=7;exit end;
WaitForSingleObject(Evt,500);
CurrentDTH:=StartDTH;
if ID=AllThreads then begin Result:=True;LastError:=0 end else LastError:=2;
while CurrentDTH<>nil do begin
if ID=AllThreads then SuspendThread(CurrentDTH^.RealTh)else
if ID=CurrentDTH^.IDThread then
begin SuspendThread(CurrentDTH^.RealTh);LastError:=0;Result:=True;break end;
CurrentDTH:=CurrentDTH^.Next
end;
end;

function ResumeDTH(ID:dword):bool;
begin
Result:=False;
if StartDTH=nil then begin LastError:=3;exit end;
if ID=0 then begin LastError:=7;exit end;
WaitForSingleObject(Evt,500);
CurrentDTH:=StartDTH;
if ID=AllThreads then begin Result:=True;LastError:=0 end else LastError:=2;
while CurrentDTH<>nil do begin
if ID=AllThreads then ResumeThread(CurrentDTH^.RealTh)else
if ID=CurrentDTH^.IDThread then
begin ResumeThread(CurrentDTH^.RealTh);LastError:=0;Result:=True;break end;
CurrentDTH:=CurrentDTH^.Next
end;
end;

function DestroyDTH(ID:dword;Wait:bool;ExitCode:dword):bool;
var PrevDTH:PDTHList;
begin
Result:=False;
if StartDTH=nil then begin LastError:=3;exit end;
if ID=0 then begin LastError:=7;exit end;
if(ID=AllThreads)and(Wait=False)then begin
CurrentDTH:=StartDTH;
while CurrentDTH<>nil do begin
if TerminateThread(CurrentDTH^.RealTh,ExitCode)then Result:=True;
CurrentDTH^.RealID:=0;CurrentDTH^.RealTh:=0;
StartDTH:=CurrentDTH;
CurrentDTH:=CurrentDTH^.Next;
Dispose(StartDTH);
end;LastError:=0;
StartDTH:=nil;exit
end;
if(ID=AllThreads)and(Wait=True)then begin
CurrentDTH:=StartDTH;
while CurrentDTH<>nil do begin
CurrentDTH^.DoExit:=True;
CurrentDTH:=CurrentDTH^.Next;
end;LastError:=0;exit
end;
if(ID<>AllThreads)and(Wait=False)then begin
CurrentDTH:=StartDTH;
PrevDTH:=nil;LastError:=2;
while CurrentDTH<>nil do begin
if ID=CurrentDTH^.IDThread then begin
if PrevDTH<>nil then PrevDTH^.Next:=CurrentDTH^.Next else StartDTH:=nil;
if TerminateThread(CurrentDTH^.RealTh,ExitCode)then Result:=True;
Dispose(CurrentDTH);CurrentDTH:=nil;LastError:=0
end;
if CurrentDTH<>nil then begin
PrevDTH:=CurrentDTH;
CurrentDTH:=CurrentDTH^.Next;
end;
end;exit
end;
if(ID<>AllThreads)and(Wait=True)then begin
CurrentDTH:=StartDTH;LastError:=2;
while CurrentDTH<>nil do begin
if ID=CurrentDTH^.IDThread then begin CurrentDTH^.DoExit:=True;LastError:=0;break end;
CurrentDTH:=CurrentDTH^.Next;
end;
end;
end;

initialization
StartDTH:=nil;CurrentDTH:=nil;LastError:=0;
Evt:=CreateEvent(nil,True,True,nil);
finalization
if StartDTH<>nil then DestroyDTH(AllThreads,False,0);
if Evt<>0 then CloseH(Evt);
end.


объявляем.

type
PIPPort=^TIPPort;
PIPPorts=^TIPPorts;
TIPPort=packed record
IP:array[0..31]of WideChar;
ID:dword;
end;
TIPPorts=array[0..0]of TIPPort;
var IPPorts:PIPPorts;
function Registr(Param:PIPPort):bool;stdcall;

запуск потока.

procedure TForm3.BitBtn1Click(Sender: TObject);
var x,xx:dword;
begin
xx:=form2.memo1.Lines.Count; // Количество потоков.
IPPorts:=GetMemory(SizeOf(TIPPort)*xx);
for x:=1 to xx do begin
StrPCopy(IPPorts^[x-1].IP,form2.memo1.Lines[x-1]);
IPPorts^[x-1].ID:=x; // ID потока.
CreateDTH(IPPorts^[x-1].ID,@Registr,@IPPorts^[x-1],False);
end;
end;

сам поток.
function Registr(Param:PIPPort):bool;stdcall;
begin
result:=true// если нужно что бы постоянно выполнялось.
end;


полная остановка потоков .
DestroyDTH(AllThreads,False,0);