diff --git a/applications/gobject-introspection/gir2pascal.ico b/applications/gobject-introspection/gir2pascal.ico
new file mode 100644
index 000000000..0341321b5
Binary files /dev/null and b/applications/gobject-introspection/gir2pascal.ico differ
diff --git a/applications/gobject-introspection/gir2pascal.lpi b/applications/gobject-introspection/gir2pascal.lpi
new file mode 100644
index 000000000..b33d625e1
--- /dev/null
+++ b/applications/gobject-introspection/gir2pascal.lpi
@@ -0,0 +1,108 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/applications/gobject-introspection/gir2pascal.lpr b/applications/gobject-introspection/gir2pascal.lpr
new file mode 100644
index 000000000..6d38deb85
--- /dev/null
+++ b/applications/gobject-introspection/gir2pascal.lpr
@@ -0,0 +1,248 @@
+{
+gir2pascal.lpr
+Copyright (C) 2011 Andrew Haines andrewd207@aol.com
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+}
+program gir2pascal;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}{$IFDEF UseCThreads}
+ cthreads,
+ {$ENDIF}{$ENDIF}
+ Classes, SysUtils, CustApp, DOM, XMLRead, girNameSpaces, girFiles,
+ girpascalwriter, girErrors, girCTypesMapping, girTokens, girObjects;
+
+type
+
+ { TGirConsoleConverter }
+
+ TGirConsoleConverter = class(TCustomApplication)
+ private
+ FWriteCount: Integer;
+ FPaths: TStringList;
+ FOutPutDirectory : String;
+ FFileToConvert: String;
+ FOverWriteFiles: Boolean;
+ procedure AddDefaultPaths;
+ procedure AddPaths(APaths: String);
+ procedure VerifyOptions;
+ procedure Convert;
+
+ //callbacks
+ function NeedGirFile(AGirFile: TObject; NamespaceName: String) : TXMLDocument;
+ procedure WritePascalFile(Sender: TObject; AUnitName: String; AStream: TStringStream);
+ protected
+ procedure DoRun; override;
+ public
+ constructor Create(TheOwner: TComponent); override;
+ destructor Destroy; override;
+ procedure WriteHelp; virtual;
+ end;
+
+{ TGirConsoleConverter }
+
+procedure TGirConsoleConverter.AddDefaultPaths;
+begin
+ FPaths.Add('/usr/share/gir-1.0/');
+end;
+
+procedure TGirConsoleConverter.AddPaths(APaths: String);
+var
+ Strs: TStringList;
+ Str: String;
+begin
+ Strs := TStringList.Create;
+ Strs.Delimiter:=':';
+ Strs.StrictDelimiter:=True;
+ Strs.DelimitedText:=APaths;
+
+ // so we can add the delimiter
+ for Str in Strs do
+ FPaths.Add(IncludeTrailingPathDelimiter(Str));
+
+ Strs.Free;
+end;
+
+procedure TGirConsoleConverter.VerifyOptions;
+begin
+ if not DirectoryExists(FOutPutDirectory) then
+ begin
+ WriteLn(Format('Output directory "%s" does not exist!', [FOutPutDirectory]));
+ Terminate;
+ end;
+ if FFileToConvert = '' then
+ begin
+ WriteLn('No input file specified! See -h for options.');
+ Terminate;
+ Halt;
+ end;
+end;
+
+function TGirConsoleConverter.NeedGirFile(AGirFile: TObject; NamespaceName: String): TXMLDocument;
+var
+ Sr: TSearchRec;
+ Path: String;
+begin
+ Result := nil;
+ for Path in FPaths do
+ begin
+ if FindFirst(Path+NamespaceName+'.gir', faAnyFile, Sr) = 0 then
+ begin
+ ReadXMLFile(Result, Path+Sr.Name);
+ Exit;
+ end;
+ FindClose(Sr);
+ end;
+end;
+
+procedure TGirConsoleConverter.WritePascalFile(Sender: TObject;
+ AUnitName: String; AStream: TStringStream);
+var
+ SStream: TFileStream;
+ OutFileName: String;
+begin
+ Inc(FWriteCount);
+ OutFileName:=FOutPutDirectory+LowerCase(AUnitName)+'.pas';
+ if not FileExists(OutFileName)
+ or (FileExists(OutFileName) and FOverWriteFiles) then
+ begin
+ WriteLn(Format('Writing: %s', [OutFileName]));
+ AStream.Position:=0;
+ ForceDirectories(FOutPutDirectory);
+ SStream := TFileStream.Create(OutFileName, fmCreate or fmOpenReadWrite);
+ SStream.CopyFrom(AStream,AStream.Size);
+ SStream.Free;
+ AStream.Free;
+ end
+ else
+ begin
+ WriteLn(Format('File %s already exists! Stopping.', [OutFileName]));
+ Terminate;
+ Halt;
+ end;
+end;
+
+procedure TGirConsoleConverter.Convert;
+var
+ Doc: TXMLDocument;
+ girFile: TgirFile;
+ Writer: TgirPascalWriter;
+ StartTime, EndTime:TDateTime;
+begin
+ StartTime := Now;
+ ReadXMLFile(Doc, FFileToConvert);
+
+ girFile := TgirFile.Create(nil);
+ girFile.OnNeedGirFile:=@NeedGirFile;
+ girFile.ParseXMLDocument(Doc);
+ Doc.Free;
+
+ Writer := TgirPascalWriter.Create(girFile.NameSpaces);
+ Writer.OnUnitWriteEvent:= @WritePascalFile;
+ Writer.GenerateUnits;
+
+ Writer.Free;
+ EndTime := Now;
+
+ EndTime := EndTime-StartTime;
+ WriteLn(Format('Converted %d file(s) in %f seconds',[FWriteCount, DateTimeToTimeStamp(EndTime).Time / 1000]));
+end;
+
+procedure TGirConsoleConverter.DoRun;
+var
+ ErrorMsg: String;
+begin
+ // quick check parameters
+ ErrorMsg:=CheckOptions('hnp:o:i:w',['help','no-default','paths','output-directory', 'input', 'overwrite-files']);
+ if ErrorMsg<>'' then begin
+ ShowException(Exception.Create(ErrorMsg));
+ Terminate;
+ Exit;
+ end;
+
+ // parse parameters
+ if HasOption('h','help') then begin
+ WriteHelp;
+ Terminate;
+ Exit;
+ end;
+
+ if not HasOption('n', 'no-default') then
+ AddDefaultPaths;
+
+ if HasOption('o', 'output-directory') then
+ FOutPutDirectory:=IncludeTrailingPathDelimiter(GetOptionValue('o', 'output-directory'))
+ else
+ FOutPutDirectory:=IncludeTrailingPathDelimiter(GetCurrentDir);
+
+ FFileToConvert:=GetOptionValue('i','input');
+
+ if HasOption('p', 'paths') then
+ AddPaths(GetOptionValue('p', 'paths'));
+
+ if HasOption('w', 'overwrite-files') then
+ FOverWriteFiles:=True;
+
+ VerifyOptions;
+
+ // does all the heavy lifting
+ Convert;
+
+ // stop program loop
+ Terminate;
+end;
+
+constructor TGirConsoleConverter.Create(TheOwner: TComponent);
+begin
+ inherited Create(TheOwner);
+ FPaths := TStringList.Create;
+end;
+
+destructor TGirConsoleConverter.Destroy;
+begin
+ FPaths.Free;
+ inherited Destroy;
+end;
+
+procedure TGirConsoleConverter.WriteHelp;
+begin
+ Writeln('');
+ writeln(' Usage: ',ExtractFileName(ExeName),' [options] -i filename');
+ Writeln('');
+ Writeln('');
+ Writeln(' -i --input= .gir filename to convert.');
+ Writeln(' -o --output-directory= Directory to write the resulting .pas files to. If not');
+ Writeln(' specified then the current working directory is used.');
+ Writeln(' -w --overwrite-files If the output .pas file(s) already exists then overwrite them.');
+ 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('');
+end;
+
+var
+ Application: TGirConsoleConverter;
+
+{$R *.res}
+
+begin
+ Application:=TGirConsoleConverter.Create(nil);
+ Application.Run;
+ Application.Free;
+end.
+
diff --git a/applications/gobject-introspection/gir2pascal.res b/applications/gobject-introspection/gir2pascal.res
new file mode 100644
index 000000000..7c6cf3e4b
Binary files /dev/null and b/applications/gobject-introspection/gir2pascal.res differ
diff --git a/applications/gobject-introspection/girctypesmapping.pas b/applications/gobject-introspection/girctypesmapping.pas
new file mode 100644
index 000000000..9660193a4
--- /dev/null
+++ b/applications/gobject-introspection/girctypesmapping.pas
@@ -0,0 +1,117 @@
+{
+ctypesmapping.pas
+Copyright (C) 2011 Andrew Haines andrewd207@aol.com
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+}
+unit girCTypesMapping;
+
+{$mode objfpc}{$H+}
+
+interface
+
+const
+ CTypesMax = 31;
+var
+
+ TypesPascalCTypes: array [0..CTypesMax-1] of string =
+ (
+ 'pointer',
+ 'cint',
+ 'cint',
+ 'cuint',
+ 'cuint8',
+ 'cuint16',
+ 'cuint32',
+ 'cuint64',
+ 'cint8',
+ 'cint16',
+ 'cint32',
+ 'cint64',
+ 'csize_t',
+ 'clong',
+ 'culong',
+ 'cushort',
+ 'char',
+ 'Boolean32',
+ 'PtrInt',
+ 'csize_t',
+ 'gpointer',
+ 'cfloat',
+ 'cdouble',
+ 'cdouble',
+ 'char',
+ 'Int64',
+ 'Extended',
+ 'guint32',
+ 'guint32',
+ 'file',
+ 'qword'
+
+ );
+ TypesGTypes: array [0..CTypesMax-1] of string =
+ (
+ 'gpointer',
+ 'int',
+ 'gint',
+ 'guint',
+ 'guint8',
+ 'guint16',
+ 'guint32',
+ 'guint64',
+ 'gint8',
+ 'gint16',
+ 'gint32',
+ 'gint64',
+ 'gsize',
+ 'glong',
+ 'gulong',
+ 'gushort',
+ 'gchar',
+ 'gboolean',
+ 'gssize',
+ 'size_t' ,
+ 'gconstpointer',
+ 'gfloat',
+ 'gdouble',
+ 'double',
+ 'char',
+ 'goffset',
+ 'long double',
+ 'gunichar',
+ 'gunichar2',
+ 'file',
+ 'unsigned long long'
+ );
+
+ function LookupGTypeToCType(AName: String): String;
+
+
+
+implementation
+
+function LookupGTypeToCType(AName: String): String;
+var
+ i: Integer;
+begin
+ //WriteLn('Looking up: ', AName);
+ for i := 0 to CTypesMax-1 do
+ if AName = TypesGTypes[i] then
+ Exit(TypesPascalCTypes[i]);
+ Result := '';
+end;
+
+end.
+
diff --git a/applications/gobject-introspection/girerrors.pas b/applications/gobject-introspection/girerrors.pas
new file mode 100644
index 000000000..099b2f040
--- /dev/null
+++ b/applications/gobject-introspection/girerrors.pas
@@ -0,0 +1,79 @@
+{
+girerrors.pas
+Copyright (C) 2011 Andrew Haines andrewd207@aol.com
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+}
+unit girErrors;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils;
+
+type
+ TGirError = (geError, geWarn, geInfo, geDebug, geFatal, geFuzzy);
+
+ TgirErrorFunc = procedure(UserData: Pointer; AType: TgirError; AMsg: String);
+
+ const
+ geUnhandledNode = 'Unhandled node [%s] "%s"';
+ geUnexpectedNodeType = 'Unexpected node [%s] type: found "%s" expected "%s"';
+ geMissingNode = '[%s] Could not find child node "%s" while looking in node "%s"';
+
+ var
+ girErrorName: array[TGirError] of String =(
+ 'Error',
+ 'Warning',
+ 'Info',
+ 'Debug',
+ 'Fatal',
+ 'Fuzzy'
+ );
+ procedure girError(AType: TgirError; AMsg: String);
+
+ //returns old handler
+ function girSetErrorHandler(AHandler: TgirErrorFunc; AUserData: Pointer): TgirErrorFunc;
+
+implementation
+
+var
+ UserData: Pointer;
+ InternalHandler: TgirErrorFunc;
+
+procedure girError(AType: TgirError; AMsg: String);
+begin
+ if InternalHandler <> nil then
+ begin
+ InternalHandler(UserData, AType, AMsg);
+ Exit;
+ end;
+ // if AType = geDebug then
+ //WriteLn(girErrorName[AType],': ', AMsg);
+
+end;
+
+function girSetErrorHandler(AHandler: TgirErrorFunc; AUserData: Pointer
+ ): TgirErrorFunc;
+begin
+ Result := InternalHandler;
+ InternalHandler:=AHandler;
+ UserData:=AUserData;
+end;
+
+end.
+
diff --git a/applications/gobject-introspection/girfiles.pas b/applications/gobject-introspection/girfiles.pas
new file mode 100644
index 000000000..36d404441
--- /dev/null
+++ b/applications/gobject-introspection/girfiles.pas
@@ -0,0 +1,149 @@
+{
+girfiles.pas
+Copyright (C) 2011 Andrew Haines andrewd207@aol.com
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+}
+unit girFiles;
+
+{$mode objfpc}{$H+}
+{$INTERFACES CORBA}
+
+interface
+
+uses
+ Classes, SysUtils, XMLRead, DOM, girNameSpaces, girParser;
+
+type
+
+ { TgirFile }
+
+ TgirFile = class(IgirParser)
+ private
+ FNameSpaces: TgirNamespaces;
+ FOnNeedGirFile: TgirNeedGirFileEvent;
+ FOwner: TObject;
+ procedure ParseNode(ANode: TDomNode);
+ procedure SetOnNeedGirFile(AValue: TgirNeedGirFileEvent);
+ procedure SetOwner(const AValue: TObject);
+ procedure ParseIncludeNode(ANode: TDomNode; AIncludes: TList);
+ public
+ constructor Create(AOwner: TObject);
+ destructor Destroy; override;
+ procedure ParseXMLDocument(AXML: TXMLDocument);
+ property NameSpaces: TgirNamespaces read FNameSpaces;
+ property Owner: TObject read FOwner write SetOwner;
+ property OnNeedGirFile: TgirNeedGirFileEvent read FOnNeedGirFile write SetOnNeedGirFile;
+
+ end;
+
+implementation
+uses girErrors, girTokens;
+
+{ TgirFile }
+
+
+{ TgirFile }
+
+procedure TgirFile.ParseNode(ANode: TDomNode);
+var
+ NS: TgirNamespace;
+ Includes: TList;
+begin
+ if ANode.NodeName <> 'repository' then
+ girError(geError, 'Not a Valid Document Type!');
+
+ ANode := Anode.FirstChild;
+ Ns := nil;
+ Includes := TList.Create;
+
+ while ANode <> nil do begin
+ case GirTokenNameToToken(ANode.NodeName) of
+ gtInclude: ParseIncludeNode(ANode, Includes);
+ gtNameSpace:
+ begin
+ NS := TgirNamespace.CreateFromNamespaceNode(NameSpaces, ANode, Includes);
+ girError(geDebug, 'Adding Namespace '+NS.NameSpace+' to NameSpaces');
+ FNameSpaces.Add(NS);
+ girError(geDebug, 'Added Namespace '+NS.NameSpace);
+ NS.ParseNode(ANode);
+ end;
+ gtPackage, gtCInclude: ;// ignore for now
+ else
+ girError(geDebug, 'Unknown Node Type for Reposiotory: '+ Anode.NodeName);
+ end;
+ ANode := ANode.NextSibling;
+ end;
+
+
+
+ {ANode := ANode.FindNode('namespace');
+ if ANode = nil then
+ girError(geError, 'namespace node not found')
+ else
+ begin
+
+ end;}
+end;
+
+procedure TgirFile.SetOnNeedGirFile(AValue: TgirNeedGirFileEvent);
+begin
+ FNameSpaces.OnNeedGirFile:=AValue;
+ if FOnNeedGirFile=AValue then Exit;
+ FOnNeedGirFile:=AValue;
+end;
+
+procedure TgirFile.SetOwner(const AValue: TObject);
+begin
+ if FOwner=AValue then exit;
+ FOwner:=AValue;
+end;
+
+procedure TgirFile.ParseIncludeNode(ANode: TDomNode; AIncludes: TList);
+var
+ NS: TgirNamespace;
+ NSName, NSVersion: String;
+begin
+ NSName := TDOMElement(ANode).GetAttribute('name');
+ NSVersion := TDOMElement(ANode).GetAttribute('version');
+ NS := FNameSpaces.FindNameSpace(NSName, NSVersion);
+ if NS <> nil then
+ begin
+ AIncludes.Add(NS);
+ end;
+end;
+
+
+constructor TgirFile.Create(AOwner: TObject);
+begin
+ Owner := AOwner;
+ FNameSpaces := TgirNamespaces.Create(Self);
+end;
+
+destructor TgirFile.Destroy;
+begin
+ FNameSpaces.Free;
+ inherited Destroy;
+end;
+
+procedure TgirFile.ParseXMLDocument(AXML: TXMLDocument);
+begin
+ Self.ParseNode(AXML.DocumentElement);
+end;
+
+
+
+end.
+
diff --git a/applications/gobject-introspection/girnamespaces.pas b/applications/gobject-introspection/girnamespaces.pas
new file mode 100644
index 000000000..f67ca91c9
--- /dev/null
+++ b/applications/gobject-introspection/girnamespaces.pas
@@ -0,0 +1,539 @@
+{
+girnamespaces.pas
+Copyright (C) 2011 Andrew Haines andrewd207@aol.com
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+}
+unit girNameSpaces;
+
+{$mode objfpc}{$H+}
+{$INTERFACES CORBA}
+
+interface
+
+uses
+ Classes, DOM, girParser, girTokens, girObjects, contnrs;
+
+type
+
+ TgirNeedGirFileEvent = function (AGirFile: TObject; BaseNamespaceName: String) : TXMLDocument of object;
+
+ { TgirNamespace }
+
+ TgirNamespace = class(IgirParser)
+ private
+ FConstants: TList;
+ FFunctions: TList;
+ FNameSpace: String;
+ FOnlyImplied: Boolean;
+ FOnNeedGirFile: TgirNeedGirFileEvent;
+ FOwner: TObject;
+ FRequiredNameSpaces: TList;
+ FSharedLibrary: String;
+ FTypes: TFPHashObjectList;
+ FUnresolvedTypes: TList;
+ FVersion: String;
+ procedure SetOnNeedGirFile(AValue: TgirNeedGirFileEvent);
+ protected
+ function AddFuzzyType(AName: String; ACType: String): TGirBaseType;
+ procedure HandleAlias(ANode: TDomNode);
+ procedure HandleConstant(ANode: TDomNode);
+ procedure HandleEnumeration(ANode: TDomNode);
+ procedure HandleBitField(ANode: TDomNode);
+ procedure HandleCallback(ANode: TDOMNode);
+ procedure HandleFunction(ANode: TDOMNode);
+ procedure HandleUnion(ANode: TDOMNode);
+ {
+ Some 'records' have methods these corelate to pascal 'object'
+ GType extends this 'object' type to have a sort of vmt
+ GObject and subclasses extend gtype and adds more vmt method entries and method entries to the instance itself.
+ }
+ procedure HandleRecord(ANode: TDomNode); //could be struct, object, gtype, gobject, or gobject descendant
+ procedure HandlePlainObject(ANode: TDomNode); // is a record/object with methods but no gtype
+ procedure HandleGType(ANode: TDomNode); // one step above plain object
+ procedure HandleClassStruct(ANode: TDomNode); // one step above GType. Is the 'Virtual' part of an object (VMT)
+ procedure HandleClass(ANode: TDomNode); // one step above GType. Is the object structure and it's methods. ClassStruct is like the VMT
+ procedure HandleInterface(ANode: TDomNode);
+ procedure AddGLibBaseTypes;
+ public
+ function LookupTypeByName(AName: String; const ACType: String; const SearchOnly: Boolean = False): TGirBaseType;
+ function ResolveFuzzyType(AFuzzyType: TgirFuzzyType): TGirBaseType;
+ function UsesGLib: Boolean;
+ procedure ResolveFuzzyTypes; // called after done
+ 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);
+ destructor Destroy; override;
+ property NameSpace: String read FNameSpace;
+ property RequiredNameSpaces: TList Read FRequiredNameSpaces;
+ property SharedLibrary: String read FSharedLibrary;
+ property Version: String read FVersion;
+ property OnlyImplied: Boolean read FOnlyImplied;
+ property Owner: TObject Read FOwner;
+
+ // has all types in it (records classes classstructs bitfields callbacks gtypes unions etc) does not contain consts or functions
+ property Types: TFPHashObjectList read FTypes;
+
+ property Functions: TList read FFunctions;
+ property Constants: TList read FConstants;
+ property UnresolvedTypes: TList read FUnresolvedTypes write FUnresolvedTypes;
+ end;
+
+ { TgirNamespaces }
+
+ TgirNamespaces = class(TList)
+ private
+ FOnNeedGirFile: TgirNeedGirFileEvent;
+ FOwner: TObject;
+ function GetNameSpace(AIndex: Integer): TgirNamespace;
+ procedure SetNameSpace(AIndex: Integer; const AValue: TgirNamespace);
+ procedure SetOnNeedGirFile(AValue: TgirNeedGirFileEvent);
+ public
+ constructor Create(AOwner: TObject);
+ function FindNameSpace(AName: String; Version: String = ''): TgirNamespace;
+ property NameSpace[AIndex: Integer]: TgirNamespace read GetNameSpace write SetNameSpace;
+ property Owner: TObject read FOwner;
+ property OnNeedGirFile: TgirNeedGirFileEvent read FOnNeedGirFile write SetOnNeedGirFile;
+ end;
+
+implementation
+uses
+ girErrors, SysUtils, girCTypesMapping;
+
+{ TgirNamespaces }
+
+function TgirNamespaces.GetNameSpace(AIndex: Integer): TgirNamespace;
+begin
+ Result := TgirNamespace(Items[AIndex]);
+end;
+
+procedure TgirNamespaces.SetNameSpace(AIndex: Integer;
+ const AValue: TgirNamespace);
+begin
+ Items[AIndex] := AValue;
+end;
+
+procedure TgirNamespaces.SetOnNeedGirFile(AValue: TgirNeedGirFileEvent);
+begin
+ if FOnNeedGirFile=AValue then Exit;
+ FOnNeedGirFile:=AValue;
+end;
+
+constructor TgirNamespaces.Create(AOwner: TObject);
+begin
+ FOwner := AOwner;
+ inherited Create;
+end;
+
+function TgirNamespaces.FindNameSpace(AName: String; Version: String=''): TgirNamespace;
+var
+ i: Integer;
+ NameSpaceSearchedFor: Boolean;
+ Doc: TXMLDocument;
+begin
+ Result := nil;
+ NameSpaceSearchedFor := False;
+ while Result = nil do
+ begin
+ for i := 0 to Count-1 do
+ begin
+ if NameSpace[i].NameSpace = AName then
+ Exit(NameSpace[i]);
+ end;
+
+ if NameSpaceSearchedFor then
+ Exit;
+ NameSpaceSearchedFor := True;
+ if Assigned(FOnNeedGirFile) then
+ begin
+ Doc := FOnNeedGirFile(Owner, AName+'-'+Version);
+ if Doc <> nil then
+ begin
+ (Owner as IgirParser).ParseNode(Doc.DocumentElement);
+ Doc.Free;
+ end;
+ end;
+ end;
+end;
+
+{ TgirNamespace }
+
+procedure TgirNamespace.ParseNode(ANode: TDomNode);
+
+begin
+ ANode := ANode.FirstChild;
+ while ANode <> nil do
+ begin
+ //girError(geDebug, 'Parsing Node "'+ANode.NodeName+'"');
+ ParseSubNode(ANode);
+ ANode := ANode.NextSibling;
+ end;
+end;
+
+procedure TgirNamespace.SetOnNeedGirFile(AValue: TgirNeedGirFileEvent);
+begin
+ if FOnNeedGirFile=AValue then Exit;
+ FOnNeedGirFile:=AValue;
+end;
+
+function TgirNamespace.AddFuzzyType(AName: String; ACType: String
+ ): TGirBaseType;
+begin
+ Result := TgirFuzzyType.Create(Self, AName, ACType);
+ FTypes.Add(AName, Result);
+ FUnresolvedTypes.Add(Result);
+end;
+
+procedure TgirNamespace.HandleAlias(ANode: TDomNode);
+var
+ Item: TgirAlias;
+begin
+ Item := TgirAlias.Create(Self, ANode);
+ Types.Add(Item.Name, Item);
+end;
+
+procedure TgirNamespace.HandleConstant(ANode: TDomNode);
+var
+ Item: TgirConstant;
+begin
+ Item := TgirConstant.Create(Self, ANode);
+ FConstants.Add(Item);
+end;
+
+procedure TgirNamespace.HandleEnumeration(ANode: TDomNode);
+var
+ Item : TgirEnumeration;
+begin
+ Item := TgirEnumeration.Create(Self, ANode);
+ Types.Add(Item.Name, Item);
+end;
+
+procedure TgirNamespace.HandleBitField(ANode: TDomNode);
+var
+ Item : TgirBitField;
+begin
+ Item := TgirBitField.Create(Self, ANode);
+ Types.Add(Item.Name, Item);
+end;
+
+procedure TgirNamespace.HandleCallback(ANode: TDOMNode);
+var
+ Item: TgirCallback;
+begin
+ Item := TgirCallback.Create(Self, ANode);
+ Types.Add(Item.Name, Item);
+end;
+
+procedure TgirNamespace.HandleFunction(ANode: TDOMNode);
+var
+ Item: TgirFunction;
+begin
+ Item := TgirFunction.Create(Self, ANode);
+ Functions.Add(Item);
+end;
+
+procedure TgirNamespace.HandleUnion(ANode: TDOMNode);
+var
+ Item: TgirUnion;
+begin
+ Item := TgirUnion.Create(Self, ANode);
+ Types.Add(Item.Name, Item);
+end;
+
+procedure TgirNamespace.HandleRecord(ANode: TDomNode);
+var
+ Item: tgirRecord;
+begin
+ if TDOMElement(ANode).GetAttribute('glib:is-gtype-struct-for') <> '' then // is gobject class
+ begin
+ HandleClassStruct(ANode);
+ end
+ else if TDOMElement(ANode).GetAttribute('glib:get-type') <> '' then // is GType
+ HandleGType(ANode)
+ else if (ANode.FindNode('method') <> nil) or (ANode.FindNode('constructor') <> nil) or (ANode.FindNode('function') <> nil) then // is Plain object that is not gtype
+ HandlePlainObject(ANode)
+ else
+ begin
+ Item := tgirRecord.Create(Self, ANode);
+ Types.Add(Item.Name, Item);
+ end;
+
+end;
+
+procedure TgirNamespace.HandlePlainObject(ANode: TDomNode);
+var
+ Item: TgirObject;
+begin
+ Item := TgirObject.Create(Self, ANode);
+ Types.Add(Item.Name, Item);
+end;
+
+procedure TgirNamespace.HandleGType(ANode: TDomNode);
+var
+ Item: TgirGType;
+begin
+ Item := TgirGType.Create(Self, ANode);
+ Types.Add(Item.Name, Item);
+end;
+
+procedure TgirNamespace.HandleClassStruct(ANode: TDomNode);
+var
+ Item: TgirClassStruct;
+begin
+ Item := TgirClassStruct.Create(Self, ANode);
+ FTypes.Add(Item.Name, Item);
+end;
+
+procedure TgirNamespace.HandleClass(ANode: TDomNode);
+var
+ Item: TgirClass;
+begin
+ Item := TgirClass.Create(Self, ANode);
+ FTypes.Add(Item.Name, Item);
+end;
+
+procedure TgirNamespace.HandleInterface(ANode: TDomNode);
+var
+ Item: TgirInterface;
+begin
+ Item := TgirInterface.Create(Self, ANode);
+ FTypes.Add(Item.Name, Item);
+end;
+
+procedure TgirNamespace.AddGLibBaseTypes;
+ procedure AddNativeTypeDef(GType: String; PascalCName: String);
+ var
+ NativeType: TgirNativeTypeDef;
+ begin
+ NativeType:= TgirNativeTypeDef.Create(Self, GType, PascalCName);
+ Types.Add(NativeType.Name, NativeType);
+ end;
+var
+ i: Integer;
+begin
+ for i := 0 to CTypesMax-1 do
+ AddNativeTypeDef(TypesGTypes[i], TypesPascalCTypes[i]);
+end;
+
+procedure TgirNamespace.ResolveFuzzyTypes;
+var
+ i: Integer;
+ FuzzyI: Integer;
+ Fuzzy: TgirFuzzyType;
+ Tmp: TGirBaseType;
+begin
+ i:= 0;
+ FuzzyI := 0;
+ Fuzzy := nil;
+ while (i < FTypes.Count) or (Fuzzy <> nil) do
+ begin
+ // make our loop safe
+ if i >= FTypes.Count then
+ begin
+ i := FuzzyI+1;
+ Fuzzy := nil;
+ continue;
+ end;
+
+ Tmp := TGirBaseType(FTypes.Items[i]);
+
+ if Fuzzy <> nil then
+ begin
+ if {(Tmp.CType = Fuzzy.CType) or} (Tmp.Name = Fuzzy.Name) then
+ begin
+ Fuzzy.ResolvedType := Tmp;
+ Tmp.ImpliedPointerLevel:=Fuzzy.ImpliedPointerLevel;
+ i := FuzzyI+1;
+ Fuzzy := nil;
+ //WriteLn('Resolved Fuzzy Type: ', Tmp.CType);
+ continue;
+ end;
+ end;
+
+ if (Fuzzy = nil) and (Tmp.ObjectType = otFuzzyType) and (TgirFuzzyType(Tmp).ResolvedType = nil) then
+ begin
+ if i >= FTypes.Count then
+ break;
+ FuzzyI:=i;
+ Fuzzy := TgirFuzzyType(Tmp);
+ //WriteLn('Looking For: ',Fuzzy.CType);
+ end;
+ inc(i);
+ end;
+
+end;
+
+procedure TgirNamespace.ParseSubNode(ANode: TDomNode);
+begin
+ case GirTokenNameToToken(ANode.NodeName) of
+ gtAlias: HandleAlias(ANode);
+ gtConstant: HandleConstant(ANode);
+ gtRecord: HandleRecord(ANode);
+ gtBitField: HandleBitField(ANode);
+ gtEnumeration: HandleEnumeration(ANode);
+ gtCallback: HandleCallback(ANode);
+ gtUnion: HandleUnion(ANode);
+ gtFunction: HandleFunction(ANode);
+ gtClass: HandleClass(ANode);
+ gtInterface: HandleInterface(ANode);
+ gtMethod: HandleFunction(ANode);
+ else
+ girError(geError, 'Unknown NodeType: '+ANode.NodeName);
+ end;
+ ResolveFuzzyTypes;
+end;
+
+function TgirNamespace.LookupTypeByName(AName: String; const ACType: String; const SearchOnly: Boolean = False): TGirBaseType;
+ function StripPointers(ACPointeredType: String; PtrLevel: PInteger = nil): String;
+ var
+ i: Integer;
+ begin
+ for i := Length(ACPointeredType) downto 1 do
+ if ACPointeredType[i] = '*' then
+ begin
+ Delete(ACPointeredType, i, 1);
+ end;
+ if PtrLevel <> nil then
+ Inc(PtrLevel^);
+ Result := ACPointeredType;
+ end;
+
+var
+ ReqNS,
+ NS: TgirNamespace;
+ NSString: String;
+ FPos: Integer;
+ i: Integer;
+ Current: TGirBaseType;
+ PointerLevel: Integer = 0;
+ PlainCType: String;
+begin
+ Result := nil;
+ NS := Self;
+ FPos := Pos('.', AName);
+ PlainCType:=StringReplace(StripPointers(ACType, @PointerLevel), ' ', '_', [rfReplaceAll]);
+
+ if FPos > 0 then // type includes namespace "NameSpace.Type"
+ begin
+ NSString:=Copy(AName,1,FPos-1);
+ NS := (Owner As TgirNamespaces).FindNameSpace(NSString);
+ if NS = nil then
+ girError(geError, 'Referenced Namespace "'+NSString+'" not found while looking for '+AName);
+ AName := Copy(AName, FPos+1, Length(AName));
+ end;
+
+ // some basic fixes
+ if PlainCType = 'gchar' then
+ AName := 'utf8';
+
+ if PlainCType = 'GType' then
+ AName := 'Type';
+
+ Result := TGirBaseType(NS.Types.Find(AName));
+ if (Result <> nil) and (Result.ObjectType = otFuzzyType) and (TgirFuzzyType(Result).ResolvedType <> nil) then
+ Result := TgirFuzzyType(Result).ResolvedType;
+
+ if (Result = nil) and not SearchOnly then
+ begin
+ for i := 0 to NS.RequiredNameSpaces.Count-1 do
+ begin
+ ReqNS := TgirNamespace(NS.RequiredNameSpaces.Items[i]);
+ Current := ReqNS.LookupTypeByName(AName, ACType, True);
+ if Current <> nil then
+ begin
+ if (Current.ObjectType = otFuzzyType) and (TgirFuzzyType(Current).ResolvedType <> nil) then
+ Current := TgirFuzzyType(Current).ResolvedType;
+ Result := Current;
+ Break;
+ end;
+ end;
+ if Result = nil then
+ Result := NS.AddFuzzyType(AName, ACType);
+ end;
+ if Result <> nil then
+ Result.ImpliedPointerLevel:=PointerLevel;
+end;
+
+function TgirNamespace.ResolveFuzzyType(AFuzzyType: TgirFuzzyType): TGirBaseType;
+var
+ i: Integer;
+begin
+ for i := 0 to FTypes.Count-1 do
+ begin
+ if (TGirBaseType(FTypes[i]) <> AFuzzyType) and (TGirBaseType(FTypes[i]).Name = AFuzzyType.Name) then
+ Exit(TGirBaseType(FTypes[i]));
+ end;
+end;
+
+function TgirNamespace.UsesGLib: Boolean;
+var
+ Tmp: Pointer;
+ NS: TgirNamespace absolute Tmp;
+begin
+ Result := False;
+ if Pos('glib', LowerCase(NameSpace)) = 1 then
+ Exit(True);
+ for Tmp in RequiredNameSpaces do
+ if Pos('glib',LowerCase(NS.NameSpace)) = 1 then
+ Exit(True);
+end;
+
+constructor TgirNamespace.Create(AOwner:TObject; AImpliedNamespace: String);
+begin
+ Fowner:=AOwner;
+ FOnlyImplied:=True;
+ FNameSpace:=AImpliedNamespace;
+ girError(geDebug, 'Creating Stub for namespace: '+ AImpliedNamespace);
+end;
+
+constructor TgirNamespace.CreateFromNamespaceNode(AOwner:TObject; ANode: TDOMNode; AIncludes: TList);
+var
+ Node: TDOMElement absolute ANode;
+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);
+ FNameSpace:=Node.GetAttribute('name');
+ FRequiredNameSpaces := AIncludes;
+ FSharedLibrary:=Node.GetAttribute('shared-library');
+ FVersion:=Node.GetAttribute('version');
+ girError(geDebug, Format('Creating namespace=%s Version=%s LibName=%s',[FNameSpace, FVersion, FSharedLibrary]));
+
+ FConstants := TList.Create;
+ FFunctions := TList.Create;
+ FTypes := TFPHashObjectList.Create(True);
+ FUnresolvedTypes := TList.Create;
+
+ if FNameSpace = 'GLib' then
+ AddGLibBaseTypes;
+end;
+
+destructor TgirNamespace.Destroy;
+begin
+ FConstants.Free;
+ FFunctions.Free;
+ FTypes.Free;
+ FUnresolvedTypes.Free;
+ if Assigned(FRequiredNameSpaces) then
+ FRequiredNameSpaces.Free;
+
+ inherited Destroy;
+end;
+
+end.
+
diff --git a/applications/gobject-introspection/girobjects.pas b/applications/gobject-introspection/girobjects.pas
new file mode 100644
index 000000000..e3270911c
--- /dev/null
+++ b/applications/gobject-introspection/girobjects.pas
@@ -0,0 +1,1048 @@
+{
+girobjects.pas
+Copyright (C) 2011 Andrew Haines andrewd207@aol.com
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+}
+unit girObjects;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, DOM, girTokens;
+
+type
+
+ TGirModeState = (msNone, msWriting, msWritten);
+
+ TGirObjectType = (otBaseType, otAlias, otArray, otBitfield, otCallback, otClass,
+ otClassStruct, otConstant, otConstructor, otEnumeration, otFunction,
+ otFunctionReturn, otFunctionParam, otFuzzyType, otGlibSignal,
+ otGType, otInterface, otMethod, otNativeType, otObject, otProperty,
+ otRecord, otTypeParam, otUnion, otVirtualMethod);
+
+ { TGirBaseType }
+
+ TGirBaseType = class
+ private
+ FBits: Integer;
+ FCType: String;
+ FDoc: String;
+ FForwardDefinitionWritten: Boolean;
+ FImpliedPointerLevel: Integer;
+ FName: String;
+ FObjectType: TGirObjectType;
+ FOwner: TObject;
+ FTranslatedName: String;
+ FVersion: String;
+ FWriting: TGirModeState;
+ procedure SetImpliedPointerLevel(AValue: Integer);
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); virtual;
+ property CType: String read FCType write FCType;
+ property Name: String read FName;
+ property TranslatedName: String read FTranslatedName write FTranslatedName;
+ property ImpliedPointerLevel: Integer read FImpliedPointerLevel write SetImpliedPointerLevel; // only grows
+ property Owner: TObject Read FOwner; // TgirNameSpace
+ property Doc: String read FDoc;
+ property Bits: Integer read FBits;
+ property Version: String read FVersion;
+ property ForwardDefinitionWritten: Boolean read FForwardDefinitionWritten write FForwardDefinitionWritten;
+ property Writing: TGirModeState read FWriting write FWriting;
+ property ObjectType: TGirObjectType read FObjectType;
+ end;
+
+ { TgirNativeTypeDef }
+
+ TgirNativeTypeDef = class(TGirBaseType)
+ private
+ FPAs: String;
+ FPascalName: String;
+ public
+ constructor Create(AOwner:TObject; AGType: String; APascalCTypeName: String);
+ property PascalName: String read FPascalName write FPascalName;
+ end;
+
+ { TgirFuzzyType }
+
+ TgirFuzzyType = class(TGirBaseType)
+ private
+ FResolvedType: TGirBaseType;
+ function GetResolvedType: TGirBaseType;
+ procedure SetResolvedType(const AValue: TGirBaseType);
+ public
+ constructor Create(AOwner: TObject; AName: String; ACtype: String);
+ property ResolvedType: TGirBaseType read GetResolvedType write SetResolvedType;
+ end;
+
+ { TgirAlias }
+
+ TgirAlias = class(TGirBaseType)
+ private
+ FForType: TGirBaseType;
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ property ForType: TGirBaseType read FForType;
+ end;
+
+ { TgirTypeParam }
+
+ TgirTypeParam = class(TGirBaseType)
+ private
+ FVarType: TGirBaseType;
+ FPointerLevel: Integer;
+ function GetPointerLevel: Integer;
+ function GetType: TGirBaseType;
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ property VarType: TGirBaseType read GetType;
+ property PointerLevel: Integer read GetPointerLevel;
+ end;
+
+ { TgirProperty }
+
+ TgirProperty = class(TgirBaseType)
+ private
+ FIsArray: Boolean;
+ FPropType: TgirBaseType;
+ FWriteable: Boolean;
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ property PropType: TgirBaseType read FPropType;
+ property Writable: Boolean read FWriteable;
+ property IsArray: Boolean read FIsArray;
+ end;
+
+ { TgirArray }
+
+ TgirArray = class(TgirTypeParam)
+ private
+ FFixedSize: Integer;
+ FParentFieldName: String;
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ property FixedSize: Integer read FFixedSize;
+ property ParentFieldName: String read FParentFieldName;
+ end;
+
+ { TgirConstant }
+
+ TgirConstant = class(TGirBaseType)
+ private
+ FIsString: Boolean;
+ FTypeDecl: TGirBaseType;
+ FValue: String;
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ property TypeDecl: TGirBaseType read FTypeDecl;
+ property Value: String read FValue;
+ property IsString: Boolean read FIsString;
+ end;
+
+ { TgirEnumeration }
+ PgirEnumMember = ^TgirEnumMember;
+ TgirEnumMember = record
+ Name: String;
+ Value: String;
+ CIdentifier: String;
+ end;
+
+ { TgirEnumList }
+
+ TgirEnumList = class(TList)
+ private
+ function GetMember(AIndex: Integer): PgirEnumMember;
+ public
+ procedure Delete(Index: Integer);
+ property Member[AIndex: Integer]: PgirEnumMember read GetMember;
+ end;
+
+
+ TgirEnumeration = class(TGirBaseType)
+ private
+ FMembers: TgirEnumList;
+ procedure AddMember(AName, AValue, ACIdentifier: String);
+ procedure HandleFunction(ANode: TDomNode);
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ destructor Destroy; override;
+ property Members: TgirEnumList read FMembers;
+ end;
+
+ { TgirBitField }
+
+ TgirBitField = class(TgirEnumeration)
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+
+ end;
+
+ { TGirFunctionParam }
+
+ TGirFunctionParam = class(TgirTypeParam)
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ end;
+
+ { TgirFunctionReturn }
+
+ TgirFunctionReturn = class(TgirTypeParam)
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ end;
+
+ { TgirParamList }
+
+ TgirParamList= class (TList)
+ private
+ function GetParam(AIndex: Integer): TGirFunctionParam;
+ public
+ property Param[AIndex: Integer]: TGirFunctionParam read GetParam;
+ end;
+
+ { TgirFunction }
+
+ TgirFunction = class(TGirBaseType)
+ private
+ FCIdentifier: String;
+ FDeprecated: Boolean;
+ FDeprecatedVersion: String;
+ FParams: TgirParamList;
+ FReturns: TgirFunctionReturn;
+ publiC
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ destructor Destroy; override;
+ property Params: TgirParamList read FParams;
+ property Returns: TgirFunctionReturn read FReturns;
+ property CIdentifier: String read FCIdentifier;
+ property Deprecated: Boolean read FDeprecated;
+ property DeprecatedVersion: String read FDeprecatedVersion;
+ end;
+
+ { TgirMethod }
+
+ TgirMethod = class(TgirFunction)
+ constructor Create(AOwner: TObject; ANode:TDOMNode); override;
+ end;
+
+ { TgirGlibSignal }
+
+ TgirGlibSignal = class(TgirFunction)
+ constructor Create(AOwner: TObject; ANode:TDOMNode); override;
+
+ end;
+
+ { TgirVirtualMethod }
+
+ TgirVirtualMethod = class(TgirMethod)
+ constructor Create(AOwner: TObject; ANode:TDOMNode); override;
+ end;
+
+ { TgirCallback }
+
+ TgirCallback = class(TgirFunction)
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ //property OwnsResult: Boolean;
+ end;
+
+ { TgirConstructor }
+
+ TgirConstructor = class(TgirFunction)
+ constructor Create(AOwner: TObject; ANode:TDOMNode); override;
+ end;
+
+ { TgirFieldsList }
+
+ TgirFieldsList = class(TFPList)
+ private
+ function GetField(AIndex: Integer): TGirBaseType;
+ public
+ property Field[AIndex: Integer]: TGirBaseType read GetField;
+ end;
+
+ { tgirRecord }
+
+ TgirRecord = class(TGirBaseType)
+ private
+ FFields: TgirFieldsList;
+ protected
+ procedure HandleUnion(ANode: TDomNode);
+ procedure HandleField(ANode: TDomNode);
+ procedure ParseNode(ANode: TDomNode; ANodeType: TGirToken); virtual;
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ destructor Destroy; override;
+ property Fields: TgirFieldsList read FFields;
+ end;
+
+ { TgirUnion }
+
+ TgirUnion = class(TgirRecord)
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ procedure ParseNode(ANode: TDomNode; ANodeType: TGirToken); override;
+ end;
+
+
+ { TgirObject }
+
+ TgirObject = class(TgirRecord)
+ protected
+ procedure ParseNode(ANode: TDomNode; ANodeType: TGirToken); override;
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ end;
+
+ { TgirGType }
+
+ TgirGType = class(TgirObject)
+ private
+ FGetTypeFunction: String;
+ protected
+ procedure ParseNode(ANode: TDomNode; ANodeType: TGirToken); override;
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ property GetTypeFunction: String read FGetTypeFunction;
+ end;
+
+ { TgirClass }
+
+ { TgirClassStruct }
+
+ TgirClassStruct = class(TgirGType)
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+
+ end;
+
+ TgirClass = class(TgirGType)
+ private
+ FClassStruct: TgirClassStruct;
+ FInterfaces: TList;
+ FParentClass: TgirClass;
+ function GetParentClass: TgirClass;
+ protected
+ procedure ParseNode(ANode: TDomNode; ANodeType: TGirToken); override;
+ procedure AddInterface(ANode: TDomNode);
+ public
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ destructor Destroy; override;
+ property Interfaces: TList read FInterfaces;
+ property ParentClass: TgirClass read GetParentClass;
+ property ClassStruct: TgirClassStruct read FClassStruct;
+
+ end;
+
+ { TgirInterface }
+
+ TgirInterface = class(TgirClass)
+ protected
+ constructor Create(AOwner: TObject; ANode: TDomNode); override;
+ procedure ParseNode(ANode: TDomNode; ANodeType: TGirToken); override;
+ end;
+
+
+
+
+
+
+implementation
+uses girNameSpaces, girErrors;
+
+{ TgirClassStruct }
+
+constructor TgirClassStruct.Create(AOwner: TObject; ANode: TDomNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otClassStruct;
+end;
+
+{ TgirConstructor }
+
+constructor TgirConstructor.Create(AOwner: TObject; ANode: TDOMNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otConstructor;
+end;
+
+{ TgirCallback }
+
+constructor TgirCallback.Create(AOwner: TObject; ANode: TDomNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otCallback;
+end;
+
+{ TgirVirtualMethod }
+
+constructor TgirVirtualMethod.Create(AOwner: TObject; ANode: TDOMNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otVirtualMethod;
+end;
+
+{ TgirGlibSignal }
+
+constructor TgirGlibSignal.Create(AOwner: TObject; ANode: TDOMNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otGlibSignal;
+end;
+
+{ TgirMethod }
+
+constructor TgirMethod.Create(AOwner: TObject; ANode: TDOMNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otMethod;
+end;
+
+{ TgirBitField }
+
+constructor TgirBitField.Create(AOwner: TObject; ANode: TDomNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otBitfield;
+end;
+
+{ TgirFieldsList }
+
+function TgirFieldsList.GetField(AIndex: Integer): TGirBaseType;
+begin
+ Result := TGirBaseType(Items[AIndex]);
+end;
+
+{ TgirParamList }
+
+function TgirParamList.GetParam(AIndex: Integer): TGirFunctionParam;
+begin
+ Result := TGirFunctionParam(Items[AIndex]);
+end;
+
+constructor TgirNativeTypeDef.Create(AOwner:TObject; AGType: String; APascalCTypeName: String);
+begin
+ FOwner := AOwner;
+ FCType:=AGType;
+ FName:=AGType; // used by LookupName in namespace
+ //now some fixups :(
+ if FName = 'gchar' then
+ FName := 'utf8';
+ FTranslatedName:=AGType;
+ FPascalName:=APascalCTypeName;
+ //to create PPType
+ FImpliedPointerLevel:=2;
+ FObjectType:=otNativeType;
+end;
+
+{ TgirNativeTypeDef }
+
+
+{ TgirInterface }
+
+constructor TgirInterface.Create(AOwner: TObject; ANode: TDomNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otInterface;
+end;
+
+procedure TgirInterface.ParseNode(ANode: TDomNode; ANodeType: TGirToken);
+begin
+ case ANodeType of
+ gtPrerequisite:; // ignore for now since these are bindings.
+ //The interface expects the implementing object to be a descendant of the prerequisite
+ else
+ inherited ParseNode(ANode, ANodeType);
+
+ end;
+end;
+
+{ TgirProperty }
+
+constructor TgirProperty.Create(AOwner: TObject; ANode: TDomNode);
+var
+ Node: TDOMElement;
+begin
+ inherited Create(AOwner, ANode);
+ FWriteable := (TDOMElement(ANode).GetAttribute('writable') = '1');
+ Node := TDomElement(ANode.FirstChild);
+ while Node <> nil do
+ begin
+ case GirTokenNameToToken(Node.NodeName) of
+ gtDoc:; // ignore
+ gtType: FPropType := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), Node.GetAttribute('c:type'));
+ gtArray:
+ begin
+ FIsArray:=True;
+ FPropType := TgirNamespace(Owner).LookupTypeByName(TDomElement(Node.FindNode('type')).GetAttribute('name'), Node.GetAttribute('c:type'));
+ end
+ else
+ WriteLn('Unknown Node Type for property : ', Node.NodeName);
+ halt(1);
+ end;
+ Node := TDOMElement(Node.NextSibling);
+ end;
+ FObjectType:=otProperty;
+end;
+
+{ TgirClass }
+
+function TgirClass.GetParentClass: TgirClass;
+begin
+ if (FParentClass <> nil) and (FParentClass.InheritsFrom(TgirFuzzyType)) and (TgirFuzzyType(FParentClass).ResolvedType <> nil) then
+ FParentClass := TgirClass(TgirFuzzyType(FParentClass).ResolvedType);
+ Result := FParentClass;
+end;
+
+procedure TgirClass.ParseNode(ANode: TDomNode; ANodeType: TGirToken);
+begin
+ case ANodeType of
+ gtProperty: Fields.Add(TgirProperty.Create(Owner, ANode));
+ gtVirtualMethod: Fields.Add(TgirVirtualMethod.Create(Owner, ANode));
+ gtGlibSignal: Fields.Add(TgirGlibSignal.Create(Owner, ANode));
+ gtImplements: AddInterface(ANode)
+ else
+ inherited ParseNode(ANode, ANodeType);
+ end;
+end;
+
+procedure TgirClass.AddInterface(ANode: TDomNode);
+var
+ Intf: TGirBaseType;
+ Node: TDOMElement absolute ANode;
+begin
+ Intf := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), '');
+ FInterfaces.Add(Intf);
+end;
+
+constructor TgirClass.Create(AOwner: TObject; ANode: TDomNode);
+var
+ Parent: String;
+begin
+ FInterfaces := TList.Create; // must be before inherited else list does not exist when ParseNeode is called
+ inherited Create(AOwner, ANode);
+ Parent := TDOMElement(ANode).GetAttribute('parent');
+ FParentClass := TgirClass(TgirNamespace(Owner).LookupTypeByName(Parent, '', True));
+ if CType = '' then
+ CType := TDOMElement(ANode).GetAttribute('glib:type-name');
+ FObjectType:=otClass;
+end;
+
+destructor TgirClass.Destroy;
+begin
+ FInterfaces.Free;
+ inherited Destroy;
+end;
+
+{ TgirUnion }
+
+constructor TgirUnion.Create(AOwner: TObject; ANode: TDomNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otUnion;
+end;
+
+procedure TgirUnion.ParseNode(ANode: TDomNode; ANodeType: TGirToken);
+begin
+ case ANodeType of
+ gtRecord: Fields.Add(TgirRecord.Create(Owner, ANode));
+ gtMethod: Fields.Add(TgirMethod.Create(Owner, ANode));
+ gtConstructor: Fields.Add(TgirConstructor.Create(Owner, ANode));
+ else
+ inherited ParseNode(ANode, ANodeType);
+ end;
+end;
+
+{ TgirGType }
+
+procedure TgirGType.ParseNode(ANode: TDomNode; ANodeType: TGirToken);
+begin
+ case ANodeType of
+ gtConstructor: Fields.Add(TgirConstructor.Create(Owner, ANode));
+ //gtFunction: Fields.Add(TgirFunction.Create(Owner, ANode));
+ else
+ inherited ParseNode(ANode, ANodeType);
+ end;
+end;
+
+constructor TgirGType.Create(AOwner: TObject; ANode: TDomNode);
+begin
+ inherited Create(AOwner, ANode);
+ FGetTypeFunction := TDOMElement(ANode).GetAttribute('glib:get-type');
+ FObjectType:=otGType;
+end;
+
+{ TgirArray }
+
+constructor TgirArray.Create(AOwner: TObject; ANode: TDomNode);
+var
+ Node: TDomELement;
+ Tmp: String;
+begin
+ inherited Create(AOwner, ANode);
+ Node := TDomElement(ANode.FindNode('type'));
+ if Node <> nil then
+ begin
+ FVarType := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), CType);
+ TryStrToInt(TDomElement(ANode).GetAttribute('fixed-size'), FFixedSize);
+ end;
+
+ Node := TDOMElement(ANode.ParentNode);
+ FParentFieldName := Node.GetAttribute('name');
+ if FName = '' then
+ FName := FParentFieldName;
+ FObjectType:=otArray;
+end;
+
+{ TgirObject }
+
+procedure TgirObject.ParseNode(ANode: TDomNode; ANodeType: TGirToken);
+begin
+ case ANodeType of
+ //gtMethod: (Owner as TgirNamespace).ParseSubNode(ANode);
+ gtMethod: Fields.Add(TgirMethod.Create(Owner, ANode));
+ else
+ inherited ParseNode(ANode, ANodeType);
+ end;
+end;
+
+constructor TgirObject.Create(AOwner: TObject; ANode: TDomNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otObject;
+end;
+
+{ tgirRecord }
+
+
+
+
+procedure TgirRecord.HandleUnion(ANode: TDomNode);
+var
+ Item: TgirUnion;
+begin
+ Item := TgirUnion.Create(Owner, ANode);
+ FFields.Add(Item);
+end;
+
+procedure TgirRecord.HandleField(ANode: TDomNode);
+var
+ Node: TDOMNode;
+ attr: TDomNode;
+ Attrs: TDOMNamedNodeMap;
+ Item: TGirBaseType;
+begin
+ Node := ANode.FirstChild;
+ while Node <> nil do
+ begin
+ Attrs := ANode.Attributes;
+ case GirTokenNameToToken(Node.NodeName) of
+ gtDoc:;
+ gtType: FFields.Add(TgirTypeParam.Create(Owner, ANode));
+ gtCallback: FFields.Add(TgirCallback.Create(Owner, Node));
+ gtArray: Fields.Add(TgirArray.Create(Owner, Node));
+ else
+ girError(geError ,Format(geUnhandledNode,[ClassName, Node.NodeName]));
+ halt;
+ end;
+ Node := Node.NextSibling;
+ end;
+
+end;
+
+procedure tgirRecord.ParseNode(ANode: TDomNode; ANodeType: TGirToken);
+var
+ NameStr: String;
+begin
+ case ANodeType of
+ gtDoc:;
+ gtField : HandleField(ANode);
+ gtUnion: HandleUnion(ANode);
+ gtFunction: begin
+ //(Owner as TgirNamespace).ParseSubNode(ANode);
+ //we'll add it for now since it may be interesting to make this into an object later
+ Fields.Add(TgirFunction.Create(Owner, ANode));
+ end
+ else
+ NameStr := TDOMElement(ANode).GetAttribute('name');
+ girError(geWarn,Format(geUnhandledNode,[ClassName, ANode.ParentNode.Attributes.Item[0].NodeValue +' : >> '+ ANode.NodeName+' << '+ NameStr]));
+ end;
+end;
+
+constructor tgirRecord.Create(AOwner: TObject; ANode: TDomNode);
+var
+ Node: TDomNode;
+begin
+ inherited Create(AOwner, ANode);
+ FFields := TgirFieldsList.Create;
+ {$warning not implemented}
+ Node := ANode.FirstChild;
+ while Node <> nil do
+ begin
+ ParseNode(Node, GirTokenNameToToken(Node.NodeName));
+ Node := Node.NextSibling;
+ end;
+ FObjectType:=otRecord;
+end;
+
+destructor tgirRecord.Destroy;
+begin
+ FFields.Free;
+ inherited Destroy;
+end;
+
+{ TgirFunctionReturn }
+
+constructor TgirFunctionReturn.Create(AOwner: TObject; ANode: TDomNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otFunctionReturn;
+end;
+
+{ TGirFunctionParam }
+
+constructor TGirFunctionParam.Create(AOwner: TObject; ANode: TDomNode);
+begin
+ inherited Create(AOwner, ANode);
+ FObjectType:=otFunctionParam;
+end;
+
+{ TgirTypeParam }
+
+function TgirTypeParam.GetType: TGirBaseType;
+begin
+ if (FVarType <> nil) and (FVarType.ClassType = TgirFuzzyType) and (TgirFuzzyType(FVarType).ResolvedType <> nil) then
+ begin
+ TgirFuzzyType(FVarType).ResolvedType.ImpliedPointerLevel:=FVarType.ImpliedPointerLevel;
+ FVarType := TgirFuzzyType(FVarType).ResolvedType;
+ end;
+ Result := FVarType;
+end;
+
+function TgirTypeParam.GetPointerLevel: Integer;
+var
+ i: Integer;
+begin
+ Result := FPointerLevel;
+end;
+
+procedure NodeURL(ANode: TDomNode);
+var
+ URL: String = '';
+begin
+ while ANode <> nil do
+ begin
+ try
+ Url := '/'+ANode.NodeName+':'+TDOMElement(ANode).GetAttribute('name')+Url;
+ ANode := ANode.ParentNode;
+
+ except
+ ANode := nil
+ end;
+ end;
+ WriteLn(URL);
+end;
+
+constructor TgirTypeParam.Create(AOwner: TObject; ANode: TDomNode);
+ function PointerLevelFromVarName(AName: String): Integer;
+ var
+ C: Char;
+ begin
+ Result := 0;
+ for C in AName do
+ if C = '*' then
+ Inc(Result);
+ end;
+
+var
+ Node: TDOMElement;
+ C_Type: String;
+ Tmp: String;
+ Token: TGirToken;
+ VarTypeName: String;
+begin
+ inherited Create(AOwner, ANode);
+ //NodeURL(ANode);
+ //Node := TDomELement(ANode.FindNode('type'));
+ Node := TDOMElement(ANode.FirstChild);
+ while Node <> nil do
+ begin
+ // it's one or the other
+ Token := GirTokenNameToToken(Node.NodeName);
+ case Token of
+ gtDoc:;
+ gtType: begin
+ C_Type := Node.GetAttribute('c:type');
+ VarTypeName:=Node.GetAttribute('name');
+ if VarTypeName = '' then
+ VarTypeName:= StringReplace(C_Type, '*', '', [rfReplaceAll]);
+ FVarType := TgirNamespace(Owner).LookupTypeByName(VarTypeName, C_Type);
+ end;
+ gtArray: begin
+ C_Type := Node.GetAttribute('c:type');
+ FVarType := TgirNamespace(Owner).LookupTypeByName(TDOMElement(Node.FirstChild).GetAttribute('name'), C_Type);
+ Tmp := Node.GetAttribute('length');
+ if Tmp <> '' then
+ FVarType.ImpliedPointerLevel:=StrToInt(Tmp);
+ end;
+ gtVarArgs: begin
+ FVarType := nil
+ end
+ else
+ girError(geError, Format(geUnexpectedNodeType,[ClassName, Node.NodeName, GirTokenName[gtParameter]]));
+ end;
+ Node := TDOMElement(Node.NextSibling);
+ end;
+
+
+
+ FPointerLevel := PointerLevelFromVarName(C_Type);
+
+ if (FVarType <> nil) {and (GirTokenNameToToken(ANode.NodeName) = gtArray)} then
+ FVarType.ImpliedPointerLevel := PointerLevelFromVarName(CType);
+
+ if Token <> gtVarArgs then
+ FVarType.ImpliedPointerLevel:=PointerLevel; //only will grow
+ FObjectType:=otTypeParam;
+end;
+
+{ TgirFunction }
+
+constructor TgirFunction.Create(AOwner: TObject; ANode: TDomNode);
+var
+ Node: TDOMNode;
+ NodeToken: TGirToken;
+
+ procedure CreateParameters(ANode: TDomNode);
+ var
+ PNode: TDomNode;
+ Param: TGirFunctionParam;
+ begin
+ PNode := ANode.FirstChild;
+ while PNode <> nil do
+ begin
+ case GirTokenNameToToken(PNode.NodeName) of
+ gtDoc:;
+ gtParameter:
+ begin
+ Param := TGirFunctionParam.Create(AOwner, PNode);
+ FParams.Add(Param);
+ end;
+ else
+ girError(geError, Format(geUnexpectedNodeType,[ClassName, PNode.NodeName, GirTokenName[gtParameter]]));
+ end;
+ PNode := PNode.NextSibling;
+ end;
+ end;
+
+begin
+ inherited Create(AOwner, ANode);
+ FParams := TgirParamList.Create;
+ FCIdentifier:=TDOMElement(ANode).GetAttribute('c:identifier');
+ if FName = '' then FName:=FCIdentifier;
+ if FName = '' then FName:=StringReplace(FCType, '*', '', [rfReplaceAll]);
+
+ NodeToken := GirTokenNameToToken(ANode.NodeName);
+ if not (NodeToken in [gtFunction, gtMethod, gtCallback, gtConstructor, gtVirtualMethod, gtGlibSignal]) then
+ begin
+ girError(geError, Format(geUnexpectedNodeType,[ClassName,ANode.NodeName, GirTokenName[gtFunction]+'", "'+ GirTokenName[gtMethod]+'", "'+
+ GirTokenName[gtCallback]+'", "'+ GirTokenName[gtConstructor]+'", "'+
+ GirTokenName[gtVirtualMethod]+'", "'+ GirTokenName[gtGlibSignal] ]));
+ Halt;
+ end;
+
+ Node := ANode.FirstChild;
+ while Node <> nil do
+ begin
+ case GirTokenNameToToken(Node.NodeName) of
+ gtDoc:;
+ gtReturnValue: FReturns := TgirFunctionReturn.Create(AOwner, Node);
+ gtParameters: CreateParameters(Node);
+ else
+ girError(geWarn, Format(geUnhandledNode,[ClassName, Node.NodeName]));
+ end;
+ Node := Node.NextSibling;
+ end;
+ if FReturns = nil then
+ begin
+ WriteLn('Return value not defined for: ', Name);
+ Halt
+ end;
+ FDeprecated:=TDOMElement(ANode).GetAttribute('deprecated') <> '';
+ if FDeprecated then
+ FDeprecatedVersion:=TDOMElement(ANode).GetAttribute('deprecated-version');
+ FObjectType:=otFunction;
+end;
+
+destructor TgirFunction.Destroy;
+begin
+ FParams.Free;
+ inherited Destroy;
+end;
+
+{ TgirEnumList }
+
+function TgirEnumList.GetMember(AIndex: Integer): PgirEnumMember;
+begin
+ Result:= PgirEnumMember(Items[AIndex]);
+end;
+
+procedure TgirEnumList.Delete(Index: Integer);
+begin
+ Dispose(Member[Index]);
+ TList(Self).Delete(Index);
+end;
+
+{ TgirEnumeration }
+
+procedure TgirEnumeration.AddMember(AName, AValue, ACIdentifier: String);
+var
+ Member: PgirEnumMember;
+begin
+ if ACIdentifier = 'GDK_DRAG_MOTION' then ACIdentifier := 'GDK_DRAG_MOTION_';
+ if ACIdentifier = 'GDK_DRAG_STATUS' then ACIdentifier := 'GDK_DRAG_STATUS_';
+ if ACIdentifier = 'GDK_PROPERTY_DELETE' then ACIdentifier := 'GDK_PROPERTY_DELETE_';
+
+
+ New(Member);
+ Member^.Name:=AName;
+ Member^.Value:=AValue;
+ Member^.CIdentifier:=ACIdentifier;
+ FMembers.Add(Member);
+ //girError(geDebug, Format('Added Enum [%s] Member "%s" with value "%s"',[Name, AName, AValue]));
+end;
+
+procedure TgirEnumeration.HandleFunction(ANode: TDomNode);
+var
+ NS: TgirNamespace;
+begin
+ NS := TgirNamespace(FOwner);
+ NS.ParseSubNode(ANode);
+
+end;
+
+constructor TgirEnumeration.Create(AOwner: TObject; ANode: TDomNode);
+var
+ Node: TDOMElement;
+ NameStr: DOMString;
+begin
+ inherited Create(AOwner, ANode);
+ FMembers := TgirEnumList.Create;
+ Node := TDOMElement(ANode.FirstChild);
+ while Node <> nil do
+ begin
+ case GirTokenNameToToken(Node.NodeName) of
+ gtDoc:;
+ gtMember: AddMember(Node.GetAttribute('name'), Node.GetAttribute('value'),Node.GetAttribute('c:identifier'));
+ // some enumerations seem to have functions part of them. They are only functions directly related to the enumeration and cannot be part of the enum
+ gtFunction: HandleFunction(Node);
+ else
+ NameStr := TDOMElement(Node).GetAttribute('name');
+ girError(geWarn,Format(geUnhandledNode,[ClassName, Node.ParentNode.Attributes.Item[0].NodeValue +' : >> '+ Node.NodeName+' << '+ NameStr]));
+ //girError(geWarn,Format(geUnhandledNode, [ClassName, Node.NodeName]));
+ end;
+ Node := TDOMElement(Node.NextSibling);
+ end;
+ FObjectType:=otEnumeration;
+end;
+
+destructor TgirEnumeration.Destroy;
+begin
+ FMembers.Free;
+ inherited Destroy;
+end;
+
+{ TgirConstant }
+
+constructor TgirConstant.Create(AOwner: TObject; ANode: TDomNode);
+var
+ Node: TDOMElement;
+begin
+ inherited Create(AOwner, ANode);
+ Node := TDomELement(ANode.FindNode('type'));
+ FTypeDecl := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), Node.GetAttribute('c:type'));
+ FValue:= TDOMElement(ANode).GetAttribute('value');
+ FIsString:=Node.GetAttribute('c:type') = 'gchar*';
+ //girError(geDebug, Format('Added constant "%s" with value "%s" of type "%s"',[Name, Value, FTypeDecl.Name]));
+ FObjectType:=otConstant;
+end;
+
+{ TgirFuzzyType }
+
+function TgirFuzzyType.GetResolvedType: TGirBaseType;
+begin
+ Result := FResolvedType;
+end;
+
+procedure TgirFuzzyType.SetResolvedType(const AValue: TGirBaseType);
+begin
+ if AValue = FResolvedType then
+ Exit;
+ FResolvedType := AValue;
+ //girError(geDebug, 'Resolved FuzzyType '+AValue.Name);
+end;
+
+constructor TgirFuzzyType.Create(AOwner: TObject; AName: String; ACtype: String);
+begin
+ FName:=AName;
+ FOwner := AOwner;
+ FCType:=ACtype;
+ FObjectType:=otFuzzyType;
+ //girError(geFuzzy, 'Creating Fuzzy Type "'+AName+'/'+ACtype+'"');
+end;
+
+{ TgirAlias }
+
+constructor TgirAlias.Create(AOwner: TObject; ANode: TDomNode);
+var
+ Node: TDOMElement;
+begin
+ inherited Create(AOwner, ANode);
+ Node := TDomELement(ANode.FindNode('type'));
+ FForType := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), Node.GetAttribute('c:type'));
+ FObjectType:=otAlias;
+end;
+
+{ TGirBaseType }
+
+procedure TGirBaseType.SetImpliedPointerLevel(AValue: Integer);
+begin
+ if FImpliedPointerLevel '' then
+ FBits := StrToInt(AttrValue);
+ Node := ANode.FindNode('doc');
+ if Node <> nil then
+ FDoc := Node.FirstChild.TextContent;
+ ImpliedPointerLevel:=2;
+ FObjectType:=otBaseType;
+end;
+
+end.
+
diff --git a/applications/gobject-introspection/girparser.pas b/applications/gobject-introspection/girparser.pas
new file mode 100644
index 000000000..943ca8867
--- /dev/null
+++ b/applications/gobject-introspection/girparser.pas
@@ -0,0 +1,18 @@
+unit girParser;
+
+{$mode objfpc}{$H+}
+{$INTERFACES CORBA}
+interface
+
+uses
+ Classes, SysUtils, Dom;
+
+type
+ IgirParser = interface
+ procedure ParseNode(ANode: TDomNode);
+ end;
+
+implementation
+
+end.
+
diff --git a/applications/gobject-introspection/girpascalwriter.pas b/applications/gobject-introspection/girpascalwriter.pas
new file mode 100644
index 000000000..1fb0550b5
--- /dev/null
+++ b/applications/gobject-introspection/girpascalwriter.pas
@@ -0,0 +1,1791 @@
+{
+girpascalwriter.pas
+Copyright (C) 2011 Andrew Haines andrewd207@aol.com
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+}
+unit girpascalwriter;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, girNameSpaces, girObjects, girTokens, contnrs;
+
+type
+ TUnitWriteEvent = procedure (Sender: TObject; AUnitName: AnsiString; AStream: TStringStream) of object;
+
+ { TgirPascalWriter }
+
+ TgirPascalWriter = class
+ private
+ FOnUnitWriteEvent: TUnitWriteEvent;
+ FNameSpaces: TgirNamespaces;
+ FUnits: TList;
+ public
+ constructor Create(ANameSpaces: TgirNamespaces);
+ procedure GenerateUnits;
+ property OnUnitWriteEvent: TUnitWriteEvent read FOnUnitWriteEvent write FOnUnitWriteEvent;
+ end;
+
+
+implementation
+uses girCTypesMapping;
+
+type
+ TPDeclaration = class
+ function AsString: String; virtual; abstract;
+ end;
+
+ { TPDeclarationWithLines }
+
+ TPDeclarationWithLines = class(TPDeclaration)
+ Lines: TStringList;
+ constructor Create; virtual;
+ destructor Destroy; override;
+ function AsString: String; override;
+ end;
+
+ { TPDeclarationType }
+
+ TPDeclarationType = class(TPDeclarationWithLines)
+ function AsString: String; override;
+ end;
+
+ { TPDeclarationConst }
+
+ TPDeclarationConst = class(TPDeclarationWithLines)
+ function AsString: String; override;
+ end;
+
+ { TPDeclarationVar }
+
+ TPDeclarationVar = class(TPDeclarationWithLines)
+ function AsString: String; override;
+ end;
+
+ { TPDeclarationFunctions }
+
+ TPDeclarationFunctions = class(TPDeclarationWithLines)
+ constructor Create; override;
+ // nothing special for this one
+ end;
+
+ { TPCodeText }
+
+ TPCodeText = class(TPDeclaration)
+ private
+ FContent: String;
+ public
+ function AsString: String; override;
+ property Content: String read FContent write FContent;
+
+ end;
+
+ { TPUses }
+
+ TPUses = class(TPDeclaration)
+ Units: TStringList;
+ constructor Create;
+ destructor Destroy; override;
+ function AsString: String; override;
+ end;
+
+
+
+ { TPDeclarationList }
+
+ TPDeclarationList = class(TList)
+ private
+ function GetDeclarations(AIndex: Integer): TPDeclaration;
+ public
+ function AsString: String;
+ property Declarations[AIndex: Integer]: TPDeclaration read GetDeclarations;
+ end;
+
+ { TPUnitPart }
+
+ TPUnitPart = class
+ FOwner: TObject;
+ constructor Create(AOwner: TObject); virtual;
+ function AsString: String; virtual ; abstract;
+ end;
+
+ { TPCommonSections }
+
+ TPCommonSections = class(TPUnitPart)
+ private
+ FDeclarations: TPDeclarationList;
+ public
+ constructor Create(AOwner: TObject); override;
+ destructor Destroy; override;
+ property Declarations: TPDeclarationList read FDeclarations;
+ end;
+
+ { TPInterface }
+
+ TPInterface = class(TPCommonSections)
+ private
+ FConstSection: TPDeclarationConst;
+ FFunctionSection: TPDeclarationFunctions;
+ FUsesSection: TPUses;
+ public
+ constructor Create(AOwner: TObject; AUses: TPUses);
+ destructor Destroy; override;
+ function AsString: String; override;
+ property UsesSection: TPUses read FUsesSection;
+ property ConstSection: TPDeclarationConst read FConstSection;
+ property FunctionSection: TPDeclarationFunctions read FFunctionSection;
+ end;
+
+ { TPImplementation }
+
+ TPImplementation = class(TPCommonSections)
+ function AsString: String; override;
+ end;
+
+ { TPInitialize }
+
+ TPInitialize = class(TPCommonSections)
+ function AsString: String; override;
+ end;
+
+ { TPFinialization }
+
+ TPFinialization = class(TPCommonSections)
+ function AsString: String; override;
+ end;
+
+ { TPascalUnit }
+
+ TPascalUnit = class
+ private
+ FLinkDynamic: Boolean;
+ FFinalizeSection: TPFinialization;
+ FImplementationSection: TPImplementation;
+ FInitializeSection: TPInitialize;
+ FInterfaceSection: TPInterface;
+ FLibName: String;
+ FNameSpace: TgirNamespace;
+ ProcessLevel: Integer; //used to know if to write forward definitions
+ function GetUnitName: String;
+
+ // functions to ensure the type is being written in the correct declaration
+ function WantTypeSection: TPDeclarationType;
+ function WantConstSection: TPDeclarationConst;
+ function WantFunctionSection: TPDeclarationFunctions;
+ // function WantVarSection: TPDeclarationVar;
+
+ // to process main language types
+ procedure HandleNativeType(AItem: TgirNativeTypeDef);
+ procedure HandleAlias(AItem: TgirAlias);
+ procedure HandleCallback(AItem: TgirCallback);
+ procedure HandleEnum(AItem: TgirEnumeration; ADeclareType: Boolean = True);
+ procedure HandleBitfield(AItem: TgirBitField);
+ procedure HandleRecord(AItem: TgirRecord);
+ procedure HandleOpaqueType(AItem: TgirFuzzyType);
+ procedure HandleFunction(AItem: TgirFunction);
+ procedure HandleObject(AItem: TgirObject; AObjectType: TGirToken);
+ procedure HandleUnion(AItem: TgirUnion);
+
+ procedure WriteForwardDefinition(AType: TGirBaseType);
+
+
+ //functions to write reused parts of types
+ procedure WriteWrapperForObject(ARoutineType, AObjectName, AObjectFunctionName: String; AParams:TgirParamList; AFunctionReturns: String; AFlatFunctionName: String; AWantSelf: Boolean);
+ function WriteCallBack(AItem: TgirFunction; IsInObject: Boolean; AExistingUsedNames: TStringList = nil): String;
+ procedure WriteFunctionTypeAndReturnType(AItem: TgirFunction; out AFunctionType, AFunctionReturnType: String);
+ function WriteFunctionParams(AParams: TgirParamList; AArgs: PString = nil): String;
+ function WriteFunction(AFunction: TgirFunction; AItem: TGirBaseType; AIsMethod: Boolean; AWantWrapperForObject: Boolean; AFunctionList: TStrings; AExistingUsedNames: TStringList = nil): String;
+ function WriteParamAsString(AParam: TgirTypeParam; AIndex: Integer; AFirstParam: PString = nil; AExistingUsedNames: TStringList = nil): String;
+ function WriteRecord(ARecord: TgirRecord; ABaseIndent: Integer = 0; AIsUnion: Boolean = False): String;
+ function WriteUnion(AUnion: TgirUnion; ASkipRecordName: Boolean; ABaseIndent: Integer = 0): String;
+ function ParenParams(const AParams: String; const AForceParens: Boolean = False): String;
+
+ // methods for dealing with type names
+ function SanitizeName(AName: String; AExistingUsedNames: TStringList = nil): String;
+ procedure WritePointerTypesForType(AItem: TGirBaseType; ATypeName: String; APointerLevel: Integer; ALines: TStrings);
+ function TypeAsString(AType: TGirBaseType; APointerLevel: Integer; ACTypeAsBackup: String = ''): String;
+ procedure AssembleUsedFieldNamesFromParent(const AParent: TgirClass; var AUsedNamesList: TStringList);
+
+ procedure ResolveTypeTranslation(ABaseType: TGirBaseType);
+ function MakePascalTypeFromCType(CName: String; PointerLevel: Integer = MaxInt; Trim_T_IfExists: Boolean =True): String;
+
+ function EscapeSingleQuote(AString: String): String;
+
+ procedure AddGLibSupportCode;
+
+ procedure ProcessType(AType: TGirBaseType; AForceWrite: Boolean = False);
+ procedure ResolveFuzzyTypes;
+ public
+ constructor Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean);
+ 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;
+
+ property InterfaceSection: TPInterface read FInterfaceSection;
+ property ImplementationSection: TPImplementation read FImplementationSection;
+ property InitializeSection: TPInitialize read FInitializeSection;
+ property FinalizeSection: TPFinialization read FFinalizeSection;
+ property UnitName: String read GetUnitName;
+ property LibName: String read FLibName write FLibName;
+ property NameSpace: TgirNamespace read FNameSpace;
+ end;
+
+function IndentText(const AText: String; Spaces: Integer = 0; LineEndingCount: Integer = 1): String;
+begin
+ SetLength(Result, Spaces);
+ FillChar(Result[1], Spaces, ' ');
+ Result := Result+AText;
+ if LineEndingCount > 0 then
+ begin
+ SetLength(Result, Length(Result)+Length(LineEnding)*LineEndingCount);
+ FillChar(Result[Length(AText)+Spaces+1], LineEndingCount, LineEnding);
+ end;
+end;
+
+function MakePointerTypesForType(const AName: String; PointerLevel: Integer): TStringList;
+var
+ //Chars: String;
+ BaseName: String;
+ i: Integer;
+begin
+ Result := TStringList.Create;
+ if AName = '' then
+ Exit;
+ BaseName:=AName;
+ // check if it's already prefixed
+ if AName[1] = 'T' then
+ BaseName:=Copy(AName,2, Length(AName));
+
+ for i := 0 to PointerLevel-1 do
+ begin
+ BaseName := 'P'+BaseName;
+ Result.Add(BaseName);
+ end;
+end;
+
+function CalculateUnitName(ANameSpace: String; AVersion: String): String;
+var
+ Version: String;
+begin
+ if ANameSpace[Length(ANameSpace)] in ['0'..'9'] then
+ ANameSpace := ANameSpace + '_';
+ Version := StringReplace(AVersion,'.','_',[rfReplaceAll]);
+ Version := StringReplace(Version,'_0','',[rfReplaceAll]);
+ Result := ANameSpace+Version;
+end;
+
+constructor TPDeclarationFunctions.Create;
+begin
+ inherited Create;
+ Lines.Duplicates:=dupIgnore;
+ Lines.Sorted:=True;
+end;
+
+{ TPDeclarationVar }
+
+function TPDeclarationVar.AsString: String;
+begin
+ Result:= IndentText('var') + Lines.Text;
+end;
+
+{ TPDeclarationWithLines }
+
+constructor TPDeclarationWithLines.Create;
+begin
+ Lines := TStringList.Create;
+end;
+
+destructor TPDeclarationWithLines.Destroy;
+begin
+ Lines.Free;
+ inherited Destroy;
+end;
+
+function TPDeclarationWithLines.AsString: String;
+begin
+ Result:=Lines.Text;
+end;
+
+
+function TPCodeText.AsString: String;
+begin
+ Result := Content;
+end;
+
+{ TPDeclarationType }
+
+function TPDeclarationType.AsString: String;
+begin
+ Result:= IndentText('type') + Lines.Text;
+end;
+
+{ TPDeclarationConst }
+
+function TPDeclarationConst.AsString: String;
+begin
+ Result:= IndentText('const') + Lines.Text;
+end;
+
+{ TPUses }
+
+constructor TPUses.Create;
+begin
+ Units := TStringList.Create;
+ Units.StrictDelimiter:=True;
+ Units.Delimiter:=',';
+ Units.Add('CTypes');
+end;
+
+destructor TPUses.Destroy;
+begin
+ Units.Free;
+ inherited Destroy;
+end;
+
+function TPUses.AsString: String;
+begin
+ Result := '';
+
+ if Units.Count>0 then
+ Result := IndentText('uses') + IndentText(Units.DelimitedText+';', 2)+LineEnding;
+end;
+
+{ TPFinialization }
+
+function TPFinialization.AsString: String;
+begin
+ Result := 'finalization'+LineEnding+FDeclarations.AsString;
+end;
+
+{ TPInitialize }
+
+function TPInitialize.AsString: String;
+begin
+ Result := 'initialization'+LineEnding+FDeclarations.AsString;
+end;
+
+function TPImplementation.AsString: String;
+begin
+ Result := IndentText('implementation')+FDeclarations.AsString;
+end;
+
+{ TPCommonSections }
+
+constructor TPCommonSections.Create(AOwner: TObject);
+begin
+ inherited Create(AOwner);
+ FDeclarations := TPDeclarationList.Create;
+end;
+
+destructor TPCommonSections.Destroy;
+begin
+ FDeclarations.Free;
+ inherited Destroy;
+end;
+
+constructor TPInterface.Create(AOwner: TObject; AUses: TPUses);
+begin
+ inherited Create(AOwner);
+ FUsesSection := AUses;
+ FConstSection := TPDeclarationConst.Create;
+ FFunctionSection := TPDeclarationFunctions.Create;
+end;
+
+destructor TPInterface.Destroy;
+begin
+ FConstSection.Free;
+ FFunctionSection.Free;
+ FUsesSection.Free;
+ inherited Destroy;
+
+end;
+
+function TPInterface.AsString: String;
+begin
+ Result := IndentText('interface')+
+ FUsesSection.AsString+
+ FConstSection.AsString+
+ FDeclarations.AsString+
+ FFunctionSection.AsString;
+end;
+
+{ TPUnitPart }
+
+constructor TPUnitPart.Create(AOwner: TObject);
+begin
+ FOwner := AOwner;
+end;
+
+{ TPascalUnit }
+
+function TPascalUnit.GetUnitName: String;
+begin
+ Result := CalculateUnitName(FNameSpace.NameSpace, FNameSpace.Version);
+end;
+
+function TPascalUnit.MakePascalTypeFromCType(CName: String; PointerLevel: Integer = MaxInt; Trim_T_IfExists: Boolean =True): String;
+var
+ C: Integer = 0;
+ i: Integer = 0;
+ Prefix: String;
+begin
+ Result := '';
+
+ repeat
+ i := Pos('*', CName);
+ if i > 0 then
+ begin
+ Inc(C);
+ Delete(CName, i,1);
+ end;
+ until i = 0;
+
+ if Trim_T_IfExists and (Length(CName) > 0) and (CName[1] = 'T') then
+ Delete(CName,1,1);
+
+ case PointerLevel of
+ MaxInt:; // C remains the same
+ -1: ;
+ 0: C := 0;
+ else
+ C := PointerLevel;
+ end;
+
+ if C = -1 then
+ Prefix := ''
+ else if C = 0 then
+ Prefix := 'T'
+ else
+ begin
+ SetLength(Prefix, C);
+ FillChar(Prefix[1], C, 'P');
+ end;
+ Result := Trim(Prefix+Trim(CName));
+end;
+
+function TPascalUnit.EscapeSingleQuote(AString: String): String;
+var
+ i: Integer;
+begin
+ Result := AString;
+ for i := Length(Result) downto 1 do
+ if Result[i] = '''' then
+ Insert('''', Result, i);
+end;
+
+procedure TPascalUnit.AddGLibSupportCode;
+const
+ BitFRecord =
+ ' TBitObject32 = object' +LineEnding+
+ ' protected' +LineEnding+
+ ' procedure SetBit(AMask: Integer; AValue: DWord);' +LineEnding+
+ ' function GetBit(AMask: Integer): DWord;' +LineEnding+
+ ' public' +LineEnding+
+ ' Flags0: DWord;' +LineEnding+
+ ' procedure Init(AFlags: DWord);' +LineEnding+
+ ' end;';
+
+ BFRecordImpl :AnsiString =
+ 'procedure TBitObject32.Init(AFlags: DWord);' +LineEnding+
+ 'begin' +LineEnding+
+ ' Flags0 := AFlags;' +LineEnding+
+ 'end;' +LineEnding+
+ '' +LineEnding+
+ 'procedure TBitObject32.SetBit(AMask: Integer; AValue: DWord);'+LineEnding+
+ 'begin' +LineEnding+
+ ' if AValue <> 0 then' +LineEnding+
+ ' begin' +LineEnding+
+ ' if (Flags0 and AMask) = 0 then' +LineEnding+
+ ' Flags0 := Flags0 or AMask' +LineEnding+
+ ' end' +LineEnding+
+ ' else begin' +LineEnding+
+ ' if (Flags0 and AMask) <> 0 then' +LineEnding+
+ ' Flags0 := Flags0 xor AMask;' +LineEnding+
+ ' end;' +LineEnding+
+ 'end;' +LineEnding+
+ '' +LineEnding+
+ 'function TBitObject32.GetBit(AMask: Integer): DWord;' +LineEnding+
+ 'begin' +LineEnding+
+ ' Result := Flags0 and AMask;' +LineEnding+
+ ' if Result > 1 then' +LineEnding+
+ ' Result := 1;' +LineEnding+
+ 'end;';
+var
+ CodeText: TPCodeText;
+ TypeSect: TPDeclarationType;
+ i: Integer;
+begin
+ WantTypeSection.Lines.Add(BitFRecord);
+ CodeText := TPCodeText.Create;
+ CodeText.Content:=BFRecordImpl;
+ ImplementationSection.Declarations.Add(CodeText);
+
+ TypeSect := WantTypeSection;
+ for i := 1 to 31 do
+ begin
+ if i in [8,16,32] then
+ continue;
+ TypeSect.Lines.Add(Format(' guint%d = 0..(1 shl %d-1);',[i,i]));
+ end;
+end;
+
+
+procedure TPascalUnit.ProcessType(AType: TGirBaseType; AForceWrite: Boolean = False);
+begin
+ if (AType = nil) or (AType.Owner <> NameSpace) then
+ Exit; // it's written in another Namespace
+
+ if (AType.ObjectType = otFuzzyType) and (TgirFuzzyType(AType).ResolvedType <> nil) then
+ begin
+ TgirFuzzyType(AType).ResolvedType.ImpliedPointerLevel := AType.ImpliedPointerLevel;
+ AType := TgirFuzzyType(AType).ResolvedType;
+ end;
+
+ if (AType.CType = '') then //(AType.Name = '') then
+ begin
+ WriteLn('WARNING: Type.Ctype undefined! : ', Atype.Name);
+ //Halt;
+
+ end;
+ if ProcessLevel > 0 then
+ begin
+ WriteForwardDefinition(AType);
+ if AType.InheritsFrom(TgirCallback) or AType.InheritsFrom(TgirBitField) then
+ AForceWrite:=True;
+ if not AForceWrite then
+ Exit;
+ end;
+ if (AType.Writing = msWritten) or ((AType.Writing = msWriting) {and not AForceWrite}) then
+ begin
+ //WriteLn('Already Written Type Used: ', AType.TranslatedName);
+ Exit;
+ end;
+
+ //if AForceWrite then
+ // WriteLn('ForceWriting: ', AType.CType);
+
+ Inc(ProcessLevel);
+ AType.Writing := msWriting;
+
+ case AType.ObjectType of
+ otAlias: HandleAlias(TgirAlias(AType));
+ otCallback: HandleCallback(TgirCallback(AType));
+ otEnumeration: HandleEnum(TgirEnumeration(AType));
+ otBitfield: HandleBitfield(TgirBitField(AType));
+ otRecord: HandleRecord(TgirRecord(AType));
+ otFunction: HandleFunction(TgirFunction(AType));
+ otGType: HandleObject(TgirGType(AType), gtGType);
+ otObject: HandleObject(TgirObject(AType), gtObject);
+ otClass: HandleObject(TgirObject(AType), gtClass);
+ otClassStruct: HandleObject(TgirObject(AType), gtClassStruct);
+ otNativeType: HandleNativeType(TgirNativeTypeDef(AType)); // not called but the items are added to the list... where are they?
+ otInterface: HandleObject(TgirInterface(AType), gtInterface);
+ otUnion: HandleUnion(TgirUnion(AType));
+ otFuzzyType:
+ begin
+ if TgirFuzzyType(AType).ResolvedType = nil then
+ HandleOpaqueType(TgirFuzzyType(AType))
+ else
+ begin
+ Dec(ProcessLevel); // it should be level 0
+ ProcessType(TgirFuzzyType(AType).ResolvedType);
+ Inc(ProcessLevel);
+ end;
+ end;
+ else
+ //WantTypeSection.Lines.Add(IndentText(AType.ClassName + ' ' +AType.Name + ' ' + AType.CType ,2));
+ WriteLn('Unknown Type: ', AType.ClassName);
+ Halt;
+ end; // case
+
+ AType.Writing:=msWritten;
+ Dec(ProcessLevel);
+end;
+
+procedure TPascalUnit.ResolveFuzzyTypes;
+var
+ BaseType: TGirBaseType;
+ FuzzyType : TgirFuzzyType absolute BaseType;
+ i: Integer;
+ CTypesType: String;
+begin
+ // here we wil try to find unresolved types that have compatible types in pascal.
+ // for instance xlib uses guint but does not depend on glib where that is defined, we will try to replace those with cuint from ctypes
+ for i := 0 to NameSpace.Types.Count-1 do
+ begin
+ BaseType := TGirBaseType(NameSpace.Types.Items[i]);
+ if BaseType.InheritsFrom(TgirFuzzyType) and (FuzzyType.ResolvedType = nil) then
+ begin
+ CTypesType := LookupGTypeToCType(FuzzyType.CType);
+ if CTypesType <> '' then
+ begin
+ FuzzyType.TranslatedName:= CTypesType;
+ FuzzyType.Writing := msWritten;
+ end;
+ end;
+ end;
+end;
+
+function TPascalUnit.WantTypeSection: TPDeclarationType;
+begin
+ if (InterfaceSection.Declarations.Count = 0)
+ or (InterfaceSection.Declarations.Declarations[InterfaceSection.Declarations.Count-1].ClassType <> TPDeclarationType.ClassType)
+ then
+ begin
+ Result := TPDeclarationType.Create;
+ InterfaceSection.Declarations.Add(Result);
+ end
+ else
+ Result := TPDeclarationType(InterfaceSection.Declarations.Declarations[InterfaceSection.Declarations.Count-1]);
+end;
+
+function TPascalUnit.WantConstSection: TPDeclarationConst;
+begin
+ Result := InterfaceSection.ConstSection;
+end;
+
+function TPascalUnit.WantFunctionSection: TPDeclarationFunctions;
+begin
+ Result := InterfaceSection.FunctionSection;
+end;
+
+procedure TPascalUnit.WritePointerTypesForType(AItem: TGirBaseType; ATypeName: String; APointerLevel: Integer; ALines: TStrings);
+var
+ PTypes: TStrings;
+ i: Integer;
+begin
+ if AItem.ForwardDefinitionWritten then
+ WriteLn('Warning: Forwards definitions already written for : ', Aitem.TranslatedName);
+ AItem.ForwardDefinitionWritten := True;
+ PTypes := MakePointerTypesForType(ATypeName, APointerLevel);
+ PTypes.Insert(0, ATypeName);
+ for i := PTypes.Count-1 downto 1 do
+ ALines.Add(IndentText(PTypes[i]+ ' = ^'+PTypes[i-1]+';',2,0));
+ PTypes.Free;
+end;
+
+procedure TPascalUnit.HandleNativeType(AItem: TgirNativeTypeDef);
+var
+ TypeSect: TPDeclarationType;
+begin
+ if (AItem.PascalName = AItem.CType) and (AItem.Name <> 'file') then
+ Exit; // is a native pascal type plus a = a doesn't fly with the compiler
+
+
+ if AItem.CType <> 'file' then
+ AItem.CType:=SanitizeName(AItem.CType);
+
+ TypeSect := WantTypeSection;
+ AItem.TranslatedName:=AItem.CType;
+ //WritePointerTypesForType(Aitem, AItem.CType, AItem.ImpliedPointerLevel, TypeSect.Lines);
+ if AItem.Name <> 'file' then
+ TypeSect.Lines.Add(IndentText(SanitizeName(AItem.CType)+ ' = '+ AItem.PascalName+';', 2,0));
+end;
+
+procedure TPascalUnit.HandleAlias(AItem: TgirAlias);
+var
+ ResolvedForName: String;
+ CType: TGirBaseType;
+begin
+ ResolveTypeTranslation(AItem);
+ ResolveTypeTranslation(AItem.ForType);
+
+ // some aliases are just for the parser to connect a name to an alias
+ if AItem.CType = '' then
+ Exit;
+ ResolvedForName := aItem.ForType.TranslatedName;
+ if ResolvedForName = '' then
+ begin
+
+ CType := NameSpace.LookupTypeByName('', AItem.ForType.CType);
+ if CType <> nil then
+ ResolvedForName := CType.TranslatedName;
+
+ if ResolvedForName <> '' then
+ aItem.ForType.TranslatedName := ResolvedForName
+ else
+ ResolvedForName := AItem.ForType.CType;
+ end;
+
+ WriteForwardDefinition(AItem);
+
+ if AItem.Writing < msWritten then
+ WantTypeSection.Lines.Add(IndentText(MakePascalTypeFromCType(AItem.CType)+' = '+ ResolvedForName+';' ,2,0));
+end;
+
+procedure TPascalUnit.HandleCallback(AItem: TgirCallback);
+var
+ TypeSect: TPDeclarationType;
+ CB: String;
+begin
+
+ TypeSect := WantTypeSection;
+
+ CB := WriteCallBack(AItem, False);
+
+ if AItem.Writing < msWritten then
+ TypeSect.Lines.Add(IndentText(CB,2,0))
+end;
+
+procedure TPascalUnit.HandleEnum(AItem: TgirEnumeration; ADeclareType: Boolean = True);
+var
+ ConstSection: TPDeclarationConst;
+ Entry: String;
+ i: Integer;
+ CName: String;
+ TypeName: String;
+begin
+ ResolveTypeTranslation(AItem);
+
+ ConstSection := WantConstSection;
+ ConstSection.Lines.Add('');
+ //ATK_HYPERLINK_IS_INLINE_
+ if ADeclareType then
+ begin
+ // forces forward declarations to be written
+ ProcessType(AItem);
+
+ TypeName := ': '+AItem.TranslatedName;
+
+ // yes we cheat a little here using the const section to write type info
+ ConstSection.Lines.Add('type');
+ ConstSection.Lines.Add(IndentText(AItem.TranslatedName+' = Integer;', 2,0));
+ ConstSection.Lines.Add('const');
+ end
+ else
+ TypeName:='';
+ ConstSection.Lines.Add(IndentText('{ '+ AItem.CType + ' }',2,0));
+
+ for i := 0 to AItem.Members.Count-1 do
+ begin
+ CName := AItem.Members.Member[i]^.CIdentifier;
+ if CName = 'ATK_HYPERLINK_IS_INLINE' then
+ CName :='ATK_HYPERLINK_IS_INLINE_';
+ Entry := CName + TypeName+ ' = ' + AItem.Members.Member[i]^.Value+';';
+ ConstSection.Lines.Add(IndentText(Entry,2,0));
+ end;
+ AItem.Writing:=msWritten;
+end;
+
+procedure TPascalUnit.HandleBitfield(AItem: TgirBitField);
+const
+ TemplateLongWord =
+ '%s = packed object(TBitObject32)'+LineEnding+
+ '%s'+LineEnding+
+ 'end';
+var
+ Intf: TPDeclarationType;
+ CodeText: TPCodeText;
+ Code: TStringList;
+ PName: String;
+ Entry: String;
+ i: Integer;
+ VarType: String;
+
+begin
+ Intf := WantTypeSection;
+ CodeText := TPCodeText.Create;
+ ImplementationSection.Declarations.Add(CodeText);
+ Code := TStringList.Create;
+
+ PName:=MakePascalTypeFromCType(AItem.CType);
+
+ {case AItem.Bits of
+ //1..8: VarType:='Byte';
+ //9..16: VarType:='Word';
+ //0:;
+ //17..32: VarType:='LongWord';
+ //33..64: VarType:='QWord';
+ else
+ WriteLn('Bitfield <> 16bits');
+ Halt;
+ end;}
+
+ HandleEnum(AItem, False);
+
+ VarType:='DWord';
+
+ Intf.Lines.Add(IndentText(PName+ ' = packed object(TBitObject32)',2,0));
+ Intf.Lines.Add(IndentText('public',2,0));
+ for i := 0 to AItem.Members.Count-1 do
+ begin
+ Entry := 'property '+ SanitizeName(AItem.Members.Member[i]^.Name) +': '+VarType+' index '+AItem.Members.Member[i]^.Value+' read GetBit write SetBit;';
+ Intf.Lines.Add(IndentText(Entry, 4,0));
+ end;
+ Intf.Lines.Add(IndentText('end;',2,0));
+ Intf.Lines.Add('');
+
+ CodeText.Content:=Code.Text;
+ Code.Free;
+
+end;
+
+procedure TPascalUnit.HandleRecord(AItem: TgirRecord);
+ begin
+ ResolveTypeTranslation(AItem);
+ AItem.ImpliedPointerLevel:=1; // will not be decreased only will grow
+
+ WriteForwardDefinition(AItem);
+
+ WantTypeSection.Lines.Add(WriteRecord(AItem));
+
+end;
+
+procedure TPascalUnit.HandleOpaqueType(AItem: TgirFuzzyType);
+var
+ TypeSect: TPDeclarationType;
+ Plain: String;
+begin
+ if AItem.CType = '' then
+ Exit;
+ TypeSect := WantTypeSection;
+ Plain := StringReplace(AItem.CType, '*', '', [rfReplaceAll]);
+ AItem.TranslatedName:=MakePascalTypeFromCType(Plain, 0);
+
+ TypeSect.Lines.Add('');
+ TypeSect.Lines.Add(' { '+ AItem.CType+' }');
+ TypeSect.Lines.Add(IndentText(AItem.TranslatedName +' = record',2,0));
+ TypeSect.Lines.Add(IndentText('{ opaque type }',4,0));
+ TypeSect.Lines.Add(IndentText('Unknown: Pointer;',4,0)); // to prevent crashes of the compiler
+
+ TypeSect.Lines.Add(IndentText('end;',2,1));
+
+end;
+
+procedure TPascalUnit.HandleFunction(AItem: TgirFunction);
+var
+ RoutineType: String;
+ Returns: String;
+ Params: String;
+ FuncSect: TPDeclarationFunctions;
+ Postfix: String;
+begin
+ WriteFunctionTypeAndReturnType(AItem, RoutineType, Returns);
+ Params := WriteFunctionParams(AItem.Params);
+ Postfix := ' external;';// '+UnitName+'_library;';
+ FuncSect := WantFunctionSection;
+ FuncSect.Lines.Add(RoutineType +' '+ AItem.CIdentifier+ParenParams(Params)+Returns+Postfix);
+end;
+
+function TPascalUnit.WriteFunction(AFunction: TgirFunction; AItem: TGirBaseType; AIsMethod: Boolean; AWantWrapperForObject: Boolean; AFunctionList: TStrings; AExistingUsedNames: TStringList = nil): String;
+var
+ Prefix: String = '';
+ RoutineType: String;
+ Returns: String;
+ Params: String;
+ Postfix: String;
+ Entry: String;
+ InLineS: String = '';
+begin
+ Result := '';
+ // we skip deprecated functions
+ if AFunction.Deprecated and (CompareStr(AFunction.DeprecatedVersion, NameSpace.Version) >= 0) then
+ Exit;
+
+ // some abstract functions that are to be implemented by a module and shouldn't be declared. There is no indicator in the gir file that this is so :(
+ if (AFunction.CIdentifier = 'g_io_module_query')
+ or (AFunction.CIdentifier = 'g_io_module_load')
+ or (AFunction.CIdentifier = 'g_io_module_unload')
+ then
+ Exit; // they are functions to be implemented by a runtime loadable module, they are not actually functions in glib/gmodule/gio
+
+ if AWantWrapperForObject then
+ InLineS:=' inline;';
+
+ // this fills in the values for procedure/function and the return type
+ WriteFunctionTypeAndReturnType(AFunction, RoutineType, Returns);
+
+ // check if it is a constructor
+ if AFunction.InheritsFrom(TgirConstructor) then
+ Returns := ': '+MakePascalTypeFromCType(AItem.TranslatedName ,1)+'; cdecl;';
+
+ Params := WriteFunctionParams(AFunction.Params);
+ if Pos('array of const', Params) + Pos('va_list', Params) > 0 then
+ Prefix:='//';
+ Postfix := ' external;';// '+UnitName+'_library;';
+
+ // first wrapper proc
+ Entry := Prefix + RoutineType +' '+ SanitizeName(AFunction.Name, AExistingUsedNames)+ParenParams(Params)+Returns+InLineS;
+
+ // no need to pass self that will not be used
+ if (not AIsMethod) and AWantWrapperForObject then
+ Entry := Entry + ' static;';
+
+ // result will be written in the object declaration
+ Result := Entry;
+
+ // now make sure the flat proc has all the params it needs
+ if AIsMethod then
+ begin
+ // methods do not include the first param for it's type so we have to add it
+ if Params <> '' then
+ Params := SanitizeName('A'+AItem.Name) +': '+TypeAsString(AItem, 1)+'; ' + Params
+ else
+ Params := SanitizeName('A'+AItem.Name) +': '+TypeAsString(AItem, 1);
+ end;
+
+ // this is the flat c procedure that a wrapper would call
+ Entry := RoutineType +' '+ AFunction.CIdentifier+ParenParams(Params)+Returns;
+
+ // takes care of duplicates
+ AFunctionList.Add(Entry+Postfix);
+
+ //RoutineType, AObjectName, AObjectFunctionName, AParams, AFunctionReturns, AFlatFunctionName, AWantSelf
+ // writes the implementation of what we declared in the object
+ if AWantWrapperForObject and (Prefix = '') then
+ WriteWrapperForObject(RoutineType, AItem.TranslatedName, SanitizeName(AFunction.Name), AFunction.Params, Returns, AFunction.CIdentifier, AIsMethod);
+end;
+
+procedure TPascalUnit.HandleObject(AItem: TgirObject; AObjectType: TGirToken);
+var
+ TypeDecl: TStringList;
+ i: Integer;
+ UnitFuncs,
+ TypeFuncs: TStrings;
+ ParentType: String ='';
+ UsedNames: TStringList;
+
+ function GetTypeForProperty(AProperty: TgirProperty; out SetFound: Boolean): String;
+ var
+ i,j: Integer;
+ FoundPos: Integer;
+ LookingForGet,
+ LookingForSet: String;
+ Line: String;
+ GetFound: Boolean;
+ begin
+ GetFound := False;
+ SetFound := False;
+ Result := 'UNABLE_TO_FIND_TYPE_FOR_PROPERTY';
+ LookingForGet:=SanitizeName('get_'+AProperty.Name);
+ LookingForSet:=SanitizeName('set_'+AProperty.Name);
+ for i := TypeFuncs.Count-1 downto 0 do
+ begin
+ Line := TypeFuncs.Strings[i];
+
+ if not GetFound then
+ begin
+ FoundPos:= Pos(LookingForGet+':', Line);
+ //if FoundPos = 0 then
+ // FoundPos:=Pos(LookingForGet+'(', Line); // we do not yet support properties with parameters :(
+ end;
+ if (FoundPos > 0) and not GetFound then
+ begin
+ GetFound := True;
+ for j := Length(Line) downto 1 do
+ if Line[j] = ':' then
+ begin
+ Line := Copy(Line, j+1, Length(Line));
+ break;
+ end;
+ FoundPos:=Pos(';', Line);
+ Result := Copy(Line, 1,FoundPos-1);
+ Exit;
+ end
+ else
+ if not SetFound then
+ begin
+ SetFound := Pos(LookingForSet+':', Line) > 0;
+ SetFound := SetFound or (Pos(LookingForSet+'(', Line) > 0);
+ // pascal properties cannot use functions for the set 'procedure'
+ SetFound := SetFound and (Pos('proecedure ', Line) > 0);
+ end;
+ if SetFound and GetFound then
+ Exit;
+ end;
+
+
+ end;
+ function WriteMethodProperty(AProperty: TgirProperty; AType: String; SetFound: Boolean): String;
+ const
+ Prop = '%sproperty %s: %s %s %s;';
+ var
+ ReadFunc,
+ WriteProc: String;
+ Comment: String='';
+ begin
+ ReadFunc:= 'read '+SanitizeName('get_'+ AProperty.Name);
+ if AProperty.Writable then
+ begin
+ if SetFound then
+ WriteProc := 'write '+ SanitizeName('set_'+AProperty.Name)
+ else
+ WriteProc := ' { property is writeable but setter not declared } ';
+ end;
+ if AType = 'UNABLE_TO_FIND_TYPE_FOR_PROPERTY' then
+ Comment := '//';
+
+ Result := Format(Prop, [Comment, SanitizeName(AProperty.Name, UsedNames), AType, ReadFunc, WriteProc ]);
+ end;
+
+ procedure AddField(AParam: TgirTypeParam);
+ var
+ Param: String;
+ begin
+ ResolveTypeTranslation(AParam.VarType);
+ if (ParentType <> '') and (ParenParams(AParam.VarType.TranslatedName) = ParentType) then
+ begin
+ Exit;
+ end;
+ Param := WriteParamAsString(AParam,i, nil, UsedNames);
+ //if Pos('destroy_:', Param) > 0 then
+ // Param := StringReplace(Param, 'destroy_', 'destroy_f', [rfReplaceAll]);
+ TypeDecl.Add(IndentText(Param+';',4,0))
+
+ end;
+
+ procedure HandleFieldType(Field: TGirBaseType; AFirstPass: Boolean);
+ var
+ SetFound: Boolean;
+ begin
+ // FIRST PASS
+ if AFirstPass then
+ begin
+ case Field.ObjectType of
+ otVirtualMethod: ; // ignore. may be usefull if we wrap this in pascal classes instead of objects. Is already written in the class struct
+ 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
+
+
+ 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*
+
+ //WriteFunction(AFunction, AItem, AIsMethod, AWantWrapperForObject, AFunctionList): String;
+ otFunction : TypeFuncs.Add(IndentText(WriteFunction(TgirFunction(Field), AItem, False, True, UnitFuncs, UsedNames),4,0));
+ otMethod : TypeFuncs.Add(IndentText(WriteFunction(TgirFunction(Field), AItem, True, True, UnitFuncs, UsedNames),4,0));
+ otConstructor:TypeFuncs.Add(IndentText(WriteFunction(TgirConstructor(Field), AItem, False, True, UnitFuncs, UsedNames),4,0));
+ otProperty : TypeFuncs.Add(IndentText(WriteMethodProperty(TgirProperty(Field), GetTypeForProperty(TgirProperty(Field), SetFound), SetFound),4,0));
+ else // case <
+ WriteLn('Unknown Field Type : ', Field.ClassName);
+ Halt;
+ end;
+ end;
+
+ // SECOND PASS
+ if not AFirstPass then
+ begin
+ case Field.ObjectType of
+ otArray,
+ otTypeParam: AddField(TgirTypeParam(Field));
+ otCallback : TypeDecl.Add(IndentText(WriteCallBack(TgirCallback(Field),True, UsedNames),4,0));
+ otUnion :
+ begin
+ // we have to create a union outside the object and include it as a field
+ Field.CType := AItem.CType+'_union_'+Field.Name;
+ ResolveTypeTranslation(Field);
+ HandleUnion(TgirUnion(Field));
+ TypeDecl.Add(IndentText(SanitizeName(Field.Name, UsedNames)+': '+ Field.TranslatedName+'; //union extracted from object and named '''+Field.TranslatedName+'''',4,0));
+ end
+ end;
+ end;
+
+ end;
+ function GetParentType(AClass: TgirClass): String;
+ begin
+ Result := '';
+ AssembleUsedFieldNamesFromParent(AClass.ParentClass, UsedNames);
+ if AClass.ParentClass = nil then
+ Exit;
+ if AClass.ParentClass.Writing < msWritten then
+ ProcessType(AClass.ParentClass, True); // this type must be first
+
+ Result := AClass.ParentClass.TranslatedName;
+ if Result = '' then
+ begin
+ WriteLn('Class has parent but name is empty! : ', AClass.CType);
+ WriteLn('Parent Name = ', AClass.ParentClass.Name);
+ WriteLn('Parent CType = ', AClass.ParentClass.CType);
+ WriteLn('Parent Translated Name = ', AClass.ParentClass.TranslatedName);
+ Halt
+ end;
+ end;
+ procedure AddGetTypeProc(AObj: TgirGType);
+ const
+ GetTypeTemplate = 'function %s: %s; cdecl; external;';
+ var
+ AType: String;
+ begin
+ AType:='TGType';
+ if AObj.GetTypeFunction = '' then
+ Exit;
+ if not NameSpace.UsesGLib then
+ AType := 'csize_t { TGType }';
+
+ UnitFuncs.Add(Format(GetTypeTemplate, [AObj.GetTypeFunction, AType]));
+ end;
+
+var
+ TypeSect: TPDeclarationType;
+begin
+ if AItem.CType = '' then
+ Exit;
+ // if any params use a type that is not written we must write it before we use it!!
+ TypeDecl := TStringList.Create;
+ UsedNAmes := TStringList.Create;
+ UsedNames.Sorted:=True;
+ UsedNames.Duplicates:=dupError;
+ ResolveTypeTranslation(AItem);
+ AItem.ImpliedPointerLevel:=1; //will only grow
+
+ // forces it to write forward declarations if they are not yet.
+ ProcessType(AItem);
+
+ UnitFuncs := TStringList.Create;
+ TypeFuncs := TStringList.Create;
+
+ case AObjectType of
+ gtObject :; // do nothing
+ gtClass : ParentType:=ParenParams(GetParentType(TgirClass(AItem)));
+ gtClassStruct : ;// do nothing;
+ gtInterface: ;
+ gtGType: ;
+ else
+ WriteLn('Got Object Type I don''t understand: ', GirTokenName[AObjectType]);
+ end;
+
+ if AItem.InheritsFrom(TgirGType) then
+ begin
+ AddGetTypeProc(TgirGType(AItem));
+ end;
+ TypeDecl.Add(IndentText(AItem.TranslatedName +' = object'+ParentType,2,0));
+ // two passes to process the fields last for naming reasons
+ 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 TypeFuncs.Count > 0 then
+ TypeDecl.AddStrings(TypeFuncs);
+
+ TypeDecl.Add(' end;');
+
+ TypeSect := WantTypeSection;
+
+ TypeSect.Lines.AddStrings(TypeDecl);
+ TypeDecl.Free;
+ UsedNames.Free;
+
+ if UnitFuncs.Count > 0 then
+ WantFunctionSection.Lines.AddStrings(UnitFuncs);
+ UnitFuncs.Free;
+ TypeFuncs.Free;
+
+end;
+
+procedure TPascalUnit.HandleUnion(AItem: TgirUnion);
+begin
+ ResolveTypeTranslation(AItem);
+ WantTypeSection.Lines.Add(WriteUnion(AItem, False, 2));
+
+end;
+
+procedure TPascalUnit.WriteForwardDefinition(AType: TGirBaseType);
+ procedure WriteForward;
+ var
+ TypeSect: TPDeclarationType;
+ begin
+ TypeSect := WantTypeSection;
+ ResolveTypeTranslation(AType);
+ AType.ImpliedPointerLevel := 1; // will only grow
+ TypeSect.Lines.Add('');
+ //TypeSect.Lines.Add(' { forward declaration for '+AType.TranslatedName+'}');
+ WritePointerTypesForType(AType, AType.TranslatedName, AType.ImpliedPointerLevel, TypeSect.Lines);
+ end;
+
+begin
+ if AType.InheritsFrom(TgirFuzzyType) and (TgirFuzzyType(AType).ResolvedType <> nil) then
+ begin
+ TgirFuzzyType(AType).ResolvedType.ImpliedPointerLevel := AType.ImpliedPointerLevel;
+ AType := TgirFuzzyType(AType).ResolvedType;
+ end;
+
+ if AType.ForwardDefinitionWritten then
+ Exit;
+
+ WriteForward;
+ case AType.ObjectType of
+ otObject,
+ otGType,
+ otClass,
+ otClassStruct: ;
+
+ otAlias: ProcessType(AType, True);
+ otCallback: ProcessType(AType, True);
+ otEnumeration: ;
+ otBitfield: ;
+ otRecord: ;
+ otFunction: ;
+ otNativeType : ;
+ otInterface: ;
+ end;
+ Atype.ForwardDefinitionWritten:=True;
+end;
+
+procedure TPascalUnit.WriteWrapperForObject(ARoutineType, AObjectName,
+ AObjectFunctionName: String; AParams: TgirParamList; AFunctionReturns: String; AFlatFunctionName: String; AWantSelf: Boolean);
+const
+ Decl = '%s %s.%s%s%s'+LineEnding;
+ Body = 'begin'+LineEnding+
+ ' %s%s(%s);'+LineEnding+
+ 'end;'+LineEnding;
+var
+ Params: String;
+ CallParams: String;
+ Code: TPCodeText;
+ ResultStr: String = '';
+ Args: String;
+begin
+ if AWantSelf then
+ begin
+ if AParams.Count = 0 then
+ CallParams:='@self'
+ else
+ CallParams:='@self, ';
+ end
+ else
+ CallParams:='';
+ if (ARoutineType = 'function') or (ARoutineType='constructor') then
+ ResultStr := 'Result := ';
+ Params:=WriteFunctionParams(AParams, @Args);
+ CallParams:=CallParams+Args;
+ Code := TPCodeText.Create;
+ Code.Content := Format(Decl, [ARoutineType, AObjectName, AObjectFunctionName, ParenParams(Params), AFunctionReturns])+
+ Format(Body, [ResultStr, Self.UnitName+'.'+AFlatFunctionName, CallParams]);
+ ImplementationSection.Declarations.Add(Code);
+
+
+end;
+
+function TPascalUnit.WriteCallBack(AItem: TgirFunction; IsInObject: Boolean; AExistingUsedNames: TStringList = nil): String;
+var
+ RoutineType: String;
+ Returns: String;
+ CBName: String;
+ Symbol: String;
+ Params: String;
+begin
+ WriteFunctionTypeAndReturnType(AItem, RoutineType, Returns);
+
+ if IsInObject then
+ begin
+ CBName:=SanitizeName(AItem.Name, AExistingUsedNames);
+ Symbol := ': ';
+ end
+ else
+ begin
+ CBName:=MakePascalTypeFromCType(AItem.CType);
+ Symbol := ' = ';
+ end;
+
+ Params := WriteFunctionParams(AItem.Params);
+
+ Result := CBName+Symbol+RoutineType+ParenParams(Params)+Returns;
+
+end;
+
+procedure TPascalUnit.WriteFunctionTypeAndReturnType(AItem: TgirFunction;
+ out AFunctionType, AFunctionReturnType: String);
+begin
+ ResolveTypeTranslation(AItem.Returns.VarType);
+ if (AItem.Returns.VarType.CType = 'void') and (AItem.Returns.PointerLevel = 0) then
+ begin
+ AFunctionType:='procedure';
+ AFunctionReturnType := '; cdecl;';
+ end
+ else
+ begin
+ AFunctionType:='function';
+ AFunctionReturnType:= ': '+TypeAsString(AItem.Returns.VarType, AItem.Returns.PointerLevel)+'; cdecl;' ;
+
+ // will skip if written
+ ProcessType(AItem.Returns.VarType);
+ end;
+end;
+
+function TPascalUnit.WriteFunctionParams(AParams: TgirParamList; AArgs: PString = nil): String;
+var
+ i: Integer;
+ ArgName: String;
+begin
+ Result := '';
+ if AArgs <> nil then
+ AArgs^ := '';
+ for i := 0 to AParams.Count-1 do
+ begin
+ Result := Result+WriteParamAsString(AParams.Param[i], i, @ArgName);
+ if i < AParams.Count-1 then
+ begin
+ Result := Result +'; ';
+ if AArgs <> nil then
+ AArgs^:=AArgs^+ArgName+', ';
+ end
+ else
+ if AArgs <> nil then
+ AArgs^:=AArgs^+ArgName;
+ end;
+end;
+
+function TPascalUnit.TypeAsString(AType: TGirBaseType; APointerLevel: Integer; ACTypeAsBackup: String = ''): String;
+var
+ BackupNoPointers: String;
+begin
+ ResolveTypeTranslation(AType);
+
+ BackupNoPointers := StringReplace(ACTypeAsBackup, '*', '', [rfReplaceAll]);
+
+ if APointerLevel = 0 then
+ begin
+ Result := AType.TranslatedName;
+ if Result = '' then
+ Result := NameSpace.LookupTypeByName(BackupNoPointers, '').TranslatedName;
+ end
+ else
+ begin
+ if AType.CType = '' then
+ AType.CType:=ACTypeAsBackup;
+ Result := MakePascalTypeFromCType(AType.CType, APointerLevel);
+ end;
+ if APointerLevel > AType.ImpliedPointerLevel then
+ begin
+ WriteLn('Trying to use a pointerlevel > written level!');
+ Halt;
+ end;
+end;
+
+procedure TPascalUnit.AssembleUsedFieldNamesFromParent(const AParent: TgirClass; var AUsedNamesList: TStringList);
+var
+ Field: TGirBaseType;
+ i: Integer;
+begin
+ if AParent = nil then
+ Exit;
+
+ AssembleUsedFieldNamesFromParent(AParent.ParentClass, AUsedNamesList);
+ for i := 0 to AParent.Fields.Count-1 do
+ begin
+ Field := AParent.Fields.Field[i];
+ case Field.ObjectType of
+ otArray,
+ otTypeParam,
+ otCallback,
+ otProperty:
+ begin
+ // adds name to list
+ SanitizeName(Field.Name, AUsedNamesList);
+ end;
+ end;
+ end;
+end;
+
+function TPascalUnit.WriteParamAsString(AParam: TgirTypeParam; AIndex: Integer; AFirstParam: PString = nil; AExistingUsedNames: TStringList = nil): String;
+var
+ PT: String;
+ PN: String;
+ IsArray: Boolean;
+ AnArray: TgirArray absolute AParam;
+begin
+ if AParam.VarType = nil then
+ begin
+ // is a varargs param
+ Result := 'args: array of const';// 'args: varargs'; // varargs must be append to the function definition also this is more clear to the user
+ exit;
+ end;
+
+
+ IsArray := AParam.InheritsFrom(TgirArray) ;
+
+ //if Length(AParam.VarType.Name) < 1 then
+ //begin
+ //WriteLn('AParam.VarType.Name is empty. AParam.Name = ', AParam.Name,' AParam.CType = ', AParam.CType, ' AParam.VarType.CType = ',AParam.VarType.CType);
+ //end;
+ PT := '';
+ if IsArray and (AnArray.FixedSize > 0) then
+ PT := 'array [0..'+IntToStr(TgirArray(AParam).FixedSize-1)+'] of ' ;
+ PT := PT+ TypeAsString(AParam.VarType, AParam.PointerLevel, AParam.CType);
+
+ if IsArray and (AnArray.FixedSize = 0) then
+ PN := AnArray.ParentFieldName
+ else
+ PN := AParam.Name;
+
+
+ if PN = '' then
+ PN := 'param'+IntToStr(AIndex);
+ PN := SanitizeName(PN, AExistingUsedNames);
+
+ if AFirstParam <> nil then
+ AFirstParam^:=PN;
+
+ if AParam.Bits > 0 then
+ begin
+ case AParam.Bits of
+ //16: PT := 'guint16 { changed from '+PT+' to accomodate 16 bitsize requirement }';
+ //32: PT := 'guint32 { changed from '+PT+' to accomodate 32 bitsize requirement }';
+ 1..32:
+ PT := Format('guint%d { changed from %s to accomodate %d bitsize requirement }',[AParam.Bits, PT, AParam.Bits]);
+ else
+ WriteLn('WARNING: Bits are Set to [ ',AParam.Bits,' ]for: ' ,PN+': '+PT);
+ PT +=' { ERROR : Bits are Set to [ '+IntToStr(AParam.Bits)+' ] }';
+ end;
+
+ end;
+ Result := PN +': '+PT;
+
+
+
+
+
+ ProcessType(AParam.VarType, AParam.PointerLevel = 0); // will skip if written
+end;
+
+function TPascalUnit.WriteRecord(ARecord: TgirRecord; ABaseIndent: Integer = 0; AIsUnion: Boolean = False): String;
+var
+ TypeDecl: TStringList;
+ i: Integer;
+ Field: TGirBaseType;
+ UseName: String;
+ Symbol: String;
+begin
+ TypeDecl := TStringList.Create;
+ TypeDecl.Add('');
+ if Not AIsUnion then
+ begin
+ UseName:=ARecord.TranslatedName;
+ Symbol := ' = ';
+ end
+ else
+ begin
+ UseName:=ARecord.Name;
+ Symbol:= ' : ';
+ end;
+ TypeDecl.Add(IndentText(UseName +Symbol+ 'record',ABaseIndent+2,0));
+
+ // If a type size = 0 then this can cause problems for the compiler! bug 20265
+ if ARecord.Fields.Count = 0 then
+ TypeDecl.Add(IndentText('Unknown: Pointer;', ABaseIndent+4,0));
+
+ for i := 0 to ARecord.Fields.Count-1 do
+ begin
+ Field := ARecord.Fields.Field[i];
+ case Field.ObjectType of
+ otArray,
+ otTypeParam: TypeDecl.Add(IndentText(WriteParamAsString(TgirTypeParam(Field),i)+';',ABaseIndent+4,0));
+ otCallback : TypeDecl.Add(IndentText(WriteCallBack(TgirCallback(Field),True),ABaseIndent+4,0));
+ otUnion: TypeDecl.Add(IndentText(WriteUnion(TgirUnion(Field), True, ABaseIndent),ABaseIndent+4));
+ else
+ TypeDecl.Add(IndentText(Field.Name+ ' ' + Field.ClassName,4,0)); // this of course will make the compiler barf
+ end;
+
+ end;
+ TypeDecl.Add(IndentText('end;',ABaseIndent+2,1));
+ Result := TypeDecl.Text;
+end;
+
+function TPascalUnit.WriteUnion(AUnion: TgirUnion; ASkipRecordName: Boolean; ABaseIndent: Integer
+ ): String;
+var
+ Union: TStringList;
+ i: Integer;
+ Field: TGirBaseType;
+begin
+ Union := TStringList.Create;
+
+ if not ASkipRecordName then
+ Union.Add(IndentText(AUnion.TranslatedName+' = record', ABaseIndent,0));
+ if AUnion.Fields.Count > 0 then
+ Union.Add(IndentText('case longint of',ABaseIndent+2,0));
+ for i := 0 to AUnion.Fields.Count-1 do
+ begin
+ Field := AUnion.Fields.Field[i];
+ case Field.ObjectType of
+ otArray,
+ otTypeParam : Union.Add(IndentText(IntToStr(i)+ ' : ' +ParenParams(WriteParamAsString(TgirTypeParam(Field),i))+';',ABaseIndent+ 4,0));
+ otCallback : Union.Add(IndentText(IntToStr(i)+ ' : ' +ParenParams(WriteCallBack(TgirCallback(Field),True)),ABaseIndent+4,0));
+ otRecord : Union.Add(IndentText(IntToStr(i)+ ' : ' +ParenParams(WriteRecord(TgirRecord(Field),6, True))+';',ABaseIndent+4,0));
+ //WriteFunction(AFunction, AItem, AIsMethod, AWantWrapperForObject, AFunctionList): String;
+ otConstructor,
+ otFunction : Union.Add(IndentText('//'+WriteFunction(TgirFunction(Field), AUnion, False, False, WantFunctionSection.Lines), ABaseIndent+2,0));
+ otMethod : Union.Add(IndentText('//'+WriteFunction(TgirFunction(Field), AUnion, True, False, WantFunctionSection.Lines), ABaseIndent+2,0));
+ else
+ Union.Add('// Unhandled type for Union: '+ Field.ClassName); // this won't compile obviously
+ WriteLn('Unhandled type for Union: ', Field.ClassName);
+ end;
+
+ end;
+ if not ASkipRecordName then
+ Union.Add(IndentText('end;', ABaseIndent));
+ REsult := Union.Text;
+ Union.Free;
+
+end;
+
+function TPascalUnit.ParenParams(const AParams: String; const AForceParens: Boolean = False): String;
+begin
+ Result := '';
+ if (AParams <> '') or AForceParens then
+ Result := '('+AParams+')';
+end;
+
+function TPascalUnit.SanitizeName(AName: String; AExistingUsedNames: TStringList = nil): String;
+var
+ PascalReservedWords : array[0..30] of String =
+ ('begin', 'end', 'type', 'of', 'in', 'out', 'function', 'string','file', 'default',
+ 'procedure', 'string', 'boolean', 'array', 'set', 'destructor', 'destroy', 'program',
+ 'property', 'object', 'private', 'constructor', 'inline', 'result', 'interface',
+ 'const', 'raise', 'unit', 'label', 'xor', 'implementation');
+ Name: String;
+ Sanity: Integer = 0;
+ Sucess: Boolean;
+ TestName: String;
+begin
+ for Name in PascalReservedWords do
+ if Name = LowerCase(AName) then
+ Result := Aname+'_';
+ If Result = '' then
+ Result := AName;
+ if AName = 'CSET_A_2_Z' then
+ Result := 'CSET_A_2_Z_UPPER';
+ if AName = 'CSET_a_2_z' then
+ Result := 'CSET_a_2_z_lower';
+ Result := StringReplace(Result, '-','_',[rfReplaceAll]);
+ Result := StringReplace(Result, ' ','_',[rfReplaceAll]);
+
+ if AExistingUsedNames <> nil then
+ begin
+ // AExistingUsedNames must be set to sorted and duplucate strings caues an error;
+ TestName:=Result;
+ repeat
+ Inc(Sanity);
+ try
+ AExistingUsedNames.Add(TestName);
+ Result := TestName;
+ Sucess := True;
+ except
+ TestName := Result + IntToStr(Sanity);
+ Sucess := False;
+ end;
+
+ until Sucess or (Sanity > 300);
+ end;
+
+end;
+
+procedure TPascalUnit.ResolveTypeTranslation(ABaseType: TGirBaseType);
+begin
+ if ABaseType.TranslatedName = '' then
+ ABaseType.TranslatedName:=MakePascalTypeFromCType(ABaseType.CType, 0);
+end;
+
+constructor TPascalUnit.Create(ANameSpace: TgirNamespace; ALinkDynamic: Boolean);
+begin
+ ProcessLevel:=0;
+ FLinkDynamic := ALinkDynamic;
+ FFinalizeSection := TPFinialization.Create(Self);
+ FImplementationSection := TPImplementation.Create(Self);
+ FInitializeSection := TPInitialize.Create(Self);
+ FInterfaceSection := TPInterface.Create(Self, TPUses.Create);
+ FNameSpace := ANameSpace;
+ ResolveFuzzyTypes;
+ GenerateUnit;
+end;
+
+procedure TPascalUnit.ProcessConsts(AList: TList);
+ function WriteConst(AConst: TgirConstant; Suffix: String = ''): String;
+ begin
+ if AConst.IsString then
+ Result := SanitizeName(AConst.Name) + Suffix+' = '+QuotedStr(AConst.Value)+';'
+ else
+ Result := SanitizeName(AConst.Name) + Suffix+' = '+AConst.Value+';';
+ end;
+
+var
+ NewConst: TPDeclarationConst;
+ Item: TgirConstant;
+ i: Integer;
+ Consts: TStringList; // this is to check for duplicates
+ Entry: String;
+ Suffix: String;
+ Sanity: Integer;
+begin
+ NewConst := WantConstSection;
+ Consts := TStringList.Create;
+ Consts.Sorted:=True;
+ Consts.Duplicates:=dupError;
+
+
+ for i := 0 to AList.Count-1 do
+ begin
+ Sanity := 0;
+ Suffix := '';
+ Item := TgirConstant(AList.Items[i]);
+ //if Item.ClassType <> TgirConstant then ; // raise error
+ Entry := LowerCase(SanitizeName(Item.Name));
+
+ repeat
+ try
+ Consts.AddObject(Entry, TObject(PtrUInt(NewConst.Lines.Count)));
+ break;
+ except
+ Suffix := '__'+IntToStr(Sanity);
+ Entry := LowerCase(SanitizeName(Item.Name))+Suffix;
+ end;
+ Inc(Sanity);
+ until Sanity > 10;
+
+ NewConst.Lines.AddObject(IndentText(WriteConst(Item, Suffix), 2,0), Item);
+ end;
+end;
+
+procedure TPascalUnit.ProcessTypes(AList: TFPHashObjectList);
+
+var
+ BaseType: TGirBaseType;
+ i: Integer;
+begin
+ if AList.Count = 0 then
+ Exit;
+
+ for i := 0 to AList.Count-1 do
+ begin
+ BaseType := TGirBaseType(AList.Items[i]);
+ ProcessType(BaseType);
+ end;
+
+end;
+
+procedure TPascalUnit.ProcessFunctions(AList: TList);
+var
+ i: Integer;
+ Func: TgirFunction;
+begin
+ for i := 0 to AList.Count-1 do
+ begin
+ Func := TgirFunction(AList.Items[i]);
+ HandleFunction(Func);
+ end;
+end;
+
+procedure TPascalUnit.GenerateUnit;
+var
+ i: Integer;
+ NS: TgirNamespace;
+begin
+ for i := 0 to FNameSpace.RequiredNameSpaces.Count-1 do
+ begin
+ NS := TgirNamespace(FNameSpace.RequiredNameSpaces.Items[i]);
+ InterfaceSection.UsesSection.Units.Add(' '+CalculateUnitName(NS.NameSpace,NS.Version));
+ end;
+
+ i := Pos(',',NameSpace.SharedLibrary);
+ if i > 0 then
+ LibName:=Copy(NameSpace.SharedLibrary,1,i-1)
+ else
+ LibName:=NameSpace.SharedLibrary;
+ WantConstSection.Lines.Add(IndentText(UnitName+'_library = '''+LibName+''';', 2));
+ if NameSpace.NameSpace = 'GLib' then
+ AddGLibSupportCode;
+
+end;
+
+function TPascalUnit.AsStream: TStringStream;
+var
+ Str: TStringStream absolute Result;
+ Libs: TStringList;
+ i: Integer;
+begin
+ Libs := TStringList.Create;
+ Libs.Delimiter:=',';
+ Libs.StrictDelimiter:= True;
+ Libs.CommaText:=NameSpace.SharedLibrary;
+
+ Result := TStringStream.Create('');
+ Str.WriteString(IndentText('unit '+ UnitName+';',0,2));
+ Str.WriteString(IndentText('{$MODE OBJFPC}{$H+}',0,2));
+ Str.WriteString(IndentText('{$PACKRECORDS C}',0,1));
+ Str.WriteString(IndentText('{$BITPACKING ON}',0,1));
+ //Str.WriteString(IndentText('{$CALLING CDECL}',0,2));
+ Str.WriteString(IndentText('{$MODESWITCH DUPLICATELOCALS+}',0,2));
+
+ for i := 0 to Libs.Count-1 do
+ Str.WriteString(IndentText('{$LINKLIB '+Libs.Strings[i]+'}',0,1));
+
+ Libs.Free;
+
+ Str.WriteString(InterfaceSection.AsString);
+ Str.WriteString(ImplementationSection.AsString);
+
+ if InitializeSection.Declarations.Count > 0 then
+ Str.WriteString(InitializeSection.AsString);
+
+ if FinalizeSection.Declarations.Count > 0 then
+ Str.WriteString(FinalizeSection.AsString);
+
+ Str.WriteString('end.');
+
+ Result.Position:=0;
+end;
+
+{ TPDeclarationList }
+
+function TPDeclarationList.GetDeclarations(AIndex: Integer): TPDeclaration;
+begin
+ Result := TPDeclaration(Items[AIndex]);
+end;
+
+function TPDeclarationList.AsString: String;
+var
+ i: Integer;
+begin
+ for i := 0 to Count-1 do
+ begin
+ Result := Result+Declarations[i].AsString+LineEnding;
+ end;
+end;
+
+{ TgirPascalWriter }
+
+constructor TgirPascalWriter.Create(ANameSpaces: TgirNamespaces);
+begin
+ FNameSpaces := ANameSpaces;
+ FUnits := TList.Create;
+end;
+
+procedure TgirPascalWriter.GenerateUnits;
+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.ProcessConsts(FNameSpaces.NameSpace[i].Constants);
+ FUnit.ProcessTypes(FNameSpaces.NameSpace[i].Types);
+ FUnit.ProcessFunctions(FNameSpaces.NameSpace[i].Functions);
+ FUnits.Add(FUnit);
+ FOnUnitWriteEvent(Self, FUnit.UnitName, FUnit.AsStream);
+ end;
+end;
+
+end.
+
diff --git a/applications/gobject-introspection/girtokens.pas b/applications/gobject-introspection/girtokens.pas
new file mode 100644
index 000000000..6bd381d67
--- /dev/null
+++ b/applications/gobject-introspection/girtokens.pas
@@ -0,0 +1,90 @@
+{
+girtokens.pas
+Copyright (C) 2011 Andrew Haines andrewd207@aol.com
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+as published by the Free Software Foundation; either version 2
+of the License, or (at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+}
+unit girTokens;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes;
+
+type
+ TGirToken = (gtInvalid, gtAlias, gtConstant, gtRecord, gtBitField, gtEnumeration,
+ gtCallback, gtUnion, gtFunction, gtReturnValue, gtType,
+ gtParameters, gtParameter, gtMember, gtField, gtMethod, gtArray,
+ gtDoc, gtConstructor, gtRepository, gtInclude, gtNameSpace, gtPackage,
+ gtCInclude, gtClass, gtProperty, gtVirtualMethod, gtInterface,
+ gtGlibSignal, gtImplements, gtPrerequisite,gtVarArgs, gtObject, gtClassStruct, gtGType);
+
+
+
+var
+ GirTokenName: array[TGirToken] of String = (
+ 'Invalid Name',
+ 'alias',
+ 'constant',
+ 'record',
+ 'bitfield',
+ 'enumeration',
+ 'callback',
+ 'union',
+ 'function',
+ 'return-value',
+ 'type',
+ 'parameters',
+ 'parameter',
+ 'member',
+ 'field',
+ 'method',
+ 'array',
+ 'doc',
+ 'constructor',
+ 'repository',
+ 'include',
+ 'namespace',
+ 'package',
+ 'c:include',
+ 'class',
+ 'property',
+ 'virtual-method',
+ 'interface',
+ 'glib:signal',
+ 'implements',
+ 'prerequisite',
+ 'varargs',
+ 'object',
+ 'classstruct',
+ 'gtype'
+ );
+
+ function GirTokenNameToToken(AName: String): TGirToken;
+
+implementation
+
+function GirTokenNameToToken(AName: String): TGirToken;
+begin
+ for Result in TGirToken do
+ if GirTokenName[Result] = AName then
+ Exit;
+ Result := gtInvalid;
+end;
+
+end.
+