diff --git a/Source/InvokeCall.inc b/Source/InvokeCall.inc index 34c66c3e..0ef200f2 100644 --- a/Source/InvokeCall.inc +++ b/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(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; diff --git a/Source/uPSRuntime.pas b/Source/uPSRuntime.pas index 5ba7f170..a6dc57ed 100644 --- a/Source/uPSRuntime.pas +++ b/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; diff --git a/dunit/.gitignore b/dunit/.gitignore new file mode 100644 index 00000000..37c82e0c --- /dev/null +++ b/dunit/.gitignore @@ -0,0 +1,5 @@ +Win32/ +Win64/ +*.dproj +*.res +*.dsk \ No newline at end of file diff --git a/dunit/PascalScriptTests.pas b/dunit/PascalScriptTests.pas new file mode 100644 index 00000000..e13e753f --- /dev/null +++ b/dunit/PascalScriptTests.pas @@ -0,0 +1,145 @@ +unit PascalScriptTests; + +interface + +uses + System.SysUtils, TestFramework, + uPSCompiler, uPSComponent, uPSRuntime, uPSUtils; + +type + TPascalScriptTests = class(TTestCase) + type + TExecute = function: T of object; + private + FScripter: TPSScript; + procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler); + procedure OnExecImport(Sender: TObject; se: TPSExec; x: + TPSRuntimeClassImporter); + function Execute(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(aScript: string): T; +begin + FScripter.Script.Text := aScript; + FScripter.CompilerOptions := FScripter.CompilerOptions + [icAllowNoBegin, icAllowNoEnd]; + + if not FScripter.Compile then begin + var A: TArray; + 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(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(''' + 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(''' + function Execute: string; + begin + Result := Format('Print %s %d', ['Hello World', 123456]); + end; + ''') + ); +end; + +procedure TPascalScriptTests.Test_BadVariableType; +begin + CheckNotEquals( + '' + , Execute(''' + 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. diff --git a/dunit/PascalScript_DUnit.dpr b/dunit/PascalScript_DUnit.dpr new file mode 100644 index 00000000..1d5bb95f --- /dev/null +++ b/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.