Revise 283: Bug: 64-bit got access violation when using CreateOleObject

Source/InvokeCall.inc

@@ -40,7 +40,9 @@ begin
              l_len := PSDynArrayGetLength(Pointer(aValue^.Dta^), aValue^.aType) - 1;
              SetLength(arr, 0);
              for i := 0 to l_len do begin
-               if not PSVariantIFCToTValue(PPSVariantIFC(IPointer(aValue^.Dta^) + IPointer(i) * 3 * SizeOf(Pointer)), arr, aValues1, aValues2, aSelf) then begin
+               if aValue^.aType.ExportName = '!OPENARRAYOFVARIANT' then
+                 arr := arr + [TValue.From<Variant>(PVariant(IPointer(aValue^.Dta^) + IPointer(i) * 3 * SizeOf(Pointer))^)]
+               else if not PSVariantIFCToTValue(PPSVariantIFC(IPointer(aValue^.Dta^) + IPointer(i) * 3 * SizeOf(Pointer)), arr, aValues1, aValues2, aSelf) then begin
                  Result := False;
                  Exit;
                end;

Source/uPSRuntime.pas

@@ -1105,7 +1105,7 @@ function MakeWString(const s: tbtunicodestring): tbtstring;
 {$ENDIF}
 
 {$IFNDEF PS_NOIDISPATCH}
-function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant;
+function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: {$ifdef Win32}array of {$ifdef PS_USECLASSICINVOKE}Variant{$else}TValue{$endif}{$endif}{$ifdef Win64}TArray<{$ifdef PS_USECLASSICINVOKE}Variant{$else}TValue{$endif}>{$endif}): Variant;
 {$ENDIF}
 
 
@@ -13163,7 +13163,7 @@ procedure TPSStack.SetWideString(ItemNo: Longint;
 const
   LOCALE_SYSTEM_DEFAULT = 2 shl 10; // Delphi 2 doesn't define this
 
-function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: array of Variant): Variant;
+function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtString; const Par: {$ifdef Win32}array of {$ifdef PS_USECLASSICINVOKE}Variant{$else}TValue{$endif}{$endif}{$ifdef Win64}TArray<{$ifdef PS_USECLASSICINVOKE}Variant{$else}TValue{$endif}>{$endif}): Variant;
 var
   Param: Word;
   i, ArgErr: Longint;
@@ -13209,16 +13209,16 @@ function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtS
     try
       for i := 0 to High(Par)  do
       begin
-        if PVarData(@Par[High(Par)-i]).VType = varString then
+        if (PVarData(PPSVariantIFC(@Par[High(Par)-i]).Dta).VType = varString) then
         begin
           DispParam.rgvarg[i].vt := VT_BSTR;
-          DispParam.rgvarg[i].bstrVal := StringToOleStr(AnsiString(Par[High(Par)-i]));
+          DispParam.rgvarg[i].bstrVal := StringToOleStr(Variant(PVarData(PPSVariantIFC(@Par[High(Par)-i]).Dta)^));
           WSFreeList.Add(DispParam.rgvarg[i].bstrVal);
         {$IFDEF UNICODE}
-        end else if (PVarData(@Par[High(Par)-i]).VType = varOleStr) or (PVarData(@Par[High(Par)-i]).VType = varUString) then
+        end else if (PVarData(PPSVariantIFC(@Par[High(Par)-i]).Dta).VType = varOleStr) or (PVarData(PPSVariantIFC(@Par[High(Par)-i]).Dta).VType = varUString) then
         begin
           DispParam.rgvarg[i].vt := VT_BSTR;
-          DispParam.rgvarg[i].bstrVal := StringToOleStr(UnicodeString(Par[High(Par)-i]));
+          DispParam.rgvarg[i].bstrVal := StringToOleStr(Variant(PVarData(PPSVariantIFC(@Par[High(Par)-i]).Dta)^));
           WSFreeList.Add(DispParam.rgvarg[i].bstrVal);
         {$ENDIF}
         end else
@@ -13239,7 +13239,7 @@ function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: tbtS
           {$ENDIF}
            (DispParam.rgvarg[i].pvarVal)^ := Par[High(Par)-i];
           *)
