Canvas.Lock;
try
Canvas.Handle:=DC;
try
//... kreslení...
finally
Canvas.Handle:=0;
end;
finally
Canvas.Unlock;
end;
try
//... tělo threadu
except
// Hlavní (prázdný) handler pro odchycení jakékoli exception.
end;
type
PMyThreadParams=^TMyThreadParams;
TMyThreadParams=record
FileName: string;
CmdShow: integer;
end;
function ExecFileThreadProc(Param: Pointer): Longint;
var ptp: PMyThreadParams;
begin
try
try
ptp:=Param;
//
ShellExecute(0,'open',PChar(ptp.FileName),nil,nil,ptp.CmdShow);
//
finally
ptp:=Param;
Finalize(ptp^);
FreeMem(ptp);
end;
except
// main thread catcher...
end;
//
Result:=0;
end;
function SpustSoubor(const FileName: string; CmdShow: integer): Boolean;
var ptp: PMyThreadParams;
thh: THandle;
thid: Cardinal;
begin
// Alokace parametrů pro thread:
ptp:=AllocMem(SizeOf(TMyThreadParams));
ptp.FileName:=FileName;
ptp.CmdShow:=CmdShow;
// Spuštění threadu:
thh:=BeginThread(nil,0,@ExecFileThreadProc,ptp,0,thid);
// Zavření handle threadu:
if (thh<>0) then begin
// Thread byl spuštěn...
CloseHandle(thh);
//
Result:=True;
//
end else begin
// Systém je přetížen?
Finalize(ptp^);
FreeMem(ptp);
//
Result:=False;
end;
end;
Kdyby ovšem v parametrech threadu bylo např. i jeho ID nebo Handle,
získané až po návratu z BeginThread, pak se v předposledním parametru
zadá CREATE_SUSPENDED,
a po dovyplnění parametru se zavolá funkce ResumeThread pro
spuštění threadu...
type
// (Poněkud jsem změnil pořadí a vypustil sekci private...)
TThread=class
protected
// virtualizace:
procedure Execute; virtual; abstract;
procedure DoTerminate; virtual; // Volání OnTerminate
// Tyto funkce/property může používat pouze thread sám:
procedure Synchronize(Method: TThreadMethod);
property ReturnValue: Integer read F... write F...;
property Terminated: Boolean read F...;
//
public
//
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
//
procedure Resume;
procedure Suspend;
//
procedure Terminate;
function WaitFor: LongWord;
// Property:
property ThreadID: THandle read F...;
property Handle: THandle read F...;
//
property FreeOnTerminate: Boolean read F... write F...;
property Suspended: Boolean read F... write Set...;
property Priority: TThreadPriority read Get... write Set...;
//
property OnTerminate: TNotifyEvent read F... write F...;
end;
Popis funkcí a property:
type
PRequest=^TRequest;
TRequestProc=function(Request: Pointer): Longint;
TRequest=record
Proc: TRequestProc;
Params: array[0..7] of DWORD; // adjust as needed...
end;
TErrorNotify=procedure(Sender: TObject; E: Exception) of object;
TWorkThread=class(TThread)
protected
// Must be in any TThread descendant:
procedure Execute; override;
procedure FreeRequest(Req: PRequest); virtual;
function PerformRequest(Req: PRequest): integer; virtual;
private
// Request queue functions:
FQueue: TList;
FQueueLock: TRtlCriticalSection;
FEvent: THandle;
FOnError: TErrorNotify;
FIdle: Boolean;
function GetNextRequest(var Req: PRequest): Boolean;
public
// Creates thread waiting on request:
constructor Create;
destructor Destroy; override;
// Thread stopping:
procedure StopWorker;
// Request queueing:
function AllocRequest: PRequest;
function EnqueueRequest(Request: PRequest): Boolean;
procedure CheckQueueCapa(AddCount: integer);
// Error logging:
property OnError: TErrorNotify read FOnError write FOnError;
// For multi-worker management...
property IsIdle: Boolean read FIdle;
end;
{ TWorkThread }
constructor TWorkThread.Create;
begin
// Create suspended:
inherited Create(True);
// Set FreeOnTerminate:
Self.FreeOnTerminate:=True; // Thread will destroy itself, when Execute returns...
// Create request-queue:
InitializeCriticalSection(FQueueLock);
FQueue:=TList.Create;
// Create manual-reset event, initialy not set:
FEvent:=CreateEvent(nil,True,False,nil);
// Start the thread:
Self.Resume;
end;
destructor TWorkThread.Destroy;
var H: THandle;
begin
// Prevent destructor re-entrance:
Self.FreeOnTerminate:=False;
// Set Terminated and release the waiting thread,
// in case that this is called in context of a main program thread:
Self.Terminate;
if (FEvent<>0) then
SetEvent(FEvent);
// Wait for the thread:
inherited Destroy;
// Cleanup:
FreeAndNil(FQueue);
H:=FEvent;
FEvent:=0;
CloseHandle(H);
DeleteCriticalSection(FQueueLock);
end;
procedure TWorkThread.StopWorker;
begin
// Set Terminated and release the waiting thread,
// in case that this is called in context of a main program thread:
Self.Terminate;
if (FEvent<>0) then
SetEvent(FEvent);
end;
// Thread procedure:
procedure TWorkThread.Execute;
var Request: PRequest;
begin
try
// Check Application.Terminated also for a case,
// that someone forgot to stop this thread...
while (not Self.Terminated) and (not Application.Terminated)
do begin
// GetNextRequest waits for a request,
// and returns False, if the thread should abort.
// Exception from GetNextRequest also aborts the thread:
if not GetNextRequest(Request) then
break;
//
if (Request=nil) then begin
// This should not happen, but for a case
// that someone forgets to reset the event,
// do not consume 99% CPU:
Sleep(50);
continue;
end;
//
try
// Perform the request:
PerformRequest(Request);
//if Assigned(Request.Proc) then ReturnValue:=Request.Proc(Request);
//
except ;// on E:Exception do begin
// Handle request error here:
if Assigned(FOnError) then
FOnError(Self,Exception(ExceptObject));
end; // end;
// Dispose this request record:
FreeRequest(Request); // this uses a separate try..except
end;
//
// ... other cleanup in context of the thread...
//
except
// Main thread catcher.
end;
end;
function TWorkThread.PerformRequest(Req: PRequest): integer;
begin
if (Req<>nil) and Assigned(Req.Proc) then
Result:=Req.Proc(Req)
else
Result:=0;
end;
function TWorkThread.AllocRequest: PRequest;
begin
Result:=AllocMem(SizeOf(TRequest));
end;
procedure TWorkThread.FreeRequest(Req: PRequest);
begin
if (Req<>nil) then begin
try
Finalize(Req^); // ... if the Request contains strings...
FreeMem(Req);
except ; end;
end;
end;
function TWorkThread.EnqueueRequest(Request: PRequest): Boolean;
begin
// Called in main-thread context...
if (Request<>nil)
and (not Self.Terminated)
then begin
// Protect TList by critical-section:
EnterCriticalSection(FQueueLock);
try
FQueue.Add(Request);
finally
LeaveCriticalSection(FQueueLock);
end;
// Release the waiting thread:
if (FEvent<>0) then
SetEvent(FEvent);
//
Result:=True;
end else begin
// Cannot enqueue:
FreeRequest(Request);
Result:=False;
end;
end;
function TWorkThread.GetNextRequest(var Req: PRequest): Boolean;
begin
// Called in context of the thread to wait for another request...
Result:=True;
Req:=nil;
//
while True do begin
//FIdle:=False;
// Check for a waiting request:
EnterCriticalSection(FQueueLock);
try
if not Self.Terminated
and (FQueue<>nil)
then begin
if (FQueue.Count>0) then begin
// Get first request:
Req:=FQueue.Extract(FQueue.First);
end else begin
// Nothing in the queue...
ResetEvent(FEvent);
end;
end else begin
// Abort worker thread:
Result:=False;
end;
finally
LeaveCriticalSection(FQueueLock);
end;
// if request_found or failure:
if (Req<>nil) or (not Result) then
exit;
// Wait for another request:
FIdle:=True;
//
case WaitForSingleObject(FEvent,INFINITE) of
WAIT_OBJECT_0: begin
// Either new request, or termination:
FIdle:=False;
if Terminated then begin
Result:=False;
exit;
end;
//continue;
end;
WAIT_FAILED: begin
// FEvent handle is no more valid??
// Ignoring this will result in 99% CPU spent in thread-loop...
FIdle:=False;
Result:=False;
exit;
end;
else begin
// This should not happen, but for a case
// that someone forgets to reset the event,
// do not consume 99% CPU:
FIdle:=False;
Sleep(50);
end;
end;
end;
// ... unreachable
end;
procedure TWorkThread.CheckQueueCapa(AddCount: integer);
var Capa: integer;
begin
// Prevent multiple re-allocations during queue-list filling...
if (AddCount>0)
and (not Self.Terminated)
then begin
// Check, if need to re-allocate the list:
Capa:=FQueue.Count+AddCount;
if (Capa>FQueue.Capacity) then begin
// Protect TList by critical-section:
EnterCriticalSection(FQueueLock);
try
// Grow the list, if needed:
Capa:=FQueue.Count+AddCount; // recompute again...
if (Capa>FQueue.Capacity) then
FQueue.Capacity:=Capa;
finally
LeaveCriticalSection(FQueueLock);
end;
end;
end;
end;// (1286 b code)
V této ukázce:
function ExtractPtr(var Ptr): Pointer; assembler; asm // [EAX]->EAX xor edx,edx lock xchg [eax],edx mov eax,edx end;nebo ekvivalent v pascalu:
function ExtractPtr(var Ptr): Pointer; begin Result:=Pointer(InterlockedExchange(integer(Ptr),0)); end;což je ovšem o pár byte a o pár tiků delší a stejně to někde zavolá lock xchg...
function GenId(var NextID: integer): integer; begin Result:=NextID; NextID:=Result+1; end;Kdyby byl totiž thread přerušen právě mezi těmi dvěma řádkami, a jiný thread se mezitím pokusil o totéž, dostanou oba stejné ID...
function GenID(var NextID: integer): integer; asm mov edx,1 //lea eax,&NextID lock xadd dword ptr [eax],edx mov eax,edx // Result into EAX end;Instrukce xadd se vyskytuje až na 486... Předpokládáte, že Váš program bude fungovat na 386?? |
var NextID: integer; ... Result:=InterlockedExchangeAdd(NextID,1);Tato funkce je ovšem pouza na WinNT! Funkce InterlockedIncrement nevrací přesnou hodnotu! |
function ExtractPtr(var Ptr): Pointer; asm // [EAX]->EAX xor edx,edx // store 0 lock xchg [eax],edx // xchg: [eax]=edx, edx=orig value mov eax,edx // Result into EAX end; |
function ExtractPtr(var Ptr): Pointer;
begin
Result:=Pointer(
InterlockedExchange(integer(Ptr),0)
);
end;
|
function EnterBit(var Bits; Index: integer): Boolean; register; asm // EAX EDX ->AL lock bts [eax],edx setnc al // return True, if previous state of bit was 0... end;Pro tohle nemám ekvivalent v pascalu...
function NListLinkHead(var NListBase; Item: Pointer): Pointer; register; asm // [EAX] EDX ->EAX // Item.Next:=NListBase^; mov ecx,[eax] mov [edx],ecx // Temp:=Item; mov ecx,edx // NListBase^:=Temp; Temp:=orig(NListBase^); lock xchg [eax],ecx // Item.Next:=Temp; cmp edx,ecx je @skip_link mov [edx],ecx @skip_link: mov eax,edx end; |
Ekvivalent v pascalu:
type
PNListItem=^TNListItem;
TNListItem=record
Next: Pointer;
end;
function NListLinkHead(var NListBase; Item: Pointer): Pointer; register;
var Temp: Pointer;
begin
PNListItem(Item).Next:=Pointer(NListBase);
Temp:=InterlockedExchange(integer(NListBase),integer(Item));
if (Temp<>Item) then
PNListItem(Item).Next:=Temp;
end;
|
var
MmSystem: THandle=0;
MciSendStringA: function (lpstrCommand, lpstrReturnString: PAnsiChar;
uReturnLength: UINT; hWndCallback: HWND): Longint stdcall=nil;
function MciCommand(Cmd: PChar): Boolean;
var ECode: Longint;
begin
// Vyzvednutí funkce - jen poprvé:
if not Assigned(MciSendStringA) then begin
if (MmSystem=0) then begin
MmSystem:=LoadLibrary('winmm.dll');
if (MmSystem<=32) then begin
if (MmSystem=0) then
inc(MmSystem); // do not retry...
end else begin
@MciSendStringA:=GetProcAddress(MmSystem,'mciSendStringA');
end;
end;
if not Assigned(MciSendStringA) then begin
Result:=False;
exit;
end;
end;
// Odeslání příkazu MCI:
ECode:=MciSendStringA(Cmd,nil,0,0);
Result:=(ECode=0);
end;
function EjectCDThreadProc(Param: Pointer): Longint;
var Buffer: array[0..63] of char;
Drive: Char;
begin
try
Drive:=chr(integer(Param));
// Příkazy (včetně aliasu foo) opsány z Shell32.dll:
StrFmt(Buffer,'open %s: type cdaudio alias foo shareable',[Drive]);
if MciCommand(Buffer) then begin
MciCommand('set foo door open');
MciCommand('close foo');
end;
except
//Main thread catcher...
end;
Result:=0;
end;
procedure EjectCD(Drive: PChar);
var thh: THandle;
thid: Cardinal;
begin
if (Drive<>nil) and (UpCase(Drive^) in ['A'..'Z']) then begin
thh:=BeginThread(nil,0,@EjectCDThreadProc,Pointer(ord(Drive[0])),0,thid);
if (thh<>0) then
CloseHandle(thh);
end;
end;
procedure TFBrowser.mnEjectCdClick(Sender: TObject);
var Buffer: array[0..3] of char;
Label _ThisCD;
begin
StrCopy(Buffer,'C:\');
//
if (Self.Path<>'')
and (Self.Path[2]=':')
then begin
Buffer[0]:=Self.Path[1];
if (GetDriveType(Buffer)=DRIVE_CDROM) then
goto _ThisCD;
end;
// Find first CD:
Buffer[0]:='A';
repeat
if (GetDriveType(Buffer)=DRIVE_CDROM) then begin
// Found a CD:
_ThisCD:
EjectCD(Buffer);
exit;
end;
inc(Buffer[0]);
until (Buffer[0]>'Z');
// No CD found...
end;
Při umístění funkce v threadu nemusí aplikace čekat tuhá na její dokončení.
if Self.HandleAllocated then begin
Wnd:=Self.Handle;
if (GetCurrentThreadId=GetWindowThreadProcessId(Wnd,nil))
then begin
// Main thread:
RefreshListNow();
//
end else begin
// Other thread:
KillMessage(Wnd,CM_REFRESHLIST); // volá PeekMessage(...PM_REMOVE)
PostMessage(Wnd,CM_REFRESHLIST,0,0);
end;
end;
Tento kus kódu používám a ještě jsem nenarazil na problém.
Bez něj ovšem docházelo k problémům, když notification
přišlo v contextu work-threadu a formulář začal plnit list-box...
const
CM_RELOADCONFIG = WM_USER+1;
var
hWatchAbort: THandle;
WatchThreadId: Cardinal;
function FolderWatchThread(Param: Pointer): Longint;
var hNotify,H: THandle;
Events: array[0..1] of THandle;
begin
try
// Param is Path, allocated by StrNew...
try
// Setup abort event:
if (hWatchAbort=0) then
hWatchAbort:=CreateEvent(nil,True,False,nil);
//
// Setup notification:
hNotify:=FindFirstChangeNotification(PChar(Param),False,
FILE_NOTIFY_CHANGE_FILE_NAME or
FILE_NOTIFY_CHANGE_ATTRIBUTES or
FILE_NOTIFY_CHANGE_SIZE or
FILE_NOTIFY_CHANGE_LAST_WRITE);
// Succeeded?
if (hNotify<>INVALID_HANDLE_VALUE) then begin
try
// Loop for awaiting the next change...
while not Application.Terminated do begin
//
Events[0]:=hNotify;
Events[1]:=hWatchAbort;
//
case WaitForMultipleObjectsEx(1+ord(Events[1]<>0),
Pointer(@Events[0]),False,INFINITE)
of
WAIT_OBJECT_0: begin
// Something changed in the folder:
if (Application<>nil)
and (Application.MainForm<>nil)
and Application.MainForm.HandleAllocated
then
PostMessage(Application.MainForm.Handle,CM_RELOADCONFIG,0,0)
else
break; // no recipient?
//
Sleep(50);
// Re-setup the notification:
if not FindNextChangeNotification(hNotify) then
break; // notification error??
end;
WAIT_OBJECT_0+1: begin
// hWatchAbort event set...
break;
end;
else begin
// what else? - no timeout expected...
Sleep(100);
break; //? continue;
end;
end;
end;
finally
// Close notification handle:
FindCloseChangeNotification(hNotify);
end;
end;
finally
// Reset WatchThreadId var:
if (WatchThreadId=GetCurrentThreadId) then begin
WatchThreadId:=0;
// Close event handle:
H:=hWatchAbort;
hWatchAbort:=0;
CloseHandle(H);
end;
// Dispose path param:
StrDispose(Param);
end;
except
// Main thread catcher...
end;
Result:=0;
end;
function WatchConfigChange(const Path: string): Boolean;
var Param: PChar;
thh: THandle;
begin
// Called for ex. by MainForm.FormCreate...
Result:=False;
// Reset abort event:
if (hWatchAbort<>0) then
ResetEvent(hWatchAbort);
//
if (Path<>'')
and (WatchThreadId=0)
then begin
// Allocate thread param:
Param:=StrNew(PChar(Path));
// Create the thread:
thh:=BeginThread(nil,0,@FolderWatchThread,Param,CREATE_SUSPENDED,WatchThreadId);
if (thh<>0) then begin
// Start the thread:
ResumeThread(thh);
// Close thread handle:
CloseHandle(thh);
//
Result:=True;
end else begin
// Failed to start the thread - dispose param:
StrDispose(Path);
end;
end;
end;
function StopConfigChangeWatch: Boolean;
begin
// Called for ex. by MainForm.FormClose...
if (hWatchAbort<>0) then begin
// Release waiting thread:
SetEvent(hWatchAbort);
// Let the thread time to terminate:
if (WatchThreadId<>0) then
Sleep(50);
// Terminated?
Result:=(WatchThreadId=0);
end else
Result:=False;
end;
Poznámka - tento fragment kódu jsem psal jako ukázku
pro tento článek a nijak jsem to nezkoušel...
type
PGrLoadParams=^TGrLoadParams;
TGrLoadParams=record
FileName: string; // in
PreviewSize: TPoint; // in/out
Picture: TPicture; // out
Preview: TBitmap; // out
Error: string; // out
Wnd: HWND; // in - notify wnd
FormData: Pointer; // for caller use...
Index: integer; // for caller use...
Busy: Boolean; // =True if loading
end;
const
CM_GRLOADDONE = $7247; // LParam=PGrThreadParams
// Result=NewRequest or 0
function GrLoadThreadProc(Param: Pointer): Longint;
var glp: PGrLoadParams;
Ptr: Pointer;
FileName: string;
Pt: TPoint;
Label _RetryLoad,_DropPreview;
begin
try
_RetryLoad:
glp:=Param;
glp.Error:='';
try
glp.Busy:=True;
FileName:=glp.FileName;
// Create TPicture:
if (glp.Picture=nil) then
glp.Picture:=TPicture.Create;
// Load picture file:
// This may generate exception, if file format unknown:
glp.Picture.LoadFromFile(glp.FileName);
// Check, if should generate a preview:
if (glp.PreviewSize.x>0)
and (glp.PreviewSize.y>0)
and (glp.Picture.Graphic<>nil)
and not glp.Picture.Graphic.Empty
then begin
// Adjust preview-size to maintain aspect ratio:
Pt.x:=glp.Picture.Graphic.Width;
Pt.y:=glp.Picture.Graphic.Height;
if not MakePreviewSize(glp.PreviewSize,Pt) then
goto _DropPreview;
// Generate preview:
if (glp.Preview=nil) then
glp.Preview:=TBitmap.Create;
glp.Preview.Width:=glp.PreviewSize.x;
glp.Preview.Height:=glp.PreviewSize.y;
glp.Preview.Canvas.StretchDraw(
Rect(0,0,glp.PreviewSize.x,glp.PreviewSize.y),
glp.Picture.Graphic);
// Done...
end else begin
_DropPreview:
FreeAndNil(glp.Preview);
end;
except on E:Exception do begin
// Loading failed:
glp:=Param;
if IsBadWritePtr(glp,SizeOf(TGrLoadParams))
or (glp.Error<>'')
then begin
// Invalid Params record...
Result:=2;
exit;
end;
glp.Error:=E.Message;
FreeAndNil(glp.Picture);
end; end;
//
glp:=Param;
glp.Busy:=False;
// Signalize to GUI:
if (glp.Wnd<>0)
and IsWindow(glp.Wnd)
then begin
Ptr:=Pointer(SendMessage(glp.Wnd,CM_GRLOADDONE,0,Longint(glp)));
// Previous Param may have been released by form!
//
// Check another load request:
if (Longint(Ptr)>$10000)
and not IsBadWritePtr(Ptr,SizeOf(TGrLoadParams))
then begin
// Returned a pointer... Check load-request:
glp:=Ptr;
if (glp<>nil)
// Check file-name string:
and (glp.FileName<>'')
and not IsBadStringPtr(Pointer(glp.FileName),MAX_PATH*2)
and (integer(StrLen(Pointer(glp.FileName)))=Length(glp.FileName))
// Check diff file (diff glp record NOT checked - may reuse):
and not AnsiSameText(glp.FileName,FileName)
then begin
// Another request...
Param:=glp;
goto _RetryLoad;
end;
end;
end else
if (glp.Wnd<>0) then begin
// There was a window, but was destroyed... Free params:
FreeGrLoadParams(Params);
end;// else no window - caller will just test Busy later...
except
// Main thread catcher...
end;
Result:=0;
end;
function MakePreviewSize(var PreviewSize: TPoint; const ImageSize: TPoint): Boolean;
var rx,ry: Double;
begin
if (ImageSize.x>0) and (ImageSize.y>0) then begin
// Default preview size:
if (PreviewSize.x=0) then
PreviewSize.x:=120;
if (PreviewSize.y=0) then
PreviewSize.y:=80;
//
rx:=PreviewSize.x/ImageSize.x;
ry:=PreviewSize.y/ImageSize.y;
//
if (rx>ry) then
rx:=ry;
if (rx>1) then
rx:=1; // Do not generate larger preview than icon
//
PreviewSize.x:=Round(ImageSize.x*rx);
PreviewSize.y:=Round(ImageSize.y*rx);
//
Result:=(PreviewSize.x>0) and (PreviewSize.y>0);
end else
Result:=False;
end;
function StartGrLoader(Params: PGrLoadParams): Cardinal; //Boolean;
var thh: THandle;
thid: Cardinal;
begin
// Check valid params:
if (Params<>nil)
and ((Params.Wnd=0) or IsWindow(Params.Wnd))
then begin
// Start thread:
thh:=BeginThread(nil,0,@GrLoadThreadProc,Params,0,thid);
if (thh<>0) then begin
// ok.
CloseHandle(thh);
//Result:=True;
Result:=thid;
exit;
end;
end;
// something failed...
Result:=0; //False;
end;
procedure FreeGrLoadParams(Params: PGrLoadParams);
begin
try
FreeAndNil(Params.Picture);
FreeAndNil(Params.Preview);
Finalize(Params^);
FreeMem(Params);
except ; end;
end;// (41 b code without except, 83 b with except)
// (1046 b code total)
Tento thread načítá graphic ze souboru do TPicture a generuje
preview bitmapu...
...
private
FFiles: TStringList; // []=FileName, Objects[]=TBitmap preview...
FLoader: Cardinal; // Just to prevent more loader threads...
procedure CmGrLoadDone(var Msg: TMessage); message CM_GRLOADDONE;
procedure FolderChanged(Sender: TObject);
...
procedure TForm1.CmGrLoadDone(var Msg: TMessage);
var glp: PGrLoadParams;
Index: integer;
begin
if (Msg.LParam>$10000)
and not IsBadWritePtr(Pointer(Msg.LParam),SizeOf(TGrLoadParams))
then begin
// Previous request done:
glp:=Pointer(Msg.LParam);
if (glp.Picture is TPicture) then begin
// Load suceeded:
//...
Index:=FFiles.IndexOf(glp.FileName);
if (Index>=0)
and (FFiles.Objects[Index]=nil)
then begin
FFiles.Objects[Index]:=glp.Preview;
glp.Preview:=nil;
end;
end else
if (glp.Error<>'') then begin
// Load failed:
//...
// Without this will re-try the same image again:
FFiles.Objects[Index]:=TObject(-2); // or FFiles.Delete(Index);
end;
end else begin
// Clear invalid number - later just checking =0 :
Msg.LParam:=Msg.LParam and 0;
end;
//
// Check, if still missing some picture:
//
Index:=FFiles.IndexOfObject(nil);
//
if (Index>=0) then begin
// Request new image:
if (Msg.LParam=0) then begin
// Do not start second loader:
if (FLoader<>0) //? and IsValidGrLoader(FLoader)
then
exit;
// Alloc new params:
glp:=AllocMem(SizeOf(TGrLoadParams));
end else begin
// Re-use previous:
glp:=Pointer(Msg.LParam);
end;
//
glp.FileName:=FFiles[Index];
//glp.Preview:=nil; // re-use same TBitmap instead if not cleared...
//glp.Picture:=nil; // re-use same TPicture instead if not cleared...
//
// Pass back to thread:
Msg.Result:=Longint(glp);
// Check internal call:
if (Msg.WParam=1)
and (Msg.LParam=0)
then begin
// Start loader now:
Msg.Result:=Msg.Result and 0;
FLoader:=StartGrLoader(glp);
end;
end else begin
// Free params record, thread will stop now...
Msg.Result:=Msg.Result and 0;
glp:=Pointer(Msg.LParam);
if (glp<>nil) then begin
Msg.LParam:=Msg.LParam and 0;
FreeGrLoadParams(glp);
//
FLoader:=0;
end;
end;
end;
procedure TForm1.FolderChanged(Sender: TObject);
begin
// Start loader soon, if some image is missing:
if (FLoader=0) then
PostMessage(Self.Handle,CM_GRLOADDONE,1,0);
end;
library AutoUnload;
function UnloadDllProc(Param: Pointer): integer; stdcall;
begin
// Executed in different thread:
Sleep(100);
FreeLibraryAndExitThread(HInstance,0);
// unreachable...
Result:=0;
end;
procedure ScheduleUnload;
var thh: THandle;
thid: Cardinal;
begin
// The thread should be started after DLL loading
// has finished, not sooner...
//
thh:=CreateThread(nil,0,@UnloadDllProc,nil,0,thid);
CloseHandle(thh);
end;
procedure DllEntryPoint(Reason: integer);
begin
try
case Reason of
DLL_PROCESS_ATTACH: begin
//
ScheduleUnload;
//
DoThisOnLibraryLoad();
end;
end;
except
// prevent exceptions here...
end;
end;
// Main DLL proc:
begin
SysInit.DllProc:=@DllEntryPoint;
DllEntryPoint(DLL_PROCESS_ATTACH);
end.
Tento fragment kódu funguje, i když ještě po vytvoření threadu je spuštěno InputQuery
s dotazem uživateli... Spuštěný thread počká na návrat z DllEntryPoint...
function IsThreadRunning(ThreadHandle: THandle): Boolean;
var ECode: Cardinal;
begin
if GetExitCodeThread(ThreadHandle,ECode) then begin
// Until the thread terminates, this returns STILL_ACTIVE:
Result:=(ECode=STILL_ACTIVE);
//
end else begin
// Invalid handle...
Result:=False;
end;
end;
function IsThreadSuspended(ThreadHandle: Boolean): Boolean;
var Value: Longint;
begin
// Previous suspend-count is returned from SuspendThread
// Must NOT be called by the thread itself!
Value:=SuspendThread(ThreadHandle);
if (Value<>-1) then begin
ResumeThread(ThreadHandle);
//
Result:=(Value>0);
end else begin
// Bad handle or insufficient rights:
Result:=False;
end;
end;
function GetThreadAddress(ThreadHandle: THandle): Pointer;
var Context: Windows.TContext;
begin
Result:=nil;
// Bez nastavení bitu CONTEXT_i386 má funkce neblahý následek
// naplnění více informací a přepsání zásobníku!
Context.ContextFlags:=CONTEXT_CONTROL;
// Bez pozastavení threadu nelze zjistit context,
// pokud thread nečeká např. ve WaitMessage:
if (integer(SuspendThread(ThreadHandle))<>-1) then begin
//
if GetThreadContext(ThreadHandle,Context) then begin
Result:=Context.EIP;
end;
//
ResumeThread(ThreadHandle);
end;
end;
Tato funkce vrátí pointer na kód, který právě thread vykonává,
nebo nil, když to nelze zjistit...
function AbortThread(ThreadHandle: THandle): Boolean;
var Context: TContext;
pStack: PDWORD;
begin
Result:=False;
//
if (integer(SuspendThread(ThreadHandle))<>-1) then begin
try
// Get context of the thread:
Context.ContextFlags:=CONTEXT_FULL;
if GetThreadContext(ThreadHandle,Context) then begin
// Check NOT executing system code:
if (Cardinal(Context.Eip)<$70000000) then begin
// Simulate a call:
pStack:=Pointer(Context.Esp);
dec(pStack);
if not IsBadWritePtr(pStack,4) then begin
Context.Esp:=DWORD(pStack);
pStack^:=Context.Eip;
// Set new EIP address:
Context.Eip:=DWORD(@SysUtils.Abort);
// Set context:
Context.ContextFlags:=CONTEXT_CONTROL;
Result:=SetThreadContext(ThreadHandle,Context);
end;
end;
end;
finally
ResumeThread(ThreadHandle);
end;
end;
end;
Tohle by mělo fungovat, pokud jsou na handle dostatečná práva
a nečeká-li thread v systému...
function GetThreadSelfHandle(Access: Cardinal): THandle;
var hProc: THandle;
begin
hProc:=GetCurrentProcess;
if not DuplicateHandle(hProc,GetCurrentThread,hProc,Result,Access,False,0) then
Result:=0;
end;
Použije se to, je-li např. potřeba handle na hlavní thread aplikace,
protože ten nebyl spuštěn funkcí BeginThread, která by vrátila handle...const
THREAD_TERMINATE =$0001;
THREAD_SUSPEND_RESUME =$0002;
THREAD_GET_CONTEXT =$0008;
THREAD_SET_CONTEXT =$0010;
THREAD_SET_INFORMATION =$0020;
THREAD_QUERY_INFORMATION =$0040;
THREAD_SET_THREAD_TOKEN =$0080;
THREAD_IMPERSONATE =$0100;
THREAD_DIRECT_IMPERSONATION =$0200;
THREAD_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or
SYNCHRONIZE or
$3FF; // == $1F03FF;
Význam bitu $0004 jsem ve winnt.h nenašel, ale je definován v GENERIC_WRITE...
type
// Return True as found/stop, False to continue...
TCritSecEnumProc=function(Arg: Pointer; CritSec: PRtlCriticalSection): Boolean;
function EnumCriticalSections(const Enum: TCritSecEnumProc; Arg: Pointer): Pointer;
function IsValidCritSec(CritSec: PRtlCriticalSection): Boolean;
function IsLockedCritSec(CritSec: PRtlCriticalSection): Boolean;
function UnlockCritSec(CritSec: PRtlCriticalSection): Boolean;
function UnlockAllCritSecs: Boolean;
implementation
function SeekListEntryBack(ListEntry: PListEntry): PListEntry;
begin
if (ListEntry<>nil) then
while (ListEntry.BLink<>nil) do
ListEntry:=ListEntry.BLink;
Result:=ListEntry;
end;
function EnumCriticalSections(const Enum: TCritSecEnumProc; Arg: Pointer): Pointer;
var TempCs: TRtlCriticalSection;
csd,Acsd: PRTLCriticalSectionDebug;
begin
if not Assigned(Enum) then begin
Result:=nil;
exit;
end;
// Get a chain item:
InitializeCriticalSection(TempCs);
try
csd:=TempCs.DebugInfo;
if (csd<>nil) then begin
csd:=Pointer(Longint(SeekListEntryBack(@csd.ProcessLocksList))-8);
if (csd=TempCs.Debug) then begin
// Skip this one:
if (csd.ProcessLocksList.FLink=nil) then begin
Result:=csd.ProcessLocksList.FLink; //nil;
exit;
end;
csd:=Pointer(Longint(csd.ProcessLocksList.FLink)-8);
end;
end;
Acsd:=csd; // store to stack through finally...
finally
// Release a chain item:
DeleteCriticalSection(TempCs);
end;
//
try
csd:=Acsd;
while (csd<>nil) do begin
// Take Next before calling Enum-proc:
Acsd:=Pointer(Longint(csd.ProcessLocksList.FLink)-8);
//
if Enum(Arg,csd.CriticalSection) then begin
Result:=csd.CriticalSection;
exit;
end;
//
//csd:=Pointer(Longint(csd.ProcessLocksList.FLink)-8);
csd:=Acsd;
end;
except
//? list unexpectedly modified during walking?
end;
//
Result:=nil;
end;
function IsValidCritSec(CritSec: PRtlCriticalSection): Boolean;
begin
if (CritSec<>nil)
and not IsBadWritePtr(CritSec,SizeOf(TRtlCriticalSection))
and (CritSec.DebugInfo<>nil)
and not IsBadWritePtr(CritSec.DebugInfo,SizeOf(TRtlCriticalSectionDebug))
and (CritSec.DebugInfo.CriticalSection=CritSec)
then
Result:=True
else
Result:=False;
end;
function IsLockedCritSec(CritSec: PRtlCriticalSection): Boolean;
begin
if //(CritSec<>nil) and
IsValidCritSec(CritSec)
then
Result:=//(CritSec.LockCount<>-1) and/or
(CritSec.RecursionCount<>0)
else
Result:=False;
end;
function UnlockCritSec(CritSec: PRtlCriticalSection): Boolean;
var csd: PRtlCriticalSectionDebug;
begin
if IsLockedCritSec(CritSec) then begin
csd:=CritSec.DebugInfo;
if (csd<>nil) then begin
csd.EntryCount:=csd.EntryCount and 0;
csd.ContentionCount:=csd.ContentionCount and 0;
end;
CritSec.RecursionCount:=CritSec.RecursionCount and 0;
CritSec.OwningThread:=CritSec.OwningThread and 0;
CritSec.LockCount:=CritSec.LockCount or -1; // -1 if not locked...
//
if (CritSec.LockSemaphore<>0) then
Result:=SetEvent(CritSec.LockSemaphore) // NT uses auto-reset Event...
else
Result:=False;
end else
Result:=False;
end;
function CritSecUnlockProc(Arg: Pointer; CritSec: PRtlCriticalSection): Boolean;
var i: integer;
begin
if IsLockedCritSec(CritSec) then begin
// Check for a temporary condition:
i:=10;
repeat
Sleep(10);
if not IsLockedCritSec(CritSec) then
break;
dec(i);
until (i=0);
//
if (i=0) then begin
// Long-locked crit-sec found:
UnlockCritSec(CritSec);
Boolean(Arg^):=True;
end;
end;
//
Result:=False; // enum all...
end;
function UnlockAllCritSecs: Boolean;
var Tries: integer;
bnFound: Boolean;
begin
Result:=False;
Tries:=100;
repeat
bnFound:=False;
EnumCriticalSections(@CritSecUnlockProc,@bnFound);
Result:=Result or bnFound;
dec(Tries);
until (Tries=0) or (not bnFound);
end;
Tyto funkce využívají faktu, že všechny RTLCriticalSection jsou přes DebugInfo
spojeny do spojového seznamu funkcí InitializeCriticalSection...(c) Semi, 09/2004