paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-05 12:50:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Ludo Brands to fix late binding for com servers (bug 22378)

Browse Source 
git-svn-id: trunk@21874 -
This commit is contained in:
michael 2012-07-11 15:15:28 +00:00
parent 53186644a7
commit d28eeaee48
1 changed files with 39 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
packages/winunits-base/src/comobj.pp
View File

@ -216,6 +216,7 @@ unit comobj;
TTypedComObjectFactory = class(TComObjectFactory)
private
FClassInfo: ITypeInfo;
FTypeInfoCount:integer;
public
constructor Create(AComServer: TComServerObject; TypedComClass: TTypedComClass; const AClassID: TGUID;
AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle);
@ -241,9 +242,15 @@ unit comobj;
{ TAutoObjectFactory }
TAutoObjectFactory = class(TTypedComObjectFactory)
private
FDispIntfEntry: PInterfaceEntry;
FDispTypeInfo: ITypeInfo;
public
constructor Create(AComServer: TComServerObject; AutoClass: TAutoClass; const AClassID: TGUID;
AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle);
function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual;
property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
property DispTypeInfo: ITypeInfo read FDispTypeInfo;
end;
{ TAutoIntfObject }
@ -1477,6 +1484,7 @@ HKCR
OleCheck(FClassInfo.GetDocumentation(-1, @TypedName, @TypedDescription, nil, nil));
FClassInfo.GetTypeAttr(ppTypeAttr);
try
FTypeInfoCount := ppTypeAttr^.cImplTypes;
TypedVersion := '';
if (ppTypeAttr^.wMajorVerNum <> 0) or (ppTypeAttr^.wMinorVerNum <> 0) then
begin
@ -1493,9 +1501,22 @@ HKCR
function TTypedComObjectFactory.GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo;
var
index, ImplTypeFlags: Integer;
RefType: HRefType;
begin
Result := nil;
for index := 0 to FTypeInfoCount - 1 do
begin
RunError(217);
OleCheck(ClassInfo.GetImplTypeFlags(index, ImplTypeFlags));
if ImplTypeFlags = TypeFlags then
begin
OleCheck(ClassInfo.GetRefTypeOfImplType(index, RefType));
OleCheck(ClassInfo.GetRefTypeInfo(RefType, Result));
break;
end;
end;
end;
procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean);
@ -1677,10 +1698,9 @@ HKCR
Result := DISP_E_UNKNOWNINTERFACE
else
begin
// Function Invoke(pvInstance: Pointer; memid: MEMBERID; wFlags: WORD; VAR pDispParams: DISPPARAMS; OUT pVarResult: VARIANT; OUT pExcepInfo: EXCEPINFO; OUT puArgErr: UINT):HResult;StdCall;
// Result := fTypeInfo.Invoke(IDispatch(Self), DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
OleCheck(QueryInterface(TAutoObjectFactory(Factory).ClassID, fInterfacePointer));
Result := TAutoObjectFactory(Factory).ClassInfo.Invoke(fInterfacePointer, DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
Result := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer(
Integer(Self) + TAutoObjectFactory(Factory).DispIntfEntry^.IOffset),
DispID, Flags, TDispParams(Params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
end;
end;
@ -1689,10 +1709,24 @@ HKCR
constructor TAutoObjectFactory.Create(AComServer: TComServerObject;
AutoClass: TAutoClass; const AClassID: TGUID; AInstancing: TClassInstancing;
AThreadingModel: TThreadingModel);
var
ppTypeAttr: lpTYPEATTR;
begin
inherited Create(AComServer, AutoClass, AClassID, AInstancing, AThreadingModel);
FDispTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT);
OleCheck(FDispTypeInfo.GetTypeAttr(ppTypeAttr));
try
FDispIntfEntry := GetIntfEntry(ppTypeAttr^.guid);
finally
FDispTypeInfo.ReleaseTypeAttr(ppTypeAttr);
end;
end;
function TAutoObjectFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry;
begin
Result := FComClass.GetInterfaceEntry(Guid);
end;
procedure TOleStream.Check(err:integer);
begin