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

* fix from Ludo to optionally skip generation of "tag" records and associated

Browse Source 
symbols. Mantis #23113

git-svn-id: trunk@22634 -
This commit is contained in:
marco 2012-10-13 11:27:20 +00:00
parent 287adff8a1
commit d52ce0f6fb
2 changed files with 37 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -53,7 +53,7 @@ To load a different type of library resource, append an integer index to 'FileNa
Example: C:\WINDOWS\system32\msvbvm60.dll\3
}
function ImportTypelib(FileName: WideString;var sUnitName:string;var slDependencies:TStringList;
bActiveX,bPackage:boolean;var sPackageSource,sPackageRegUnitSource:String):string;
bActiveX,bPackage,bRemoveStructTag:boolean;var sPackageSource,sPackageRegUnitSource:String):string;
Type
@ -66,6 +66,7 @@ Type
FAppendVersionNumber: Boolean;
FCreatePackage: Boolean;
FDependencies: TStringList;
FRemoveStructTag: Boolean;
FUnitSource: TStringList;
FPackageSource: TStringList;
FPackageRegUnitSource: TStringList;
@ -93,6 +94,7 @@ Type
procedure SetActiveX(AValue: Boolean);
procedure SetCreatePackage(AValue: Boolean);
procedure SetOutputFileName(AValue: String);
procedure SetRemoveStructTag(AValue: Boolean);
procedure SetUnitName(AValue: string);
Protected
bIsCustomAutomatable,bIsInterface,bIsAutomatable,bIsExternalDecl,bIsUserDefined:boolean;
@ -116,6 +118,7 @@ Type
function ValidateIDAgainstDeclared(id: string): boolean; virtual;
function MakeValidId(id:string;var valid:string): boolean; virtual;
function MakeValidIdAgainstDeclared(id:string;var valid:string): boolean;
function RemoveTag(typename: string): string;
// The actual routines that do the work.
procedure CreateCoClasses(const TL: ITypeLib; TICount: Integer); virtual;
procedure CreateForwards(const TL: ITypeLib; TICount: Integer); virtual;
@ -145,11 +148,13 @@ Type
// Append version number to unit name.
Property AppendVersionNumber : Boolean Read FAppendVersionNumber Write FAppendVersionNumber Default True;
// Create lpk package for ActiveXContainer descendant: default false
Property CreatePackage : Boolean Read FCreatePackage write SetCreatePackage Default False;
Property CreatePackage : Boolean read FCreatePackage write SetCreatePackage Default False;
// File to read typelib from.
Property InputFileName : WideString Read FInputFileName Write FInputFileName;
// If set, unit source will be written to this file.
Property OutputFileName : String Read FOutputFileName Write SetOutputFileName;
// Remove tag from struct names
Property RemoveStructTag : Boolean read FRemoveStructTag write SetRemoveStructTag Default False;
// Set automatically by OutputFileName or by Execute
Property UnitName : string Read FUnitname Write SetUnitName;
end;
@ -161,7 +166,7 @@ Resourcestring
SErrInvalidUnitName = 'Invalid unit name : %s';
function ImportTypelib(FileName: WideString;var sUnitName:string;var slDependencies:TStringList;
bActiveX,bPackage:boolean;var sPackageSource,sPackageRegUnitSource:String):string;
bActiveX,bPackage,bRemoveStructTag:boolean;var sPackageSource,sPackageRegUnitSource:String):string;
var i:integer;
begin
With TTypeLibImporter.Create(Nil) do
@ -169,6 +174,7 @@ begin
InputFileName:=FileName;
ActiveX:=bActiveX;
CreatePackage:=bPackage;
RemoveStructTag:=bRemoveStructTag;
Execute;
Result:=UnitSource.Text;
sUnitname:=UnitName;
@ -301,6 +307,18 @@ begin
MakeValidIdAgainstDeclared(id+'_',valid);
end;
function TTypeLibImporter.RemoveTag(typename: string): string;
begin
result:=typename;
if FRemoveStructTag and (pos('tag',typename)>0) then
if (copy(typename,1,3)='tag') then
delete(result,1,3)
else if (copy(typename,1,4)='_tag') then
delete(result,2,3)
else if (copy(typename,1,5)='__tag') then
delete(result,3,3);
end;
function TTypeLibImporter.TypeToString(TI:ITypeInfo; TD:TYPEDESC):string;
@ -331,9 +349,11 @@ begin
TD:=TD.lptdesc^;
OleCheck(TI.GetRefTypeInfo(TD.hreftype,TIref));
OleCheck(TIRef.GetDocumentation(DISPID_UNKNOWN, @BstrName, nil, nil, nil));
MakeValidId(BstrName,result);
OleCheck(TIRef.GetTypeAttr(TARef));
bIsCustomAutomatable:=TARef^.typekind in [TKIND_DISPATCH,TKIND_INTERFACE,TKIND_ENUM,TKIND_COCLASS];
if TARef^.typekind in [TKIND_RECORD,TKIND_UNION,TKIND_ALIAS] then
BstrName:=RemoveTag(BstrName);
MakeValidId(BstrName,result);
if TARef^.typekind=TKIND_ALIAS then
begin
TypeToString(TIRef,TARef^.tdescAlias); //not interested in result, only bIsCustomAutomatable and bIsInterface
@ -1210,7 +1230,7 @@ begin
case TIT of
TKIND_RECORD,TKIND_UNION:
begin
if not MakeValidId(BstrName,sRecordName) then
if not MakeValidId(RemoveTag(BstrName),sRecordName) then
AddToHeader('// Warning: renamed record ''%s'' to ''%s''',[BstrName,sRecordName],True);
AddToInterface(' P%s = ^%s;'#13#10,[sRecordName,sRecordName]);
FTypes.Add('P'+sRecordName);
@ -1260,7 +1280,7 @@ begin
stype:=TypeToString(TI, TA^.tdescAlias);
if bIsUserDefined and not ValidateID(stype) then
stype:=stype+'_';
if not MakeValidId(BstrName,sRecordName) then
if not MakeValidId(RemoveTag(BstrName),sRecordName) then
AddToHeader('// Warning: renamed alias ''%s'' to ''%s''',[BstrName,sRecordName],True);
sl:=format(' %s = %s;',[sRecordName,stype]);
if bIsUserDefined and not bIsExternalDecl and (FTypes.IndexOf(stype)=-1) then //not defined yet, defer
@ -1810,6 +1830,12 @@ begin
SetUnitName(UN)
end;
procedure TTypeLibImporter.SetRemoveStructTag(AValue: Boolean);
begin
if FRemoveStructTag=AValue then Exit;
FRemoveStructTag:=AValue;
end;
procedure TTypeLibImporter.SetUnitName(AValue: string);
begin
if FUnitname=AValue then Exit;

8
utils/importtl/importtl.pas
View File

@ -11,7 +11,7 @@ var
F:text;
slDep:TStringList;
i:integer;
bNoRecurse,bHelp,bActiveX,bPackage:boolean;
bNoRecurse,bHelp,bActiveX,bPackage,bRemoveStructTag:boolean;
begin
slDep:=TStringList.Create;
bNoRecurse:=false;
@ -25,6 +25,7 @@ begin
else if pos('-a',ParamStr(i))>0 then bActiveX:=true
else if pos('-h',ParamStr(i))>0 then bHelp:=true
else if pos('-p',ParamStr(i))>0 then bPackage:=true
else if pos('-t',ParamStr(i))>0 then bRemoveStructTag:=true
else if pos('-d',ParamStr(i))>0 then
begin
sOutDir:=trim(copy(ParamStr(i), pos('-d',ParamStr(i))+2, 260)); // windows MAX_PATH
@ -53,16 +54,17 @@ begin
writeln(' -h : displays this text.');
writeln(' -a : create ActiveXContainer descendants');
writeln(' -d dir: set output directory. Default: current directory.');
writeln(' -n : do not recurse typelibs. Default: create bindingss for all');
writeln(' -n : do not recurse typelibs. Default: create bindings for all');
writeln(' dependencies.');
writeln(' -p : create lazarus package for ActiveXContainer descendants');
writeln(' -t : remove "tag" prefix from structs');
exit;
end;
slDep.Add(paramstr(Paramcount));
i:=0;
repeat
writeln('Reading typelib from '+slDep[i]+ ' ...');
sTL:=ImportTypelib(slDep[i],unitname,slDep,bActiveX,bPackage,sPackageSource,sPackageRegUnitSource);
sTL:=ImportTypelib(slDep[i],unitname,slDep,bActiveX,bPackage,bRemoveStructTag,sPackageSource,sPackageRegUnitSource);
unitname:=sOutDir+unitname;
if (bPackage) and (sPackageSource<>'') then
begin