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

    symbols. Mantis #23113

git-svn-id: trunk@22634 -

packages/winunits-base/src/typelib.pas

@@ -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;

utils/importtl/importtl.pas

@@ -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