paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 07:06:08 +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

64
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,37 +795,41 @@ 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]);
with aPropertyDefs[findProperty(FD^.memid)] do if not bParamByRef then
begin begin
if FD^.invkind=INVOKE_PROPERTYPUT then with aPropertyDefs[findProperty(FD^.memid)] do
begin begin
sptype:=sType; if FD^.invkind=INVOKE_PROPERTYPUT then
bput:=true; begin
if bputref then //disambiguate multiple setter sptype:=sType;
sMethodName:=sMethodName+'_'; bput:=true;
pname:=sMethodName; if bputref then //disambiguate multiple setter
end sMethodName:=sMethodName+'_';
else pname:=sMethodName;
begin end
sprtype:=sType; else
bputref:=true; begin
if bput then //disambiguate multiple setter sprtype:=sType;
sMethodName:=sMethodName+'_'; bputref:=true;
prname:=sMethodName; if bput then //disambiguate multiple setter
sMethodName:=sMethodName+'_';
prname:=sMethodName;
end;
sorgname:=BstrName;
sdoc:=BstrDocString;
sParam:=sPropParam;
sDefault:=sl;
end; end;
sorgname:=BstrName;
sdoc:=BstrDocString;
sParam:=sPropParam;
sDefault:=sl;
end; end;
if sType='OleVariant' then tmp:=' procedure Set_%s(%s %s:%s); %s;'#13#10;
tmp:=' procedure Set_%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;