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

git-svn-id: trunk@16458 -

rtl/inc/variants.pp

@@ -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;