tw10897.pp 1.5 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182
  1. { %opt=-gh }
  2. program aIntfTest;
  3. {$ifdef fpc}
  4. {$mode delphi}
  5. {$endif}
  6. {$APPTYPE CONSOLE}
  7. uses
  8. SysUtils, Classes;
  9. type
  10. IMyIntf = interface
  11. ['{34326401-7B67-40FF-8E92-4587F65C8E24}']
  12. function GetOwner: IMyIntf;
  13. procedure Poing;
  14. end;
  15. type
  16. TMYClass = clasS(TinterfacedObject, IMyIntf)
  17. fRef: Integer;
  18. public
  19. function GetOwner: IMyIntf;
  20. function QueryInterface(constref IID: TGUID; out Obj): HRESULT; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  21. function _AddRef: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  22. function _Release: Integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
  23. procedure Poing;
  24. end;
  25. { TMYClass }
  26. function TMYClass._AddRef: Integer;
  27. begin
  28. inc(fRef);
  29. result := fRef;
  30. Writeln('AddRef:'+inttostr(result));
  31. end;
  32. function TMYClass._Release: Integer;
  33. begin
  34. Dec(fRef);
  35. result := FRef;
  36. Writeln('Release:'+inttostr(result));
  37. if result = 0 then Free;
  38. end;
  39. function TMYClass.GetOwner: IMyIntf;
  40. begin
  41. Writeln('GetOwner1');
  42. result := nil;
  43. Writeln('GetOwner2');
  44. end;
  45. function TMYClass.QueryInterface(constref IID: TGUID; out Obj): HRESULT;
  46. begin
  47. if GetInterface(IID, Obj) then
  48. result := S_OK else result := -1;
  49. end;
  50. var
  51. r: IMyIntf;
  52. procedure Test(x: IMyIntf);
  53. begin
  54. if x <> nil then x.Poing;
  55. x := x.GetOwner;
  56. if x <> nil then x.Poing;
  57. end;
  58. procedure TMYClass.Poing;
  59. begin
  60. writeln('poing');
  61. end;
  62. begin
  63. HaltOnNotReleased := true;
  64. r := TMYClass.Create;
  65. Test(r);
  66. Writeln('nil');
  67. r := nil;
  68. end.