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

Merged revision(s) 47516, 47518-47519 from trunk:

Browse Source 
* correctly mask the argument type of a dispatch parameter (only the top most bit needs to be removed, not the top most *two* bits)
........
+ add support for dispatching UnicodeString parameters (in addition to AnsiString parameters)
........
+ add test to check whether ComObj correctly dispatches Ansi-, Unicode- and WideString arguments
........

git-svn-id: branches/fixes_3_2@47591 -
This commit is contained in:
svenbarth 2020-11-25 22:26:40 +00:00
parent 846775f4b6
commit c74237421b
3 changed files with 190 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -13847,6 +13847,7 @@ tests/test/packages/webtbs/tw14265.pp svneol=native#text/plain
tests/test/packages/webtbs/tw1808.pp svneol=native#text/plain
tests/test/packages/webtbs/tw3820.pp svneol=native#text/plain
tests/test/packages/win-base/tdispvar1.pp svneol=native#text/plain
tests/test/packages/win-base/tdispvar2.pp svneol=native#text/pascal
tests/test/packages/zlib/tzlib1.pp svneol=native#text/plain
tests/test/t4cc1.pp svneol=native#text/plain
tests/test/t4cc2.pp svneol=native#text/plain

42
packages/winunits-base/src/comobj.pp
View File

