mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 08:09:33 +02:00
* first partially working implementation of variant com invoking
git-svn-id: trunk@5247 -
This commit is contained in:
florian
parent
0925ed13e9
commit
a13d358f1e
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -4002,6 +4002,7 @@ packages/extra/winunits/Makefile svneol=native#text/plain
|
||||
packages/extra/winunits/Makefile.fpc svneol=native#text/plain
|
||||
packages/extra/winunits/activex.pp svneol=native#text/plain
|
||||
packages/extra/winunits/buildjwa.pp svneol=native#text/plain
|
||||
packages/extra/winunits/comconst.pp svneol=native#text/plain
|
||||
packages/extra/winunits/commctrl.pp svneol=native#text/plain
|
||||
packages/extra/winunits/comobj.pp svneol=native#text/plain
|
||||
packages/extra/winunits/examples/testver.pp svneol=native#text/plain
|
||||
|
||||
@ -1235,6 +1235,12 @@ implementation
|
||||
CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
|
||||
exit;
|
||||
end;
|
||||
dataconstn:
|
||||
begin
|
||||
{ only created internally, so no additional checks necessary }
|
||||
result:=true;
|
||||
exit;
|
||||
end;
|
||||
loadn :
|
||||
begin
|
||||
case tloadnode(hp).symtableentry.typ of
|
||||
|
||||
@ -171,7 +171,7 @@ interface
|
||||
tcallparanodeclass = class of tcallparanode;
|
||||
|
||||
function reverseparameters(p: tcallparanode): tcallparanode;
|
||||
function translate_vardisp_call(p1,p2 : tnode) : tnode;
|
||||
function translate_vardisp_call(p1,p2 : tnode;methodname : ansistring) : tnode;
|
||||
|
||||
var
|
||||
ccallnode : tcallnodeclass;
|
||||
@ -223,7 +223,7 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
function translate_vardisp_call(p1,p2 : tnode) : tnode;
|
||||
function translate_vardisp_call(p1,p2 : tnode;methodname : ansistring) : tnode;
|
||||
const
|
||||
DISPATCH_METHOD = $1;
|
||||
DISPATCH_PROPERTYGET = $2;
|
||||
@ -242,21 +242,32 @@ implementation
|
||||
paracount : longint;
|
||||
vardatadef,
|
||||
pvardatadef : tdef;
|
||||
dispatchbyref : boolean;
|
||||
|
||||
calldesc : packed record
|
||||
calltype,argcount,namedargcount : byte;
|
||||
{ size of argtypes is unknown at compile time
|
||||
so this is basically a dummy }
|
||||
argtypes : array[0..255] of byte;
|
||||
{ argtypes is followed by method name
|
||||
names of named parameters, each being
|
||||
a zero terminated string
|
||||
}
|
||||
end;
|
||||
names : ansistring;
|
||||
|
||||
procedure increase_paramssize;
|
||||
begin
|
||||
{ for now we pass everything by reference
|
||||
case para.value.resultdef.typ of
|
||||
variantdef:
|
||||
inc(paramssize,para.value.resultdef.size);
|
||||
else
|
||||
}
|
||||
inc(paramssize,sizeof(voidpointertype.size ));
|
||||
{
|
||||
end;
|
||||
}
|
||||
end;
|
||||
|
||||
begin
|
||||
@ -318,6 +329,7 @@ implementation
|
||||
{ build up parameters and description }
|
||||
para:=tcallparanode(p2);
|
||||
currargpos:=0;
|
||||
paramssize:=0;
|
||||
while assigned(para) do
|
||||
begin
|
||||
if assigned(para.parametername) then
|
||||
@ -327,14 +339,25 @@ implementation
|
||||
else
|
||||
internalerror(200611041);
|
||||
end;
|
||||
|
||||
dispatchbyref:=para.value.resultdef.typ in [stringdef];
|
||||
{ assign the argument/parameter to the temporary location }
|
||||
|
||||
if para.value.nodetype<>nothingn then
|
||||
addstatement(statements,cassignmentnode.create(
|
||||
ctypeconvnode.create_internal(cderefnode.create(caddnode.create(addn,
|
||||
caddrnode.create(ctemprefnode.create(params)),
|
||||
cordconstnode.create(paramssize,ptrinttype,false)
|
||||
)),para.value.resultdef),
|
||||
para.value));
|
||||
)),voidpointertype),
|
||||
ctypeconvnode.create_internal(para.value,voidpointertype)));
|
||||
|
||||
if is_ansistring(para.value.resultdef) then
|
||||
calldesc.argtypes[currargpos]:=varStrArg
|
||||
else
|
||||
calldesc.argtypes[currargpos]:=para.value.resultdef.getvardef;
|
||||
|
||||
if dispatchbyref then
|
||||
calldesc.argtypes[currargpos]:=calldesc.argtypes[currargpos] or $80;
|
||||
|
||||
increase_paramssize;
|
||||
|
||||
@ -343,10 +366,15 @@ implementation
|
||||
para:=tcallparanode(para.nextpara);
|
||||
end;
|
||||
|
||||
// typecheckpass(statements);
|
||||
// printnode(output,statements);
|
||||
|
||||
{ old argument list skeleton isn't needed anymore }
|
||||
p2.free;
|
||||
|
||||
calldescnode.append(calldesc,4+calldesc.argcount);
|
||||
calldescnode.append(calldesc,3+calldesc.argcount);
|
||||
methodname:=methodname+#0;
|
||||
calldescnode.append(pointer(methodname)^,length(methodname));
|
||||
calldescnode.append(pointer(names)^,length(names));
|
||||
|
||||
{ actual call }
|
||||
@ -356,7 +384,7 @@ implementation
|
||||
addstatement(statements,ccallnode.createintern('fpc_dispinvoke_variant',
|
||||
{ parameters are passed always reverted, i.e. the last comes first }
|
||||
ccallparanode.create(caddrnode.create(ctemprefnode.create(params)),
|
||||
ccallparanode.create(calldescnode,
|
||||
ccallparanode.create(caddrnode.create(calldescnode),
|
||||
ccallparanode.create(ctypeconvnode.create_internal(p1,vardatadef),
|
||||
ccallparanode.create(ctypeconvnode.create_internal(caddrnode.create(
|
||||
ctemprefnode.create(result_data)
|
||||
|
||||
@ -1221,10 +1221,16 @@ implementation
|
||||
|
||||
function ttypeconvnode.typecheck_variant_to_interface : tnode;
|
||||
begin
|
||||
result := ccallnode.createinternres(
|
||||
'fpc_variant_to_interface',
|
||||
ccallparanode.create(left,nil)
|
||||
,resultdef);
|
||||
if tobjectdef(resultdef).is_related(tobjectdef(search_system_type('IDISPATCH').typedef)) then
|
||||
result := ccallnode.createinternres(
|
||||
'fpc_variant_to_idispatch',
|
||||
ccallparanode.create(left,nil)
|
||||
,resultdef)
|
||||
else
|
||||
result := ccallnode.createinternres(
|
||||
'fpc_variant_to_interface',
|
||||
ccallparanode.create(left,nil)
|
||||
,resultdef);
|
||||
typecheckpass(result);
|
||||
left:=nil;
|
||||
end;
|
||||
@ -1232,10 +1238,16 @@ implementation
|
||||
|
||||
function ttypeconvnode.typecheck_interface_to_variant : tnode;
|
||||
begin
|
||||
result := ccallnode.createinternres(
|
||||
'fpc_interface_to_variant',
|
||||
ccallparanode.create(left,nil)
|
||||
,resultdef);
|
||||
if tobjectdef(left.resultdef).is_related(tobjectdef(search_system_type('IDISPATCH').typedef)) then
|
||||
result := ccallnode.createinternres(
|
||||
'fpc_idispatch_to_variant',
|
||||
ccallparanode.create(left,nil)
|
||||
,resultdef)
|
||||
else
|
||||
result := ccallnode.createinternres(
|
||||
'fpc_interface_to_variant',
|
||||
ccallparanode.create(left,nil)
|
||||
,resultdef);
|
||||
typecheckpass(result);
|
||||
left:=nil;
|
||||
end;
|
||||
|
||||
@ -2182,7 +2182,8 @@ begin
|
||||
exclude(init_settings.globalswitches,cs_link_strip);
|
||||
|
||||
{ force fpu emulation on arm/wince and arm/gba }
|
||||
if target_info.system in [system_arm_wince,system_arm_gba,system_m68k_amiga] then
|
||||
if target_info.system in [system_arm_wince,system_arm_gba,system_m68k_amiga,
|
||||
system_m68k_linux] then
|
||||
include(init_settings.moduleswitches,cs_fp_emulation);
|
||||
|
||||
{ Section smartlinking conflicts with import sections on Windows }
|
||||
|
||||
@ -1860,6 +1860,9 @@ implementation
|
||||
srsym : tsym;
|
||||
srsymtable : TSymtable;
|
||||
classh : tobjectdef;
|
||||
{ shouldn't be used that often, so the extra overhead is ok to save
|
||||
stack space }
|
||||
dispatchstring : ansistring;
|
||||
label
|
||||
skipreckklammercheck;
|
||||
begin
|
||||
@ -2049,12 +2052,13 @@ implementation
|
||||
{ dispatch call? }
|
||||
if token=_ID then
|
||||
begin
|
||||
dispatchstring:=orgpattern;
|
||||
consume(_ID);
|
||||
if try_to_consume(_LKLAMMER) then
|
||||
begin
|
||||
p2:=parse_paras(false,true,_RKLAMMER);
|
||||
consume(_RKLAMMER);
|
||||
p1:=translate_vardisp_call(p1,p2);
|
||||
p1:=translate_vardisp_call(p1,p2,dispatchstring);
|
||||
end
|
||||
else
|
||||
p2:=nil;
|
||||
|
||||
@ -507,6 +507,7 @@ interface
|
||||
function is_publishable : boolean;override;
|
||||
function alignment : shortint;override;
|
||||
function needs_inittable : boolean;override;
|
||||
function getvardef:longint;override;
|
||||
end;
|
||||
|
||||
tenumdef = class(tstoreddef)
|
||||
@ -1215,6 +1216,15 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
function tstringdef.getvardef : longint;
|
||||
const
|
||||
vardef : array[tstringtype] of longint = (
|
||||
varUndefined,varUndefined,varString,varOleStr);
|
||||
begin
|
||||
result:=vardef[stringtype];
|
||||
end;
|
||||
|
||||
|
||||
function tstringdef.alignment : shortint;
|
||||
begin
|
||||
case stringtype of
|
||||
|
||||
@ -1400,21 +1400,27 @@ TYPE
|
||||
cNamedArgs : UINT;
|
||||
End;
|
||||
DISPPARAMS = tagDISPPARAMS;
|
||||
TDispParams = tagDISPPARAMS;
|
||||
PDispParams = ^TDispParams;
|
||||
|
||||
PExcepInfo = ^TExcepInfo;
|
||||
TFNDeferredFillIn = function(info : PExcepInfo): HRESULT;stdcall;
|
||||
tagEXCEPINFO = Record
|
||||
wCode, // An error code describing the error.
|
||||
wReserved : Word;
|
||||
Source, // A source of the exception
|
||||
Description, // A description of the error
|
||||
HelpFile : WideString; // Fully qualified drive, path, and file name
|
||||
dwHelpContext : DWord; // help context of topic within the help file
|
||||
dwHelpContext : ULONG; // help context of topic within the help file
|
||||
// We can use ULONG_PTR here, because EXCEPINFO is marshalled by RPC
|
||||
// RPC will marshal pfnDeferredFillIn.
|
||||
pvReserved,
|
||||
pfnDeferredFillIn : pULONG;
|
||||
pvReserved : pointer;
|
||||
pfnDeferredFillIn : TFNDeferredFillIn;
|
||||
SCODE : scode;
|
||||
End;
|
||||
|
||||
EXCEPINFO = tagEXCEPINFO;
|
||||
TExcepInfo = tagEXCEPINFO;
|
||||
|
||||
tagTYPEATTR = Record
|
||||
GUID : Tguid; // the GUID of the TypeInfo
|
||||
@ -3286,7 +3292,16 @@ type
|
||||
function SetErrorInfo(dwReserved:ULONG;errinfo:IErrorInfo):HResult;stdcall; external 'ole32.dll' name 'SetErrorInfo';
|
||||
function GetErrorInfo(dwReserved:ULONG;out errinfo:IErrorInfo):HResult;stdcall; external 'ole32.dll' name 'GetErrorInfo';
|
||||
function CreateErrorInfo(out errinfo:ICreateErrorInfo):HResult;stdcall; external 'ole32.dll' name 'CreateErrorInfo';
|
||||
|
||||
|
||||
const
|
||||
oleaut32dll = 'oleaut32.dll';
|
||||
|
||||
function SysAllocString(psz: pointer): Integer; external oleaut32dll name 'SysAllocString';
|
||||
function SysAllocStringLen(psz: pointer; len:dword): Integer; external oleaut32dll name 'SysAllocStringLen';
|
||||
procedure SysFreeString(bstr:pointer); external oleaut32dll name 'SysFreeString';
|
||||
function SysStringLen(bstr:pointer):UINT; external oleaut32dll name 'SysStringLen';
|
||||
function SysReAllocString(var bstr:pointer;psz: pointer): Integer; external oleaut32dll name 'SysReAllocString';
|
||||
function SysReAllocStringLen(var bstr:pointer;psz: pointer; len:dword): Integer; external oleaut32dll name 'SysReAllocStringLen';
|
||||
|
||||
implementation
|
||||
|
||||
|
||||
29
packages/extra/winunits/comconst.pp
Normal file
29
packages/extra/winunits/comconst.pp
Normal file
@ -0,0 +1,29 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2006 by Florian Klaempfl
|
||||
member of the Free Pascal development team.
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}
|
||||
{$H+}
|
||||
{$inline on}
|
||||
unit comconst;
|
||||
|
||||
interface
|
||||
|
||||
resourcestring
|
||||
SNoMethod = 'Method ''%s'' is not supported by automation object';
|
||||
SOleError = 'OLE error %.8x';
|
||||
SVarNotObject = 'Variant does not reference an automation object';
|
||||
|
||||
implementation
|
||||
|
||||
end.
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
{
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2002 by Florian Klaempfl
|
||||
Copyright (c) 2006 by Florian Klaempfl
|
||||
member of the Free Pascal development team.
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
@ -106,10 +106,14 @@ unit comobj;
|
||||
|
||||
function ProgIDToClassID(const id : string) : TGUID;
|
||||
|
||||
implementation
|
||||
procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
|
||||
DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
|
||||
procedure DispatchInvokeError(Status: HRESULT; const ExceptInfo: TExcepInfo);
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
windows;
|
||||
Windows,Types,Variants,ComConst;
|
||||
|
||||
constructor EOleSysError.Create(const Msg: string; aErrorCode: HRESULT; aHelpContext: Integer);
|
||||
var
|
||||
@ -211,6 +215,224 @@ unit comobj;
|
||||
end;
|
||||
|
||||
|
||||
procedure DispatchInvokeError(Status: HRESULT; const ExceptInfo: TExcepInfo);
|
||||
begin
|
||||
if Status=DISP_E_EXCEPTION then
|
||||
raise EOleException.Create(ExceptInfo.Description,ExceptInfo.scode,ExceptInfo.Source,
|
||||
ExceptInfo.HelpFile,ExceptInfo.dwHelpContext)
|
||||
else
|
||||
raise EOleSysError.Create('',Status,0);
|
||||
end;
|
||||
|
||||
{$define DEBUG_COMDISPATCH}
|
||||
procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
|
||||
DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
|
||||
|
||||
var
|
||||
{ we can't pass pascal ansistrings to COM routines so we've to convert them
|
||||
to/from widestring. This array contains the mapping to do so
|
||||
}
|
||||
StringMap : array[0..255] of record passtr : pansistring; comstr : pwidechar; end;
|
||||
invokekind,
|
||||
i : longint;
|
||||
invokeresult : HResult;
|
||||
exceptioninfo : TExcepInfo;
|
||||
dispparams : TDispParams;
|
||||
NextString : SizeInt;
|
||||
Arguments : array[0..255] of TVarData;
|
||||
CurrType : byte;
|
||||
MethodID : TDispID;
|
||||
begin
|
||||
NextString:=0;
|
||||
fillchar(dispparams,sizeof(dispparams),0);
|
||||
try
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('Got ',CallDesc^.ArgCount,' arguments');
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
{ copy and prepare arguments }
|
||||
for i:=0 to CallDesc^.ArgCount-1 do
|
||||
begin
|
||||
{ get plain type }
|
||||
CurrType:=CallDesc^.ArgTypes[i] and $3f;
|
||||
{ by reference? }
|
||||
if (CallDesc^.ArgTypes[i] and $80)<>0 then
|
||||
begin
|
||||
case CurrType of
|
||||
varStrArg:
|
||||
begin
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('Translating var ansistring argument ',PString(Params^)^);
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
StringMap[NextString].ComStr:=StringToOleStr(PString(Params^)^);
|
||||
StringMap[NextString].PasStr:=PString(Params^);
|
||||
Arguments[i].VType:=varOleStr or varByRef;
|
||||
Arguments[i].VPointer:=StringMap[NextString].ComStr;
|
||||
inc(NextString);
|
||||
inc(PPointer(Params));
|
||||
end;
|
||||
varVariant:
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('Unimplemented ref variant dispatch');
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
else
|
||||
begin
|
||||
writeln('Got ref argument with type ',CurrType);
|
||||
Arguments[i].VType:=CurrType or VarByRef;
|
||||
Arguments[i].VPointer:=PPointer(Params)^;
|
||||
inc(PPointer(Params));
|
||||
end;
|
||||
end
|
||||
end
|
||||
else
|
||||
case CurrType of
|
||||
varStrArg:
|
||||
begin
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('Translating ansistring argument ',PString(Params)^);
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
StringMap[NextString].ComStr:=StringToOleStr(PString(Params)^);
|
||||
StringMap[NextString].PasStr:=nil;
|
||||
Arguments[i].VType:=varOleStr;
|
||||
Arguments[i].VPointer:=StringMap[NextString].ComStr;
|
||||
inc(NextString);
|
||||
inc(PPointer(Params));
|
||||
end;
|
||||
|
||||
varVariant:
|
||||
begin
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('Unimplemented variant dispatch');
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
end;
|
||||
varCurrency,
|
||||
varDouble,
|
||||
VarDate:
|
||||
begin
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('Got 8 byte float argument');
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
Arguments[i].VType:=CurrType;
|
||||
move(PPointer(Params)^,Arguments[i].VDouble,sizeof(Double));
|
||||
inc(PDouble(Params));
|
||||
end;
|
||||
else
|
||||
begin
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('Got argument with type ',CurrType);
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
Arguments[i].VType:=CurrType;
|
||||
Arguments[i].VPointer:=PPointer(Params)^;
|
||||
inc(PPointer(Params));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ finally prepare the call }
|
||||
with DispParams do
|
||||
begin
|
||||
rgvarg:=@Arguments;
|
||||
rgdispidNamedArgs:=@DispIDs[1];
|
||||
cArgs:=CallDesc^.ArgCount;
|
||||
cNamedArgs:=CallDesc^.NamedArgCount;
|
||||
end;
|
||||
InvokeKind:=CallDesc^.CallType;
|
||||
MethodID:=DispIDs^[0];
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('MethodID: ',MethodID);
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
{ do the call and check the result }
|
||||
invokeresult:=Dispatch.Invoke(MethodID,GUID_NULL,0,InvokeKind,DispParams,result,@exceptioninfo,nil);;
|
||||
if invokeresult<>0 then
|
||||
DispatchInvokeError(invokeresult,exceptioninfo);
|
||||
|
||||
{ translate strings back }
|
||||
for i:=0 to NextString-1 do
|
||||
if assigned(StringMap[i].passtr) then
|
||||
OleStrToStrVar(StringMap[i].comstr,StringMap[i].passtr^);
|
||||
finally
|
||||
for i:=0 to NextString-1 do
|
||||
SysFreeString(StringMap[i].ComStr);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure SearchIDs(const DispatchInterface : IDispatch; Names: PChar;
|
||||
Count: Integer; IDs: PDispIDList);
|
||||
var
|
||||
res : HRESULT;
|
||||
NamesArray : ^PWideChar;
|
||||
NamesData : PWideChar;
|
||||
NameCount,
|
||||
NameLen,
|
||||
NewNameLen,
|
||||
CurrentNameDataUsed,
|
||||
CurrentNameDataSize : SizeInt;
|
||||
i : longint;
|
||||
begin
|
||||
getmem(NamesArray,Count*sizeof(PWideChar));
|
||||
CurrentNameDataSize:=256;
|
||||
CurrentNameDataUsed:=0;
|
||||
getmem(NamesData,CurrentNameDataSize*2);
|
||||
NameCount:=0;
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('SearchIDs: Searching ',Count,' IDs');
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
for i:=1 to Count do
|
||||
begin
|
||||
NameLen:=strlen(Names);
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('SearchIDs: Original name: ',Names,' Len: ',NameLen);
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
NewNameLen:=MultiByteToWideChar(0,0,Names,NameLen,nil,0)+1;
|
||||
if CurrentNameDataUsed+NewNameLen*2>CurrentNameDataSize then
|
||||
begin
|
||||
inc(CurrentNameDataSize,256);
|
||||
reallocmem(NamesData,CurrentNameDataSize*2);
|
||||
end;
|
||||
NamesArray[i-1]:=@NamesData[CurrentNameDataUsed];
|
||||
MultiByteToWideChar(0,0,Names,NameLen,@NamesData[CurrentNameDataUsed],NewNameLen);
|
||||
NamesData[CurrentNameDataUsed+NewNameLen-1]:=#0;
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
{ we should write a widestring here writeln('SearchIDs: Translated name: ',NamesData[CurrentNameDataUsed]); }
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
inc(CurrentNameDataUsed,NewNameLen);
|
||||
inc(Names,NameLen+1);
|
||||
inc(NameCount);
|
||||
end;
|
||||
res:=DispatchInterface.GetIDsOfNames(GUID_NULL,NamesArray,NameCount,GetThreadLocale,IDs);
|
||||
if res=DISP_E_UNKNOWNNAME then
|
||||
raise EOleError.createresfmt(@snomethod,[names])
|
||||
else
|
||||
OleCheck(res);
|
||||
freemem(NamesArray);
|
||||
freemem(NamesData);
|
||||
end;
|
||||
|
||||
|
||||
procedure ComObjDispatchInvoke(dest : PVariant;const source : Variant;
|
||||
calldesc : pcalldesc;params : pointer);cdecl;
|
||||
var
|
||||
dispatchinterface : pointer;
|
||||
ids : array[0..255] of longint;
|
||||
begin
|
||||
{$ifdef DEBUG_COMDISPATCH}
|
||||
writeln('ComObjDispatchInvoke called');
|
||||
writeln('ComObjDispatchInvoke: CallDesc^.ArgCount = ',CallDesc^.ArgCount);
|
||||
{$endif DEBUG_COMDISPATCH}
|
||||
if tvardata(source).vtype=VarDispatch then
|
||||
dispatchinterface:=tvardata(source).vdispatch
|
||||
else if tvardata(source).vtype=(VarDispatch or VarByRef) then
|
||||
dispatchinterface:=pvardata(tvardata(source).vpointer)^.vdispatch
|
||||
else
|
||||
raise eoleerror.createres(@SVarNotObject);
|
||||
SearchIDs(IDispatch(dispatchinterface),@CallDesc^.ArgTypes[CallDesc^.ArgCount],
|
||||
CallDesc^.NamedArgCount+1,@ids);
|
||||
if assigned(dest) then
|
||||
VarClear(dest^);
|
||||
DispatchInvoke(IDispatch(dispatchinterface),calldesc,@ids,params,dest);
|
||||
end;
|
||||
|
||||
|
||||
const
|
||||
Initialized : boolean = false;
|
||||
|
||||
@ -218,7 +440,9 @@ initialization
|
||||
if not(IsLibrary) then
|
||||
Initialized:=Succeeded(CoInitialize(nil));
|
||||
SafeCallErrorProc:=@SafeCallErrorHandler;
|
||||
VarDispProc:=@ComObjDispatchInvoke;
|
||||
finalization
|
||||
VarDispProc:=nil;
|
||||
SafeCallErrorProc:=nil;
|
||||
if Initialized then
|
||||
CoUninitialize;
|
||||
|
||||
@ -207,6 +207,8 @@ function fpc_variant_to_dynarray(const v : variant;typeinfo : pointer) : pointer
|
||||
function fpc_dynarray_to_variant(dynarr : pointer;typeinfo : pointer) : variant;compilerproc;
|
||||
function fpc_variant_to_interface(const v : variant) : iinterface;compilerproc;
|
||||
function fpc_interface_to_variant(const i : iinterface) : variant;compilerproc;
|
||||
function fpc_variant_to_idispatch(const v : variant) : idispatch;compilerproc;
|
||||
function fpc_idispatch_to_variant(const i : idispatch) : variant;compilerproc;
|
||||
procedure fpc_vararray_get(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
|
||||
procedure fpc_vararray_put(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
|
||||
procedure fpc_dispinvoke_variant(dest : pvardata;const source : tvardata; calldesc : pcalldesc;params : pointer);compilerproc;
|
||||
|
||||
@ -143,6 +143,18 @@ function fpc_interface_to_variant(const i : iinterface) : variant;compilerproc;
|
||||
end;
|
||||
|
||||
|
||||
function fpc_variant_to_idispatch(const v : variant) : idispatch;compilerproc;
|
||||
begin
|
||||
variantmanager.vartodisp(result,v);
|
||||
end;
|
||||
|
||||
|
||||
function fpc_idispatch_to_variant(const i : idispatch) : variant;compilerproc;
|
||||
begin
|
||||
variantmanager.varfromdisp(result,i);
|
||||
end;
|
||||
|
||||
|
||||
procedure fpc_dispinvoke_variant(dest : pvardata;const source : tvardata;
|
||||
calldesc : pcalldesc;params : pointer);
|
||||
begin
|
||||
|
||||
Loading…
Reference in New Issue
Block a user