paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 20:09:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* variants.pp, patch from Ivan Shikhalev implementing TInvokeableVariant.DispInvoke (with some changes), resolves #17919.

Browse Source 
git-svn-id: trunk@16458 -
This commit is contained in:
sergei 2010-11-27 19:34:39 +00:00
parent 3b910d9eb2
commit 099df04a5e
1 changed files with 108 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
rtl/inc/variants.pp
View File

@ -3940,10 +3940,115 @@ end;
TInvokeableVariantType implementation
---------------------------------------------------------------------}
procedure TInvokeableVariantType.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
procedure TInvokeableVariantType.DispInvoke(Dest: PVarData; const Source: TVarData;
CallDesc: PCallDesc; Params: Pointer);
var
method_name: ansistring;
arg_count: byte;
args: TVarDataArray;
arg_idx: byte;
arg_type: byte;
arg_byref, has_result: boolean;
arg_ptr: pointer;
arg_data: PVarData;
dummy_data: TVarData;
const
argtype_mask = $7F;
argref_mask = $80;
begin
NotSupported('TInvokeableVariantType.DispInvoke');
arg_count := CallDesc^.ArgCount;
method_name := ansistring(pchar(@CallDesc^.ArgTypes[arg_count]));
setLength(args, arg_count);
if arg_count > 0 then
begin
arg_ptr := Params;
for arg_idx := 0 to arg_count - 1 do
begin
arg_type := CallDesc^.ArgTypes[arg_idx] and argtype_mask;
arg_byref := (CallDesc^.ArgTypes[arg_idx] and argref_mask) <> 0;
arg_data := @args[arg_count - arg_idx - 1];
case arg_type of
varUStrArg: arg_data^.vType := varUString;
varStrArg: arg_data^.vType := varString;
else
arg_data^.vType := arg_type
end;
if arg_byref then
begin
arg_data^.vType := arg_data^.vType or varByRef;
arg_data^.vPointer := PPointer(arg_ptr)^;
Inc(arg_ptr,sizeof(Pointer));
end
else
case arg_type of
varVariant:
begin
arg_data^ := PVarData(PPointer(arg_ptr)^)^;
Inc(arg_ptr,sizeof(Pointer));
end;
varDouble, varCurrency, varInt64, varQWord:
begin
arg_data^.vQWord := PQWord(arg_ptr)^; // 64bit on all platforms
inc(arg_ptr,sizeof(qword))
end
else
arg_data^.vAny := PPointer(arg_ptr)^; // 32 or 64bit
inc(arg_ptr,sizeof(pointer))
end;
end;
end;
has_result := (Dest <> nil);
if has_result then
variant(Dest^) := Unassigned;
case CallDesc^.CallType of
1: { DISPATCH_METHOD }
if has_result then
begin
if arg_count = 0 then
begin
// no args -- try GetProperty first, then DoFunction
if not (GetProperty(Dest^,Source,method_name) or
DoFunction(Dest^,Source,method_name,args)) then
RaiseDispError
end
else
if not DoFunction(Dest^,Source,method_name,args) then
RaiseDispError;
end
else
begin
// may be procedure?
if not DoProcedure(Source,method_name,args) then
// may be function?
try
variant(dummy_data) := Unassigned;
if not DoFunction(dummy_data,Source,method_name,args) then
RaiseDispError;
finally
VarDataClear(dummy_data)
end;
end;
2: { DISPATCH_PROPERTYGET -- currently never generated by compiler for Variant Dispatch }
if has_result then
begin
// must be property...
if not GetProperty(Dest^,Source,method_name) then
// may be function?
if not DoFunction(Dest^,Source,method_name,args) then
RaiseDispError
end
else
RaiseDispError;
4: { DISPATCH_PROPERTYPUT }
if has_result or (arg_count<>1) or // must be no result and a single arg
(not SetProperty(Source,method_name,args[0])) then
RaiseDispError;
else
RaiseDispError;
end;
end;
function TInvokeableVariantType.DoFunction(var Dest: TVarData; const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;