@ -1184,7 +1184,7 @@ HKCR
{ 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;
StringMap : array[0..255] of record passtr : pansistring; paswstr : punicodestring; comstr : pwidechar; end;
invokekind,
i : longint;
invokeresult : HResult;
@ -1210,7 +1210,7 @@ HKCR
writeln('DispatchInvoke: Params = ',hexstr(Params));
{$endif DEBUG_COMDISPATCH}
{ get plain type }
CurrType:=CallDesc^.ArgTypes[i] and $3f;
CurrType:=CallDesc^.ArgTypes[i] and $7f;
{ a skipped parameter? Don't increment Params pointer if so. }
if CurrType=varError then
begin
@ -1230,6 +1230,21 @@ HKCR
{$endif DEBUG_COMDISPATCH}
StringMap[NextString].ComStr:=StringToOleStr(PString(Params^)^);
StringMap[NextString].PasStr:=PString(Params^);
StringMap[NextString].PasWStr:=Nil;
Arguments[i].VType:=varOleStr or varByRef;
Arguments[i].VPointer:=@StringMap[NextString].ComStr;
inc(NextString);
inc(PPointer(Params));
end;
varUStrArg:
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('Translating var unicodestring argument ',PUnicodeString(Params^)^);
{$endif DEBUG_COMDISPATCH}
StringMap[NextString].ComStr:=StringToOleStr(PUnicodeString(Params^)^);
StringMap[NextString].PasStr:=Nil;
StringMap[NextString].PasWStr:=PUnicodeString(Params^);
Arguments[i].VType:=varOleStr or varByRef;
Arguments[i].VPointer:=@StringMap[NextString].ComStr;
inc(NextString);
@ -1282,6 +1297,22 @@ HKCR
{$endif DEBUG_COMDISPATCH}
StringMap[NextString].ComStr:=StringToOleStr(PString(Params)^);
StringMap[NextString].PasStr:=nil;
StringMap[NextString].PasWStr:=nil;
Arguments[i].VType:=varOleStr;
Arguments[i].VPointer:=StringMap[NextString].ComStr;
inc(NextString);
inc(PPointer(Params));
end;
varUStrArg:
begin
{$ifdef DEBUG_COMDISPATCH}
if printcom then
writeln('Translating unicodestring argument ',PUnicodeString(Params)^);
{$endif DEBUG_COMDISPATCH}
StringMap[NextString].ComStr:=StringToOleStr(PUnicodeString(Params)^);
StringMap[NextString].PasStr:=nil;
StringMap[NextString].PasWStr:=nil;
Arguments[i].VType:=varOleStr;
Arguments[i].VPointer:=StringMap[NextString].ComStr;
inc(NextString);
@ -1373,9 +1404,12 @@ HKCR
DispatchInvokeError(invokeresult,exceptioninfo);
{ translate strings back }
for i:=0 to NextString-1 do
for i:=0 to NextString-1 do begin
if assigned(StringMap[i].passtr) then
OleStrToStrVar(StringMap[i].comstr,StringMap[i].passtr^);
OleStrToStrVar(StringMap[i].comstr,StringMap[i].passtr^)
else if assigned(StringMap[i].paswstr) then
OleStrToStrVar(StringMap[i].comstr,StringMap[i].paswstr^);
end;
finally
for i:=0 to NextString-1 do
SysFreeString(StringMap[i].ComStr);

151
tests/test/packages/win-base/tdispvar2.pp Normal file
View File

@ -0,0 +1,151 @@
{ %TARGET = win32,win64,wince }
{ tests that the different string types are converted correctly when dispatching }
program tdispvar2;
{$mode objfpc}{$H+}
uses
SysUtils, Variants, ComObj, ActiveX, Windows;
type
{ TTest }
TTest = class(TInterfacedObject, IDispatch)
function GetTypeInfoCount(out count : longint) : HResult;stdcall;
function GetTypeInfo(Index,LocaleID : longint;
out TypeInfo): HResult;stdcall;
function GetIDsOfNames(const iid: TGUID; names: Pointer;
NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall;
function Invoke(DispID: LongInt;const iid : TGUID;
LocaleID : longint; Flags: Word;var params;
VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall;
end;
var
TestStr: WideString;
{ TTest }
function TTest.GetTypeInfoCount(out count: longint): HResult; stdcall;
begin
Count := 0;
Result := S_OK;
end;
function TTest.GetTypeInfo(Index, LocaleID: longint; out TypeInfo): HResult;
stdcall;
begin
Result := E_NOTIMPL;
end;
function TTest.GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount,
LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
var
n: ^PWideChar absolute names;
d: PDispIDList absolute DispIDs;
begin
if (WideString(n^) = 'SomeFunction') then begin
d^[0] := 1;
Result := S_OK;
end else
Result := DISP_E_UNKNOWNNAME;
end;
function TTest.Invoke(DispID: LongInt; const iid: TGUID; LocaleID: longint;
Flags: Word; var params; VarResult, ExcepInfo, ArgErr: pointer): HResult;
stdcall;
var
args: TDispParams absolute params;
i: UINT;
begin
//Writeln('Call to Invoke');
if (DispID = 1) then begin
//Writeln(HexStr(Flags, 4));
//Writeln(args.cArgs, ' ', args.cNamedArgs);
for i := 0 to args.cArgs - 1 do begin
//Writeln(HexStr(args.rgvarg^[i].vt, 4));
if args.rgvarg^[i].vt = VT_BSTR then begin
//Writeln(WideString(args.rgvarg^[i].bstrVal));
TestStr := WideString(args.rgvarg^[i].bstrVal);
end else if args.rgvarg^[i].vt = VT_BSTR or VT_BYREF then begin
//Writeln(args.rgvarg^[i].pbstrVal^);
TestStr := args.rgvarg^[i].pbstrVal^;
end;
end;
Result := S_OK;
end else
Result := E_NOTIMPL;
end;
procedure Test;
{$push}
{$J-}
const
cs: AnsiString = 'Constant AnsiString';
cus: UnicodeString = 'Constant UnicodeString';
cws: WideString = 'Constant WideString';
{$pop}
var
i: IDispatch;
w: OleVariant;
s: AnsiString;
us: UnicodeString;
ws: WideString;
begin
w := Null;
i := TTest.Create;
try
s := 'AnsiString';
us := 'UnicodeString';
ws := 'WideString';
w := i;
TestStr := '';
w.SomeFunction('Constant');
if TestStr <> 'Constant' then
Halt(1);
TestStr := '';
w.SomeFunction(s);
if TestStr <> 'AnsiString' then
Halt(2);
TestStr := '';
w.SomeFunction(us);
if TestStr <> 'UnicodeString' then
Halt(3);
TestStr := '';
w.SomeFunction(ws);
if TestStr <> 'WideString' then
Halt(4);
TestStr := '';
w.SomeFunction(cs);
if TestStr <> 'Constant AnsiString' then
Halt(5);
TestStr := '';
w.SomeFunction(cus);
if TestStr <> 'Constant UnicodeString' then
Halt(6);
TestStr := '';
w.SomeFunction(cws);
if TestStr <> 'Constant WideString' then
Halt(7);
finally
w := Null;
i := Nil;
end;
end;
begin
CoInitializeEx(Nil, COINIT_MULTITHREADED);
try
Test;
finally
CoUninitialize;
end;
end.