-          Move(Par[High(Par)-i],Pointer(DispParam.rgvarg[i].pvarVal)^,
+          Move(PVarData(PPSVariantIFC(@Par[High(Par)-i]).Dta)^,Pointer(DispParam.rgvarg[i].pvarVal)^,
            Sizeof({$IFDEF DELPHI4UP}OleVariant{$ELSE}Variant{$ENDIF}));
 
         end;

dunit/.gitignore

@@ -0,0 +1,5 @@
+Win32/
+Win64/
+*.dproj
+*.res
+*.dsk

dunit/PascalScriptTests.pas

@@ -0,0 +1,145 @@
+unit PascalScriptTests;
+
+interface
+
+uses
+  System.SysUtils, TestFramework,
+  uPSCompiler, uPSComponent, uPSRuntime, uPSUtils;
+
+type
+  TPascalScriptTests = class(TTestCase)
+  type
+    TExecute<T> = function: T of object;
+  private
+    FScripter: TPSScript;
+    procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler);
+    procedure OnExecImport(Sender: TObject; se: TPSExec; x:
+            TPSRuntimeClassImporter);
+    function Execute<T>(aScript: string): T;
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+  published
+    procedure Test_Format;
+    procedure Test_CreateOleObject;
+    procedure Test_BadVariableType;
+  end;
+
+implementation
+
+uses
+  Winapi.ActiveX,
+  uPSC_comobj, uPSR_comobj;
+
+procedure TPascalScriptTests.SetUp;
+begin
+  inherited;
+  FScripter := TPSScript.Create(nil);
+  FScripter.OnCompImport := OnCompImport;
+  FScripter.OnExecImport := OnExecImport;
+end;
+
+function TPascalScriptTests.Execute<T>(aScript: string): T;
+begin
+  FScripter.Script.Text := aScript;
+  FScripter.CompilerOptions := FScripter.CompilerOptions + [icAllowNoBegin, icAllowNoEnd];
+
+  if not FScripter.Compile then begin
+    var A: TArray<string>;
+    for var i := 0 to FScripter.CompilerMessageCount - 1 do
+      A := A + [string(FScripter.CompilerMessages[i].MessageToString)];
+    Status(string.Join(sLineBreak, A));
+  end;
+
+  var Execute := TExecute<T>(FScripter.GetProcMethod('Execute'));
+  Result := Execute;
+end;
+
+procedure TPascalScriptTests.OnCompImport(Sender: TObject;
+  x: TPSPascalCompiler);
+begin
+  x.AddDelphiFunction('function Format(const Format: string; const Args: array of const): string');
+  SIRegister_ComObj(x);
+end;
+
+procedure TPascalScriptTests.OnExecImport(Sender: TObject; se: TPSExec;
+  x: TPSRuntimeClassImporter);
+begin
+  se.RegisterDelphiFunction(@Format, 'Format', cdRegister);
+  RIRegister_ComObj(se);
+end;
+
+procedure TPascalScriptTests.TearDown;
+begin
+  FScripter.Free;
+  inherited;
+end;
+
+procedure TPascalScriptTests.Test_CreateOleObject;
+begin
+  CoInitialize(nil);
+  try
+    CheckEquals(
+      'True'
+    , Execute<string>('''
+      function Execute: string;
+      var o: Variant;
+      begin
+        o := CreateOleObject('Schedule.Service.1');
+        o.Connect('');
+        Result := o.Connected;
+      end;
+      ''')
+      );
+  finally
+    CoUninitialize;
+  end;
+end;
+
+procedure TPascalScriptTests.Test_Format;
+begin
+  CheckEquals(
+    'Print Hello World 123456'
+  , Execute<string>('''
+    function Execute: string;
+    begin
+      Result := Format('Print %s %d', ['Hello World', 123456]);
+    end;
+    ''')
+  );
+end;
+
+procedure TPascalScriptTests.Test_BadVariableType;
+begin
+  CheckNotEquals(
+    ''
+  , Execute<string>('''
+    function Execute: string;
+    var o, F, T: Variant;
+        R: string;
+    begin
+      o := CreateOleObject('Schedule.Service.1');
+      o.Connect;
+
+      F := o.GetFolder('\');
+      T := F.GetTasks(0);
+
+      R := T.Item[1].NextRunTime;
+      Result := R;
+
+      R := T.Item[1].Name;
+      Result := Result + #13#10 + R;
+
+      R := T.Item[1].NumberOfMissedRuns;
+      Result := Result + #13#10 + R;
+
+      R := T.Item[1].Enabled;
+      Result := Result + #13#10 + R;
+    end;
+    ''')
+  );
+end;
+
+initialization
+  RegisterTest(TPascalScriptTests.Suite);
+end.

dunit/PascalScript_DUnit.dpr

@@ -0,0 +1,16 @@
+program PascalScript_DUnit;
+
+{$APPTYPE CONSOLE}
+
+{$R *.res}
+
+uses
+  TestFramework,
+  DunitTestRunner,
+  {$IFDEF TESTINSIGHT}TestInsight.DUnit,{$ENDIF}
+  PascalScriptTests in 'PascalScriptTests.pas';
+
+begin
+  ReportMemoryLeaksOnShutdown := True;
+  RunRegisteredTests;
+end.