AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Thema durchsuchen
Ansicht
Themen-Optionen

[Thread] Thread im Deadlock abschießen

Ein Thema von s.h.a.r.k · begonnen am 9. Okt 2008 · letzter Beitrag vom 10. Okt 2008
 
Benutzerbild von Flocke
Flocke

Registriert seit: 9. Jun 2005
Ort: Unna
1.172 Beiträge
 
Delphi 10.2 Tokyo Professional
 
#5

Re: [Thread] Thread im Deadlock abschießen

  Alt 10. Okt 2008, 16:56
Probier mal die folgenden Routinen, die Funktionsweise ist mir letztens eingefallen. Ich erzeuge einfach eine Exception in dem angegebenen Thread. Ist auch nicht 100%-ig sauber, aber immer noch besser als TerminateThread, besonders wenn die Dinge im Thread schön mit try..finally umklammert sind.

Delphi-Quellcode:
unit ThreadAbort;

interface

uses
  Windows, SysUtils, Classes;

{ These functions raise the given exception inside the given thread.
  The underscore variant simply returns False/True to indicate the success or
  failure of the action, while the other two raise an EOSError on that.
}

function _RaiseInThread(Which: THandle; E: Exception): Boolean;
procedure RaiseInThread(Which: THandle; E: Exception); overload;
procedure RaiseInThread(Which: TThread; E: Exception); overload;

{ These functions raise an EThreadAbort exception inside the given thread.
}

type
  EThreadAbort = class(Exception);

procedure AbortThread(Which: THandle; const Message: string = ''); overload;
procedure AbortThread(Which: TThread; const Message: string = ''); overload;

implementation

{ Raise an exception in the given thread.
}

function _RaiseInThread(Which: THandle; E: Exception): Boolean;
var
  Context: TContext;

  procedure Push(c: DWORD);
  begin
    Dec(Context.Esp, SizeOf(DWORD));
    PCardinal(Context.Esp)^ := c;
  end;

begin
  if Which = GetCurrentThread then
    raise E;

  Result := False;
  if SuspendThread(Which) = DWORD(-1) then
    Exit;
  try
    Context.ContextFlags := CONTEXT_CONTROL or CONTEXT_INTEGER;
    if not GetThreadContext(Which, Context) then
      Exit;

    { The following lines are copied from System.pas / _RaiseExcept,
      which (sadly) cannot be called directly. It uses the same calling
      convention since Delphi 3 (Delphi 2 uses a different signature).
    }

    Push(Context.Esp);
    Push(Context.Ebp);
    Push(Context.Edi);
    Push(Context.Esi);
    Push(Context.Ebx);
    Push(DWORD(E)); { pass class argument         }
    Push(Context.Eip); { pass address argument       }

    Push(Context.Esp); { pass pointer to arguments   }
    Push(7); { there are seven arguments   }
    Push(1); { cNonContinuable:  we can't continue execution }
    Push($0EEDFADE); { cDelphiException: our magic exception code    }
    Push(Context.Eip); { pass the return address     }

    {$IFDEF CONDITIONALEXPRESSIONS} // Delphi 6+
    Context.Eip := DWORD(RaiseExceptionProc);
    {$ELSE}
    Context.Eip := DWORD(@RaiseException);
    {$ENDIF}

    if SetThreadContext(Which, Context) then
      Result := True;
  finally
    if ResumeThread(Which) = DWORD(-1) then
      Result := False;
  end;
end;

procedure RaiseInThread(Which: THandle; E: Exception);
begin
  if not _RaiseInThread(Which, E) then
    RaiseLastOSError;
end;

procedure RaiseInThread(Which: TThread; E: Exception);
begin
  RaiseInThread(Which.Handle, E);
end;

procedure AbortThread(Which: THandle; const Message: string);
begin
  RaiseInThread(Which, EThreadAbort.Create(Message));
end;

procedure AbortThread(Which: TThread; const Message: string);
begin
  AbortThread(Which.Handle, Message);
end;

end.
Gib kurz Bescheid wenn was fehlt, ich habe den Code aus einer größeren Unit herauskopiert.
Volker
Besucht meine Garage
Aktuell: RtfLabel 1.3d, PrintToFile 1.4
  Mit Zitat antworten Zitat
 


Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 02:49 Uhr.
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024-2025 by Thomas Breitkreuz