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

* Applied patch from José Mejuto to fix bug ID #27486

Browse Source 
git-svn-id: trunk@32823 -
This commit is contained in:
michael 2016-01-01 17:10:30 +00:00
parent 9111c9263e
commit ca2b1f97ed
1 changed files with 39 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
packages/winunits-base/src/typelib.pas
View File

@ -466,6 +466,7 @@ var
VD: lpVARDESC; VD: lpVARDESC;
aPropertyDefs:array of TPropertyDef; aPropertyDefs:array of TPropertyDef;
Propertycnt,iType:integer; Propertycnt,iType:integer;
Modifier: string;
function findProperty(ireqdispid:integer):integer; function findProperty(ireqdispid:integer):integer;
var i:integer; var i:integer;
@ -545,11 +546,18 @@ begin
OleCheck(TI.GetNames(FD^.memid,@BL,length(BL),cnt)); OleCheck(TI.GetNames(FD^.memid,@BL,length(BL),cnt));
// skip IUnknown and IDispatch methods // skip IUnknown and IDispatch methods
sl:=lowercase(BL[0]); sl:=lowercase(BL[0]);
if (sl='queryinterface') or (sl='addref') or (sl='release') then //IUnknown (*************************
* Code portion removed by José Mejuto.
* If the interface declaration appears in the TLB it must be imported
* or the sequences of functions will be broken and any function below this
* point would be called wrongly.
*************************
if ((sl='queryinterface') or (sl='addref') or (sl='release')) then //IUnknown
continue; continue;
if bIsDispatch and if bIsDispatch and
((sl='gettypeinfocount') or (sl='gettypeinfo') or (sl='getidsofnames') or (sl='invoke')) then //IDispatch ((sl='gettypeinfocount') or (sl='gettypeinfo') or (sl='getidsofnames') or (sl='invoke')) then //IDispatch
continue; continue;
*)
// get return type // get return type
if bIsDispatch and ((FD^.invkind=INVOKE_PROPERTYGET) or (FD^.invkind=INVOKE_FUNC)) then if bIsDispatch and ((FD^.invkind=INVOKE_PROPERTYGET) or (FD^.invkind=INVOKE_FUNC)) then
begin begin
@ -761,6 +769,8 @@ begin
begin begin
//getters/setters for interface, insert in interface as they come, //getters/setters for interface, insert in interface as they come,
//store in aPropertyDefs to create properties at the end //store in aPropertyDefs to create properties at the end
bParamByRef:=(FD^.lprgelemdescParam[0].tdesc.vt=VT_PTR) and // by ref
not((FD^.lprgelemdescParam[0].tdesc.lptdesc^.vt=VT_USERDEFINED) and bIsInterface);// but not pointer to interface
if bPropHasParam then if bPropHasParam then
begin begin
sPropParam2:='('+sPropParam+')'; sPropParam2:='('+sPropParam+')';
@ -785,6 +795,8 @@ begin
begin begin
if not MakeValidId(GetName(1),sVarName) then if not MakeValidId(GetName(1),sVarName) then
AddToHeader('// Warning: renamed parameter ''%s'' in %s.Set_%s to ''%s''',[GetName(1),iname,sMethodName,sVarName]); AddToHeader('// Warning: renamed parameter ''%s'' in %s.Set_%s to ''%s''',[GetName(1),iname,sMethodName,sVarName]);
if not bParamByRef then
begin
with aPropertyDefs[findProperty(FD^.memid)] do with aPropertyDefs[findProperty(FD^.memid)] do
begin begin
if FD^.invkind=INVOKE_PROPERTYPUT then if FD^.invkind=INVOKE_PROPERTYPUT then
@ -808,14 +820,16 @@ begin
sParam:=sPropParam; sParam:=sPropParam;
sDefault:=sl; sDefault:=sl;
end; end;
if sType='OleVariant' then end;
tmp:=' procedure Set_%s(%s:%s); %s;'#13#10 tmp:=' procedure Set_%s(%s %s:%s); %s;'#13#10;
if not (bParamByRef or (sType='OleVariant')) then
Modifier:='const'
else else
tmp:=' procedure Set_%s(Const %s:%s); %s;'#13#10; Modifier:='var';
if bPropHasParam then if bPropHasParam then
s:=s+format(tmp,[sMethodName,sPropParam3,sType,sConv]) s:=s+format(tmp,[sMethodName,Modifier,sPropParam3,sType,sConv])
else else
s:=s+format(tmp,[sMethodName,sVarName,sType,sConv]); s:=s+format(tmp,[sMethodName,Modifier,sVarName,sType,sConv]);
end; end;
end; end;
end; end;