diff --git a/applications/gobject-introspection/gir2pascal.lpi b/applications/gobject-introspection/gir2pascal.lpi
index b33d625e1..68ce1956b 100644
--- a/applications/gobject-introspection/gir2pascal.lpi
+++ b/applications/gobject-introspection/gir2pascal.lpi
@@ -23,6 +23,7 @@
+
@@ -30,7 +31,7 @@
-
+
diff --git a/applications/gobject-introspection/gir2pascal.lpr b/applications/gobject-introspection/gir2pascal.lpr
index 6d38deb85..baf497be6 100644
--- a/applications/gobject-introspection/gir2pascal.lpr
+++ b/applications/gobject-introspection/gir2pascal.lpr
@@ -38,6 +38,7 @@ type
FOutPutDirectory : String;
FFileToConvert: String;
FOverWriteFiles: Boolean;
+ FWantTest: Boolean;
procedure AddDefaultPaths;
procedure AddPaths(APaths: String);
procedure VerifyOptions;
@@ -45,7 +46,8 @@ type
//callbacks
function NeedGirFile(AGirFile: TObject; NamespaceName: String) : TXMLDocument;
- procedure WritePascalFile(Sender: TObject; AUnitName: String; AStream: TStringStream);
+ // AName is the whole name unit.pas or file.c
+ procedure WriteFile(Sender: TObject; AName: String; AStream: TStringStream);
protected
procedure DoRun; override;
public
@@ -110,14 +112,13 @@ begin
end;
end;
-procedure TGirConsoleConverter.WritePascalFile(Sender: TObject;
- AUnitName: String; AStream: TStringStream);
+procedure TGirConsoleConverter.WriteFile(Sender: TObject; AName: String; AStream: TStringStream);
var
SStream: TFileStream;
OutFileName: String;
begin
Inc(FWriteCount);
- OutFileName:=FOutPutDirectory+LowerCase(AUnitName)+'.pas';
+ OutFileName:=FOutPutDirectory+LowerCase(AName);
if not FileExists(OutFileName)
or (FileExists(OutFileName) and FOverWriteFiles) then
begin
@@ -152,8 +153,8 @@ begin
girFile.ParseXMLDocument(Doc);
Doc.Free;
- Writer := TgirPascalWriter.Create(girFile.NameSpaces);
- Writer.OnUnitWriteEvent:= @WritePascalFile;
+ Writer := TgirPascalWriter.Create(girFile.NameSpaces, FWantTest);
+ Writer.OnUnitWriteEvent:= @WriteFile;
Writer.GenerateUnits;
Writer.Free;
@@ -168,7 +169,7 @@ var
ErrorMsg: String;
begin
// quick check parameters
- ErrorMsg:=CheckOptions('hnp:o:i:w',['help','no-default','paths','output-directory', 'input', 'overwrite-files']);
+ ErrorMsg:=CheckOptions('hnp:o:i:wt',['help','no-default','paths','output-directory', 'input', 'overwrite-files', 'test']);
if ErrorMsg<>'' then begin
ShowException(Exception.Create(ErrorMsg));
Terminate;
@@ -198,6 +199,8 @@ begin
if HasOption('w', 'overwrite-files') then
FOverWriteFiles:=True;
+ FWantTest := HasOption('t', 'test');
+
VerifyOptions;
// does all the heavy lifting
@@ -232,6 +235,7 @@ begin
Writeln(' -n --no-default /usr/share/gir-1.0 is not added as a search location for ');
Writeln(' needed .gir files.');
Writeln(' -p --paths= List of paths seperated by ":" to search for needed .gir files.');
+ Writeln(' -t --test Creates a test program and a test c file per unit to verify struct sizes.');
Writeln('');
end;
diff --git a/applications/gobject-introspection/girfiles.pas b/applications/gobject-introspection/girfiles.pas
index 36d404441..2eb32b6bc 100644
--- a/applications/gobject-introspection/girfiles.pas
+++ b/applications/gobject-introspection/girfiles.pas
@@ -59,32 +59,33 @@ uses girErrors, girTokens;
procedure TgirFile.ParseNode(ANode: TDomNode);
var
+ Node: TDomNode;
NS: TgirNamespace;
Includes: TList;
begin
if ANode.NodeName <> 'repository' then
girError(geError, 'Not a Valid Document Type!');
- ANode := Anode.FirstChild;
+ Node := Anode.FirstChild;
Ns := nil;
Includes := TList.Create;
- while ANode <> nil do begin
- case GirTokenNameToToken(ANode.NodeName) of
- gtInclude: ParseIncludeNode(ANode, Includes);
+ while Node <> nil do begin
+ case GirTokenNameToToken(Node.NodeName) of
+ gtInclude: ParseIncludeNode(Node, Includes);
gtNameSpace:
begin
- NS := TgirNamespace.CreateFromNamespaceNode(NameSpaces, ANode, Includes);
+ NS := TgirNamespace.CreateFromRepositoryNode(NameSpaces, ANode, Includes);
girError(geDebug, 'Adding Namespace '+NS.NameSpace+' to NameSpaces');
FNameSpaces.Add(NS);
girError(geDebug, 'Added Namespace '+NS.NameSpace);
- NS.ParseNode(ANode);
+ NS.ParseNode(Node);
end;
gtPackage, gtCInclude: ;// ignore for now
else
- girError(geDebug, 'Unknown Node Type for Reposiotory: '+ Anode.NodeName);
+ girError(geDebug, 'Unknown Node Type for Reposiotory: '+ node.NodeName);
end;
- ANode := ANode.NextSibling;
+ Node := Node.NextSibling;
end;
diff --git a/applications/gobject-introspection/girnamespaces.pas b/applications/gobject-introspection/girnamespaces.pas
index f67ca91c9..812012a54 100644
--- a/applications/gobject-introspection/girnamespaces.pas
+++ b/applications/gobject-introspection/girnamespaces.pas
@@ -34,7 +34,9 @@ type
TgirNamespace = class(IgirParser)
private
+ FCIncludeName: String;
FConstants: TList;
+ FCPackageName: String;
FFunctions: TList;
FNameSpace: String;
FOnlyImplied: Boolean;
@@ -75,9 +77,11 @@ type
procedure ParseNode(ANode: TDomNode);
procedure ParseSubNode(ANode: TDomNode); // generally do not use outside of TgirNameSpace
constructor Create(AOwner:TObject; AImpliedNamespace: String);
- constructor CreateFromNamespaceNode(AOwner:TObject; ANode: TDOMNode; AIncludes: TList);
+ constructor CreateFromRepositoryNode(AOwner:TObject; ANode: TDOMNode; AIncludes: TList);
destructor Destroy; override;
property NameSpace: String read FNameSpace;
+ property CIncludeName: String read FCIncludeName;
+ property CPackageName: String read FCPackageName;
property RequiredNameSpaces: TList Read FRequiredNameSpaces;
property SharedLibrary: String read FSharedLibrary;
property Version: String read FVersion;
@@ -499,19 +503,39 @@ begin
girError(geDebug, 'Creating Stub for namespace: '+ AImpliedNamespace);
end;
-constructor TgirNamespace.CreateFromNamespaceNode(AOwner:TObject; ANode: TDOMNode; AIncludes: TList);
+constructor TgirNamespace.CreateFromRepositoryNode(AOwner:TObject; ANode: TDOMNode; AIncludes: TList);
+ procedure SetCInclude;
+ var
+ Child: TDomElement;
+ begin
+ Child := TDOMElement(ANode.FindNode('c:include name'));
+ if (Child <> nil) and Child.InheritsFrom(TDOMElement) then
+ FCIncludeName:= Child.GetAttribute('name');
+ end;
+ procedure SetPackage;
+ var
+ Child: TDOMElement;
+ begin
+ Child := TDOMElement(ANode.FindNode('package'));
+ if (Child <> nil) and Child.InheritsFrom(TDOMElement) then
+ FCPackageName:=Child.GetAttribute('name');
+ end;
+
var
- Node: TDOMElement absolute ANode;
+ Node: TDOMElement;
begin
FOwner := AOwner;
if ANode = nil then
girError(geError, 'expected namespace got nil');
- if ANode.NodeName <> 'namespace' then
- girError(geError, 'expected namespace got '+ANode.NodeName);
+ if ANode.NodeName <> 'repository' then
+ girError(geError, 'expected "repository" got '+ANode.NodeName);
+ Node := TDOMElement( ANode.FindNode('namespace') );
FNameSpace:=Node.GetAttribute('name');
FRequiredNameSpaces := AIncludes;
FSharedLibrary:=Node.GetAttribute('shared-library');
FVersion:=Node.GetAttribute('version');
+ SetCInclude;
+ SetPackage;
girError(geDebug, Format('Creating namespace=%s Version=%s LibName=%s',[FNameSpace, FVersion, FSharedLibrary]));
FConstants := TList.Create;
diff --git a/applications/gobject-introspection/girobjects.pas b/applications/gobject-introspection/girobjects.pas
index e3270911c..15505bc6f 100644
--- a/applications/gobject-introspection/girobjects.pas
+++ b/applications/gobject-introspection/girobjects.pas
@@ -43,6 +43,7 @@ type
FCType: String;
FDoc: String;
FForwardDefinitionWritten: Boolean;
+ FHasFields: Boolean;
FImpliedPointerLevel: Integer;
FName: String;
FObjectType: TGirObjectType;
@@ -265,9 +266,11 @@ type
{ TgirFieldsList }
- TgirFieldsList = class(TFPList)
+ TgirFieldsList = class(TList)
private
+ FHasFields: Boolean;
function GetField(AIndex: Integer): TGirBaseType;
+ procedure Notify(Ptr: Pointer; Action: TListNotification); override;
public
property Field[AIndex: Integer]: TGirBaseType read GetField;
end;
@@ -277,6 +280,7 @@ type
TgirRecord = class(TGirBaseType)
private
FFields: TgirFieldsList;
+ function GetHasFields: Boolean;
protected
procedure HandleUnion(ANode: TDomNode);
procedure HandleField(ANode: TDomNode);
@@ -285,6 +289,7 @@ type
constructor Create(AOwner: TObject; ANode: TDomNode); override;
destructor Destroy; override;
property Fields: TgirFieldsList read FFields;
+ property HasFields: Boolean read GetHasFields;
end;
{ TgirUnion }
@@ -413,6 +418,7 @@ constructor TgirBitField.Create(AOwner: TObject; ANode: TDomNode);
begin
inherited Create(AOwner, ANode);
FObjectType:=otBitfield;
+ FHasFields:=True;
end;
{ TgirFieldsList }
@@ -422,6 +428,15 @@ begin
Result := TGirBaseType(Items[AIndex]);
end;
+procedure TgirFieldsList.Notify(Ptr: Pointer; Action: TListNotification);
+var
+ gir: TGirBaseType absolute Ptr;
+begin
+ if FHasFields then
+ Exit;
+ FHasFields:= gir.ObjectType in [otTypeParam, otCallback, otArray];
+end;
+
{ TgirParamList }
function TgirParamList.GetParam(AIndex: Integer): TGirFunctionParam;
@@ -625,6 +640,10 @@ end;
+function TgirRecord.GetHasFields: Boolean;
+begin
+ Result := Fields.FHasFields;
+end;
procedure TgirRecord.HandleUnion(ANode: TDomNode);
var
diff --git a/applications/gobject-introspection/girpascalwriter.pas b/applications/gobject-introspection/girpascalwriter.pas
index 1fb0550b5..b2ab6e053 100644
--- a/applications/gobject-introspection/girpascalwriter.pas
+++ b/applications/gobject-introspection/girpascalwriter.pas
@@ -26,19 +26,22 @@ uses
Classes, SysUtils, girNameSpaces, girObjects, girTokens, contnrs;
type
- TUnitWriteEvent = procedure (Sender: TObject; AUnitName: AnsiString; AStream: TStringStream) of object;
+ TgirWriteEvent = procedure (Sender: TObject; AUnitName: AnsiString; AStream: TStringStream) of object;
{ TgirPascalWriter }
TgirPascalWriter = class
private
- FOnUnitWriteEvent: TUnitWriteEvent;
+ FDefaultUnitExtension: String;
+ FOnUnitWriteEvent: TgirWriteEvent;
FNameSpaces: TgirNamespaces;
FUnits: TList;
+ FWantTest: Boolean;
public
- constructor Create(ANameSpaces: TgirNamespaces);
+ constructor Create(ANameSpaces: TgirNamespaces; AWantTest: Boolean);
procedure GenerateUnits;
- property OnUnitWriteEvent: TUnitWriteEvent read FOnUnitWriteEvent write FOnUnitWriteEvent;
+ property OnUnitWriteEvent: TgirWriteEvent read FOnUnitWriteEvent write FOnUnitWriteEvent;
+ property DefaultUnitExtension: String read FDefaultUnitExtension write FDefaultUnitExtension; // is .pas by default
end;
@@ -180,7 +183,11 @@ type
FInterfaceSection: TPInterface;
FLibName: String;
FNameSpace: TgirNamespace;
+ FWantTest: Boolean;
ProcessLevel: Integer; //used to know if to write forward definitions
+ FTestCFile: TStringStream;
+ FTestPascalFile: TStringStream;
+ FTestPascalBody: TStringList;
function GetUnitName: String;
// functions to ensure the type is being written in the correct declaration
@@ -230,13 +237,16 @@ type
procedure ProcessType(AType: TGirBaseType; AForceWrite: Boolean = False);
procedure ResolveFuzzyTypes;
+ procedure AddTestType(APascalName: String; ACName: String);
public
- constructor Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean);
+ constructor Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean; AWantTest: Boolean);
+ destructor Destroy; override;
procedure ProcessConsts(AList:TList); // of TgirBaseType descandants
procedure ProcessTypes(AList:TFPHashObjectList); // of TgirBaseType descandants
procedure ProcessFunctions(AList:TList);// of TgirFunction
procedure GenerateUnit;
function AsStream: TStringStream;
+ procedure Finish;
property InterfaceSection: TPInterface read FInterfaceSection;
property ImplementationSection: TPImplementation read FImplementationSection;
@@ -614,6 +624,8 @@ begin
WriteLn('Unknown Type: ', AType.ClassName);
Halt;
end; // case
+ if (AType.InheritsFrom(TgirRecord)) and (TgirRecord(AType).HasFields) then
+ AddTestType(AType.TranslatedName, AType.CType);
AType.Writing:=msWritten;
Dec(ProcessLevel);
@@ -643,6 +655,43 @@ begin
end;
end;
+procedure TPascalUnit.AddTestType(APascalName: String; ACName: String);
+const
+ CFunction = 'int GetSizeOf_%s(void)'+
+ '{ return sizeof(%s); };'+LineEnding;
+ PImport = 'function GetSizeOf_%s: LongInt; cdecl; external;'+LineEnding;
+ PTest = 'procedure Test_%s;' +LineEnding+
+ 'var' +LineEnding+
+ ' PSize: Integer;' +LineEnding+
+ ' CSize: Integer;' +LineEnding+
+ 'begin' +LineEnding+
+ ' PSize := SizeOf(%s);' +LineEnding+
+ ' CSize := GetSizeOf_%s;' +LineEnding+
+ ' if CSize = PSize then' +LineEnding+
+ ' WriteLn(''%s Matches C Size: '',CSize)' +LineEnding+
+ ' else' +LineEnding+
+ ' WriteLn(''%s size ('',PSize,'') does NOT match %s size ('',CSize,'')'');' +LineEnding+
+ 'end;' +LineEnding;
+var
+ CF: String;
+ PI: String;
+ PT: String;
+begin
+ if not FWantTest then
+ Exit;
+ if (ACName = '') or (ACName[1] = '_') then // we skip private types
+ Exit;
+
+ CF := Format(CFunction,[ACName, ACName]);
+ PI := Format(PImport, [ACName]);
+ PT := Format(PTest, [ACName, APascalName, ACName, APascalName, APascalName, ACName]);
+
+ FTestCFile.WriteString(CF); // c sizeof wrapper
+ FTestPascalFile.WriteString(PI); // c import
+ FTestPascalFile.WriteString(PT); // pascal testproc
+ FTestPascalBody.Add(Format('Test_%s;',[ACName])); //call pascal testproc
+end;
+
function TPascalUnit.WantTypeSection: TPDeclarationType;
begin
if (InterfaceSection.Declarations.Count = 0)
@@ -961,6 +1010,7 @@ var
TypeFuncs: TStrings;
ParentType: String ='';
UsedNames: TStringList;
+ WrittenFields: Integer;
function GetTypeForProperty(AProperty: TgirProperty; out SetFound: Boolean): String;
var
@@ -1040,10 +1090,12 @@ var
Param: String;
begin
ResolveTypeTranslation(AParam.VarType);
- if (ParentType <> '') and (ParenParams(AParam.VarType.TranslatedName) = ParentType) then
+ Inc(WrittenFields);
+ if (WrittenFields = 1) and (AObjectType = gtClass) and (TgirClass(AItem).ParentClass <> nil) then
begin
Exit;
end;
+
Param := WriteParamAsString(AParam,i, nil, UsedNames);
//if Pos('destroy_:', Param) > 0 then
// Param := StringReplace(Param, 'destroy_', 'destroy_f', [rfReplaceAll]);
@@ -1063,7 +1115,7 @@ var
otCallback,
otArray,
otTypeParam,
- otUnion: ; // these will be done on the second pass. this is to make the field names different if they are the same as some function or property. giving the function priority of the original name
+ otUnion: Exit; // these will be done on the second pass. this is to avoid duplicate names if they are the same as some function or property. giving the function priority of the original name
otGlibSignal : if AObjectType <> gtClass then TypeDecl.Add(IndentText(WriteCallBack(TgirCallback(Field),True, UsedNames),4,0)); // classes do not have signals They are in the class *struct*
@@ -1166,11 +1218,17 @@ begin
AddGetTypeProc(TgirGType(AItem));
end;
TypeDecl.Add(IndentText(AItem.TranslatedName +' = object'+ParentType,2,0));
- // two passes to process the fields last for naming reasons
+
+ // two passes to process the fields last for naming reasons first for methods/properties second for fields
for i := 0 to Aitem.Fields.Count-1 do
HandleFieldType(AItem.Fields.Field[i], True);
- for i := 0 to Aitem.Fields.Count-1 do
- HandleFieldType(AItem.Fields.Field[i], False);
+ if AItem.CType <> 'GInitiallyUnowned' then // empty type GInitiallyUnowned is empty and aliased to GObject which causes object introspection to add the types again since it's empty...how many places does that happen...
+ begin
+ WrittenFields:=0;
+ for i := 0 to Aitem.Fields.Count-1 do
+ HandleFieldType(AItem.Fields.Field[i], False);
+ end;
+
if TypeFuncs.Count > 0 then
@@ -1595,19 +1653,50 @@ begin
ABaseType.TranslatedName:=MakePascalTypeFromCType(ABaseType.CType, 0);
end;
-constructor TPascalUnit.Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean);
+constructor TPascalUnit.Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean; AWantTest: Boolean);
+const
+ CBasic = '#include <%s>'+LineEnding;
+ PBasic = 'program %s_test;'+LineEnding+
+ '{$LINK %s_c_test}'+LineEnding+
+ 'uses %s;'+LineEnding;
begin
ProcessLevel:=0;
+ FWantTest:=AWantTest;
FLinkDynamic := ALinkDynamic;
FFinalizeSection := TPFinialization.Create(Self);
FImplementationSection := TPImplementation.Create(Self);
FInitializeSection := TPInitialize.Create(Self);
FInterfaceSection := TPInterface.Create(Self, TPUses.Create);
FNameSpace := ANameSpace;
+ if FWantTest then
+ begin
+ FTestCFile := TStringStream.Create('');
+ FTestCFile.WriteString(Format(CBasic, [FNameSpace.CIncludeName]));
+ FTestPascalFile := TStringStream.Create('');
+ FTestPascalFile.WriteString(Format(PBasic,[UnitName, UnitName, UnitName]));
+ FTestPascalBody := TStringList.Create;
+ FTestPascalBody.Add('begin');
+ end;
ResolveFuzzyTypes;
GenerateUnit;
end;
+destructor TPascalUnit.Destroy;
+begin
+ if FWantTest then
+ begin
+ FTestPascalFile.Free;
+ FTestCFile.Free;
+ FTestPascalBody.Free;
+ end;
+ FFinalizeSection.Free;
+ FImplementationSection.Free;
+ FInitializeSection.Free;
+ FInterfaceSection.Free;
+
+ inherited Destroy;
+end;
+
procedure TPascalUnit.ProcessConsts(AList: TList);
function WriteConst(AConst: TgirConstant; Suffix: String = ''): String;
begin
@@ -1744,6 +1833,17 @@ begin
Result.Position:=0;
end;
+procedure TPascalUnit.Finish;
+begin
+ if FWantTest then
+ begin
+ FTestPascalFile.WriteString(FTestPascalBody.Text);
+ FTestPascalFile.WriteString('end.');
+ FTestCFile.Position:=0;
+ FTestPascalFile.Position:=0;
+ end;
+end;
+
{ TPDeclarationList }
function TPDeclarationList.GetDeclarations(AIndex: Integer): TPDeclaration;
@@ -1763,10 +1863,12 @@ end;
{ TgirPascalWriter }
-constructor TgirPascalWriter.Create(ANameSpaces: TgirNamespaces);
+constructor TgirPascalWriter.Create(ANameSpaces: TgirNamespaces; AWantTest: Boolean);
begin
FNameSpaces := ANameSpaces;
FUnits := TList.Create;
+ FDefaultUnitExtension:='.pas';
+ FWantTest:=AWantTest;
end;
procedure TgirPascalWriter.GenerateUnits;
@@ -1774,16 +1876,23 @@ var
i: Integer;
FUnit: TPascalUnit;
+
begin
for i := 0 to FNameSpaces.Count-1 do
begin
WriteLn(Format('Converting %s', [FNameSpaces.NameSpace[i].NameSpace]));
- FUnit := TPascalUnit.Create(FNameSpaces.NameSpace[i], False);
+ FUnit := TPascalUnit.Create(FNameSpaces.NameSpace[i], False, FWantTest);
FUnit.ProcessConsts(FNameSpaces.NameSpace[i].Constants);
FUnit.ProcessTypes(FNameSpaces.NameSpace[i].Types);
FUnit.ProcessFunctions(FNameSpaces.NameSpace[i].Functions);
+ FUnit.Finish;
FUnits.Add(FUnit);
- FOnUnitWriteEvent(Self, FUnit.UnitName, FUnit.AsStream);
+ FOnUnitWriteEvent(Self, FUnit.UnitName+FDefaultUnitExtension, FUnit.AsStream);
+ if FWantTest then
+ begin
+ FOnUnitWriteEvent(Self, FUnit.UnitName+'_test'+FDefaultUnitExtension, FUnit.FTestPascalFile);
+ FOnUnitWriteEvent(Self, FUnit.UnitName+'_c_test.c', FUnit.FTestCFile);
+ end;
end;
end;