Browse Source

* hopefully fpc_intf_assign_by_iid improved

git-svn-id: trunk@5842 -
florian 18 years ago
parent
commit
4c7c5e5adf
3 changed files with 46 additions and 4 deletions
  1. 1 0
      .gitattributes
  2. 16 4
      rtl/inc/objpas.inc
  3. 29 0
      tests/webtbs/tw6868.pp

+ 1 - 0
.gitattributes

@@ -7904,6 +7904,7 @@ tests/webtbs/tw6735.pp svneol=native#text/plain
 tests/webtbs/tw6742.pp svneol=native#text/plain
 tests/webtbs/tw6742.pp svneol=native#text/plain
 tests/webtbs/tw6767.pp svneol=native#text/plain
 tests/webtbs/tw6767.pp svneol=native#text/plain
 tests/webtbs/tw6865.pp svneol=native#text/plain
 tests/webtbs/tw6865.pp svneol=native#text/plain
+tests/webtbs/tw6868.pp svneol=native#text/plain
 tests/webtbs/tw6960.pp svneol=native#text/plain
 tests/webtbs/tw6960.pp svneol=native#text/plain
 tests/webtbs/tw6977.pp svneol=native#text/plain
 tests/webtbs/tw6977.pp svneol=native#text/plain
 tests/webtbs/tw6980.pp svneol=native#text/plain
 tests/webtbs/tw6980.pp svneol=native#text/plain

+ 16 - 4
rtl/inc/objpas.inc

@@ -78,13 +78,25 @@
       end;
       end;
 
 
     procedure fpc_intf_assign_by_iid(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_ASSIGN2']; compilerproc;
     procedure fpc_intf_assign_by_iid(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_ASSIGN2']; compilerproc;
+      var
+        tmp : pointer;
       begin
       begin
-         if assigned(D) then
-           IUnknown(D)._Release;
          if assigned(S) then
          if assigned(S) then
-           IUnknown(S).QueryInterface(iid, D)
+           begin
+             if IUnknown(S).QueryInterface(iid,tmp)<>S_OK then
+               handleerror(219);  
+             if assigned(tmp) then             
+               IUnknown(tmp)._AddRef;
+             if assigned(D) then
+               IUnknown(D)._Release;
+             D:=tmp;
+           end
          else
          else
-           D := nil;
+           begin
+             if assigned(D) then
+               IUnknown(D)._Release;
+             D:=nil;
+           end;
       end;
       end;
 
 
 
 

+ 29 - 0
tests/webtbs/tw6868.pp

@@ -0,0 +1,29 @@
+program project1;
+{$mode objfpc}{$H+}
+
+uses Classes, SysUtils;
+
+type IHelpSystem = interface(IInterface) end;
+     THelpManager = class(TInterfacedObject, IHelpSystem) end;
+
+var HelpManager : THelpManager = nil;
+function GetHelpSystem(out H: IHelpSystem) : Integer;
+begin
+  if HelpManager = nil then HelpManager := THelpManager.Create; // if help manager is not created here, it works
+  H := HelpManager;  // <-- remove this and it works
+  result := 0;
+end;
+
+procedure FreeHelpSystem;
+begin
+  if HelpManager <> nil then
+    HelpManager._Release;
+  HelpManager := nil;
+end;
+
+var h : IHelpSystem;
+begin
+  GetHelpSystem(h);
+  FreeHelpSystem;
+end.
+