소스 검색

* fix for Mantis #35028: when the mainthread executes a queued ThreadMethod make sure that the queue entry is released even if an exception is raised
+ added test

git-svn-id: trunk@41280 -

svenbarth 6 년 전
부모
커밋
1502a13e7c
3개의 변경된 파일38개의 추가작업 그리고 3개의 파일을 삭제
  1. 1 0
      .gitattributes
  2. 6 3
      rtl/objpas/classes/classes.inc
  3. 31 0
      tests/webtbs/tw35028.pp

+ 1 - 0
.gitattributes

@@ -16498,6 +16498,7 @@ tests/webtbs/tw3492.pp svneol=native#text/plain
 tests/webtbs/tw3494.pp svneol=native#text/plain
 tests/webtbs/tw34971.pp svneol=native#text/plain
 tests/webtbs/tw3499.pp svneol=native#text/plain
+tests/webtbs/tw35028.pp svneol=native#text/pascal
 tests/webtbs/tw3504.pp svneol=native#text/plain
 tests/webtbs/tw3506.pp svneol=native#text/plain
 tests/webtbs/tw3523.pp svneol=native#text/plain

+ 6 - 3
rtl/objpas/classes/classes.inc

@@ -308,9 +308,12 @@ begin
   if (GetCurrentThreadID = MainThreadID) and (not aQueueIfMain or not IsMultiThread) then
 {$endif}
   begin
-    ExecuteThreadQueueEntry(aEntry);
-    if not Assigned(aEntry^.SyncEvent) then
-      Dispose(aEntry);
+    try
+      ExecuteThreadQueueEntry(aEntry);
+    finally
+      if not Assigned(aEntry^.SyncEvent) then
+        Dispose(aEntry);
+    end;
 {$ifdef FPC_HAS_FEATURE_THREADING}
   end else begin
     { store thread and whether we're dealing with a synchronized event; the

+ 31 - 0
tests/webtbs/tw35028.pp

@@ -0,0 +1,31 @@
+{ %OPT=-gh }
+
+program tw35028;
+
+{$mode objfpc}
+
+uses
+{$ifdef unix}
+  cthreads,
+{$endif}
+  Classes;
+
+type
+  TTest = class
+    procedure Test;
+  end;
+
+procedure TTest.Test;
+begin
+  raise TObject.Create;
+end;
+
+var
+  t: TTest;
+begin
+  HaltOnNotReleased := True;
+  try
+    TThread.Queue(Nil, @t.Test);
+  except
+  end;
+end.