paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-29 10:00:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

rtl: use CreateVCLComObject routing to create VCLComObject in case it is not assigned + test

Browse Source 
git-svn-id: trunk@14948 -
This commit is contained in:
paul 2010-02-27 08:49:50 +00:00
parent 9aa4504369
commit 8d7312f87b
4 changed files with 89 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -9360,6 +9360,7 @@ tests/test/umacpas1.pp svneol=native#text/plain
tests/test/umainnam.pp svneol=native#text/plain
tests/test/units/classes/tmakeobjinst.pp svneol=native#text/plain
tests/test/units/classes/tsetstream.pp svneol=native#text/plain
tests/test/units/classes/tvclcomobject.pp svneol=native#text/plain
tests/test/units/crt/tcrt.pp svneol=native#text/plain
tests/test/units/crt/tctrlc.pp svneol=native#text/plain
tests/test/units/dos/hello.pp svneol=native#text/plain

4
rtl/objpas/classes/classesh.inc
View File

@ -1873,8 +1873,8 @@ var
RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass);
{!!!! RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass;
AxRegType: TActiveXRegType) = nil;
CurrentGroup: Integer = -1;
CreateVCLComObjectProc: procedure(Component: TComponent) = nil;}
CurrentGroup: Integer = -1;}
CreateVCLComObjectProc: procedure(Component: TComponent) = nil;
{ Point and rectangle constructors }

12
rtl/objpas/classes/compon.inc
View File

@ -40,9 +40,17 @@ end;
function TComponent.GetComObject: IUnknown;
begin
{ Check if VCLComObject is not assigned - we need to create it by }
{ the call to CreateVCLComObject routine. If in the end we are still }
{ have no valid VCLComObject pointer we need to raise an exception }
if not Assigned(VCLComObject) then
raise EComponentError.Create(SNoComSupport);
// VCLComObject is IVCComObject but we need to return IUnknown
begin
if Assigned(CreateVCLComObjectProc) then
CreateVCLComObjectProc(Self);
if not Assigned(VCLComObject) then
raise EComponentError.CreateFmt(SNoComSupport,[Name]);
end;
{ VCLComObject is IVCComObject but we need to return IUnknown }
IVCLComObject(VCLComObject).QueryInterface(IUnknown, Result);
end;

76
tests/test/units/classes/tvclcomobject.pp Normal file
View File

@ -0,0 +1,76 @@
program vclcomobject;
{$IFDEF FPC}{$MODE DELPHI}{$ENDIF}
{$APPTYPE CONSOLE}
uses
SysUtils, Classes;
type
TDummyVCLComObject = class(TInterfacedObject, IVCLComObject)
public
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
function SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult; override;
procedure FreeOnRelease;
end;
var
c: TComponent;
v: IVCLComObject;
procedure DoCreateVCLComObject(Component: TComponent);
begin
Component.VCLComObject := Pointer(V);
end;
{ TDummyVCLComObject }
procedure TDummyVCLComObject.FreeOnRelease;
begin
end;
function TDummyVCLComObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TDummyVCLComObject.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
Result := E_NOTIMPL;
end;
function TDummyVCLComObject.GetTypeInfoCount(out Count: Integer): HResult;
begin
Result := E_NOTIMPL;
end;
function TDummyVCLComObject.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TDummyVCLComObject.SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult;
begin
Result := E_UNEXPECTED;
end;
begin
v := TDummyVCLComObject.Create;
CreateVCLComObjectProc := @DoCreateVCLComObject;
c := TComponent.Create(nil);
if c.ComObject = nil then
halt(1);
c.Free;
v := nil;
end.