paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-12 17:38:01 +02:00
Code Issues Packages Projects Releases Wiki Activity
8bb72e6ac4
lazarus/tools/gir2pascal/girobjects.pas

1443 lines
42 KiB
ObjectPascal
Raw Blame History

{
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;
FDeprecated: Boolean;
FDeprecatedMsg: String;
FDeprecatedOverride: Boolean;
FDeprecatedVersion: TGirVersion;
FDoc: String;
FForwardDefinitionWritten: Boolean;
FGLibGetType: String;
FHasFields: Boolean;
FImpliedPointerLevel: Integer;
FName: String;
FObjectType: TGirObjectType;
FDisguised: Boolean;
FOwner: TObject;
FTranslatedName: String;
FVersion: TGirVersion;
FWriting: TGirModeState;
procedure SetImpliedPointerLevel(AValue: Integer);
function MaybeResolvedType: TGirBaseType;
function GetPointerLevelFromCType(ACType: String = ''): Integer;
public
constructor Create(AOwner: TObject; ANode: TDomNode); virtual;
property CType: String read FCType write FCType;
property GLibGetType: String read FGLibGetType;
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: TGirVersion read FVersion;
property ForwardDefinitionWritten: Boolean read FForwardDefinitionWritten write FForwardDefinitionWritten;
property Writing: TGirModeState read FWriting write FWriting;
property Disguised: Boolean read FDisguised; // only access this type with the functions given not fieids directly.
property ObjectType: TGirObjectType read FObjectType;
property Deprecated: Boolean read FDeprecated;
property DeprecatedMsg: String read FDeprecatedMsg;
property DeprecatedVersion: TGirVersion read FDeprecatedVersion;
{ if an object that is not deprecated depends on this deprecated item then override it. }
property DeprecatedOverride: Boolean read FDeprecatedOverride write FDeprecatedOverride;
end;
{ TgirNativeTypeDef }
TgirNativeTypeDef = class(TGirBaseType)
private
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
FIsOpaque: Boolean;
FForType: TGirBaseType;
function GetForType: TGirBaseType;
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
constructor Create(AOwner: TObject; AName, ACType, ATranslatedName: String);
property IsOpaque: Boolean read FIsOpaque;
property ForType: TGirBaseType read GetForType write FForType;
end;
{ TgirTypeParam }
TgirTypeParam = class(TGirBaseType)
private
FIsConst: Boolean;
FIsInstanceParam: Boolean;
FVarType: TGirBaseType;
FPointerLevel: Integer;
function GetPointerLevel: Integer;
function GetType: TGirBaseType;
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
constructor Create(AOwner: TObject; ANode: TDomNode; AIsInstanceParam: Boolean); virtual;
property VarType: TGirBaseType read GetType;
property PointerLevel: Integer read GetPointerLevel;
property IsInstanceParam: Boolean read FIsInstanceParam;
property IsConst: Boolean read FIsConst;
end;
{ TgirProperty }
TgirProperty = class(TgirBaseType)
private
FIsArray: Boolean;
FPropType: TgirBaseType;
FWriteable: Boolean;
function GetPropType: TgirBaseType;
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
property PropType: TgirBaseType read GetPropType;
property Writable: Boolean read FWriteable;
property IsArray: Boolean read FIsArray;
end;
{ TgirArray }
TgirArray = class(TgirTypeParam)
private
FFixedSize: Integer;
FParentFieldName: String;
FNode: TDOMNode;
function GetBestPointerLevel: Integer; // only works while the Constructor is active.
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
property FixedSize: Integer read FFixedSize;
property ParentFieldName: String read FParentFieldName;
end;
{ TgirConstant }
TgirConstant = class(TGirBaseType)
private
FCName: String;
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;
property CName: String read FCName;
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;
FNeedsSignedType: Boolean;
FNotIntTypeEnum: Boolean;
procedure AddMember(AName, AValue, ACIdentifier: String; Node: TDomElement);
procedure HandleFunction(ANode: TDomNode);
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
destructor Destroy; override;
property Members: TgirEnumList read FMembers;
property NeedsSignedType: Boolean read FNeedsSignedType;
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;
constructor Create(AOwner: TObject; ANode: TDomNode; AIsInstanceParam: Boolean); 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;
FParams: TgirParamList;
FReturns: TgirFunctionReturn;
FThrowsGError: Boolean;
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 ThrowsGError: Boolean read FThrowsGError write FThrowsGError;
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(TList)
private
FHasFields: Boolean;
function GetField(AIndex: Integer): TGirBaseType;
protected
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
public
property Field[AIndex: Integer]: TGirBaseType read GetField;
end;
{ tgirRecord }
TgirRecord = class(TGirBaseType)
private
FFields: TgirFieldsList;
function GetHasFields: Boolean;
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;
property HasFields: Boolean read GetHasFields;
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 }
TgirClass = class;
TgirClassStruct = class(TgirGType)
private
FIsClassStructFor: TgirClass;
function GetIsClassStructFor: TgirClass;
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
property IsClassStructFor: TgirClass read GetIsClassStructFor;
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)
public
constructor Create(AOwner: TObject; ANode: TDomNode); override;
procedure ParseNode(ANode: TDomNode; ANodeType: TGirToken); override;
end;
implementation
uses girNameSpaces, girErrors, XMLRead;
{ TgirClassStruct }
function TgirClassStruct.GetIsClassStructFor: TgirClass;
begin
Result := nil;
if FIsClassStructFor.ObjectType = otFuzzyType then
begin
if TgirFuzzyType(FIsClassStructFor).ResolvedType <> nil then
FIsClassStructFor := TgirClass(TgirFuzzyType(FIsClassStructFor).ResolvedType);
end;
Result := FIsClassStructFor;
end;
constructor TgirClassStruct.Create(AOwner: TObject; ANode: TDomNode);
var
IsClassForName: String;
begin
inherited Create(AOwner, ANode);
FObjectType:=otClassStruct;
IsClassForName:= (ANode as TDOMElement).GetAttribute('glib:is-gtype-struct-for');
if IsClassForName <> '' then
begin
FIsClassStructFor := TgirClass((Owner as TgirNamespace).LookupTypeByName(IsClassForName, '', True));
if (FIsClassStructFor <> nil) and (FIsClassStructFor.ObjectType = otClass) then
FIsClassStructFor.FClassStruct := Self;
end;
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;
FHasFields:=True;
end;
{ TgirFieldsList }
function TgirFieldsList.GetField(AIndex: Integer): TGirBaseType;
begin
Result := TGirBaseType(Items[AIndex]);
end;
procedure TgirFieldsList.Notify(Ptr: Pointer; Action: TListNotification);
var
gir: TGirBaseType absolute Ptr;
begin
if FHasFields then
Exit;
FHasFields:= gir.ObjectType in [otTypeParam, otCallback, otArray];
end;
{ TgirParamList }
function TgirParamList.GetParam(AIndex: Integer): TGirFunctionParam;
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
FVersion := TgirNamespace(FOwner).Version.AsMajor;
FDeprecatedVersion := girVersion(MaxInt, MaxInt);
//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 }
function TgirProperty.GetPropType: TgirBaseType;
begin
Result := FPropType;
if Assigned(Result) and Result.InheritsFrom(TgirFuzzyType) and (TgirFuzzyType(Result).ResolvedType <> nil) then
Result := TgirFuzzyType(Result).ResolvedType;
end;
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,
gtDocDeprecated:; // 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
Result := FParentClass;
if (FParentClass <> nil) and (FParentClass.ObjectType = otFuzzyType) 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');
if Parent = '' then
FParentClass := nil
else
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 }
function TgirArray.GetBestPointerLevel: Integer;
var
ArrayCType: String;
TypeCType: String;
TypeNode: TDOMElement;
ArrayCTypeLevel,
TypeCTypeLevel: Integer;
begin
ArrayCType:=TDOMElement(FNode).GetAttribute('c:type');
TypeNode := TdomElement(FNode.FindNode('type'));
TypeCType:=TDOMElement(TypeNode).GetAttribute('c:type');
ArrayCTypeLevel := GetPointerLevelFromCType(ArrayCType);
TypeCTypeLevel := GetPointerLevelFromCType(TypeCType);
if ArrayCTypeLevel > TypeCTypeLevel then
begin
FCType:=ArrayCType;
Exit(ArrayCTypeLevel)
end;
Result := TypeCTypeLevel;
//FCType:=TypeCType; // already assigned in TgirTypeParam.Create
end;
constructor TgirArray.Create(AOwner: TObject; ANode: TDomNode);
var
Node: TDomELement;
begin
FObjectType:=otArray;
FNode := ANode;
inherited Create(AOwner, ANode);
// ctype is in two places for arrays. one as an attribute of the array node.
// and in the subnode 'type' assigned above in inherited Create.
FPointerLevel:=GetBestPointerLevel;
Node := TDomElement(ANode.FindNode('type'));
if Node <> nil then
begin
FVarType := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), CType);
FVarType.ImpliedPointerLevel:=FPointerLevel;
TryStrToInt(TDomElement(ANode).GetAttribute('fixed-size'), FFixedSize);
end;
Node := TDOMElement(ANode.ParentNode);
FParentFieldName := Node.GetAttribute('name');
if FName = '' then
FName := FParentFieldName;
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 }
function TgirRecord.GetHasFields: Boolean;
begin
Result := Fields.FHasFields;
end;
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;
begin
Node := ANode.FirstChild;
while Node <> nil do
begin
case GirTokenNameToToken(Node.NodeName) of
gtDoc,
gtDocDeprecated:;
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,
gtDocDeprecated,
gtSourcePosition:;
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;
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);
end;
constructor TGirFunctionParam.Create(AOwner: TObject; ANode: TDomNode; AIsInstanceParam: Boolean);
begin
inherited Create(AOwner, ANode, AIsInstanceParam);
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;
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;
function AssignC_Type(C_Type: String): String;
begin
if Pos('const ', C_Type) > 0 then
begin
FIsConst:=True;
Result := Copy(C_Type, 7, Length(C_Type));
end
else
Result := C_Type;
{ Pascal doesn't support the concept of "pointer to const", so let's reduce
some special cases by stripping the "const" keyword. }
// used by GLib-2.0.gir and Gio-2.0.gir
Result := StringReplace(Result, 'gchar* const*', 'gchar**', [rfReplaceAll]);
end;
var
Node: TDOMElement;
C_Type: String;
Tmp: String;
Token: TGirToken;
VarTypeName: String;
SubTypeNode: TDomElement;
SubTypeName: String;
ParamDir: TGirToken;
ParamPointerLevel: Integer;
begin
inherited Create(AOwner, ANode);
//NodeURL(ANode);
//Node := TDomELement(ANode.FindNode('type'));
Node := TDOMElement(ANode.FirstChild);
if Node = nil then
girError(geError, Format(geMissingNode,[ClassName, '', ANode.NodeName]));
FPointerLevel:=-1;
ParamDir:= GirTokenNameToToken(TDomElement(ANode).GetAttribute('direction'));
case ParamDir of
gtIn,
gtEmpty: ParamPointerLevel := 0;
gtOut,
gtInOut: ParamPointerLevel := 1;
end;
while Node <> nil do
begin
// it's one or the other
Token := GirTokenNameToToken(Node.NodeName);
case Token of
gtDoc,
gtDocDeprecated:;
gtType: begin
C_Type := AssignC_Type(Node.GetAttribute('c:type'));
FCType:= C_Type;
VarTypeName:=Node.GetAttribute('name');
if VarTypeName = '' then
VarTypeName:= StringReplace(C_Type, '*', '', [rfReplaceAll]);
FVarType := TgirNamespace(Owner).LookupTypeByName(VarTypeName, C_Type);
SubTypeNode := TDomElement(Node.FindNode('type'));
if SubTypeNode <> nil then
begin
SubTypeName := SubTypeNode.GetAttribute('name');
if (SubTypeName = 'any') or (SubTypeName = 'gpointer') then // 'any' means gpointer for some reason
Inc(ParamPointerLevel);
end;
if InheritsFrom(TgirArray) then
ParamPointerLevel:=TgirArray(Self).GetBestPointerLevel
else if GetPointerLevelFromCType > ParamPointerLevel then
ParamPointerLevel:=GetPointerLevelFromCType;
end;
gtArray: begin
C_Type := AssignC_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);
if PointerLevelFromVarName(C_Type) > ParamPointerLevel then
ParamPointerLevel:=PointerLevelFromVarName(C_Type);
if (ParamPointerLevel = 0) and (ParamDir in [gtOut, gtInOut]) then
ParamPointerLevel:=1;
end;
gtVarArgs: begin
FVarType := nil
end
else
girError(geError, Format(geUnexpectedNodeType,[ClassName, Node.NodeName, GirTokenName[gtParameter]]));
end;
Node := TDOMElement(Node.NextSibling);
end;
//if FPointerLevel = -1 then
// FPointerLevel := PointerLevelFromVarName(C_Type);
if ParamPointerLevel > FPointerLevel then
FPointerLevel:=ParamPointerLevel;
if (FVarType <> nil) {and (GirTokenNameToToken(ANode.NodeName) = gtArray)} then
begin
FVarType.ImpliedPointerLevel:=FPointerLevel;
//FVarType.ImpliedPointerLevel := PointerLevelFromVarName(CType);
if FVarType.Deprecated and (TgirNamespace(Owner).DeprecatedVersion <= DeprecatedVersion) and not FVarType.DeprecatedOverride then
begin
girError(geWarn, Format('Type %s is deprecated but is used by %s. Including %s',[FVarType.CType, Name, FVarType.CType]));
FVarType.DeprecatedOverride:=True;
end;
end;
if (FVarType <> nil) and (Token <> gtVarArgs) then
FVarType.ImpliedPointerLevel:=PointerLevel; //only will grow
if (FVarType = nil) and (Token <> gtVarArgs) then
begin
WriteLn('Vartype name = ',VarTypeName);
VarTypeName := ANode.NodeName;
Node := TDOMElement(Anode.ParentNode);
while Node <> nil do
begin
if node.InheritsFrom(TDOMElement) then
VarTypeName := Node.NodeName + '('+Node.GetAttribute('name')+')/'+ VarTypeName
else
VarTypeName := Node.NodeName + '/'+ VarTypeName;
Node := TDOMElement(Node.ParentNode);
end;
WriteLn('Vartype is nil when it shouldnt be! '+VarTypeName );
raise Exception.Create('Vartype is nil when it shouldn''t be! ');
end;
FObjectType:=otTypeParam;
end;
constructor TgirTypeParam.Create(AOwner: TObject; ANode: TDomNode;
AIsInstanceParam: Boolean);
begin
FIsInstanceParam:=AIsInstanceParam;
Create(AOwner, ANode);
end;
{ TgirFunction }
constructor TgirFunction.Create(AOwner: TObject; ANode: TDomNode);
var
Node: TDOMNode;
NodeToken: TGirToken;
procedure CheckAddErrorParam(ParentNode: TDomNode);
//const
// ErrorXML = '<parameter name="error"> <type name="Error" c:type="GError**"/> </parameter>';
var
Param: TGirFunctionParam;
AddParam: Boolean;
ErrorNode: TDOMElement;
TypeNode: TDOMElement;
begin
// some functions have throws=1 as a property of the node. This indicates that
// the last parameter is GError **error. The introspection file does not include
// this as a parameter so we have to add it ourselves
AddParam:=False;
if FParams.Count > 0 then
begin
Param := FParams.Param[FParams.Count-1];
//WriteLn(Param.CType);
if Param.CType <> 'GError**' then
begin
AddParam:=True;
end;
end
else
AddParam:=True;
if AddParam then
begin
//girError(geInfo, Format(geAddingErrorNode,[ClassName, CIdentifier]));
ErrorNode := ParentNode.OwnerDocument.CreateElement('parameter');
ErrorNode.SetAttribute('name','error');
TypeNode := ParentNode.OwnerDocument.CreateElement('type');
ErrorNode.AppendChild(TypeNode);
TypeNode.SetAttribute('name','Error');
TypeNode.SetAttribute('c:type','GError**');
ParentNode.AppendChild(ErrorNode);
end;
end;
procedure CreateParameters(ANode: TDomNode);
var
PNode: TDomNode;
Param: TGirFunctionParam;
begin
PNode := ANode.FirstChild;
while PNode <> nil do
begin
case GirTokenNameToToken(PNode.NodeName) of
gtDoc,
gtDocDeprecated:;
gtParameter:
begin
Param := TGirFunctionParam.Create(AOwner, PNode, False);
FParams.Add(Param);
end;
gtInstanceParameter:
begin
Param := TGirFunctionParam.Create(AOwner, PNode, True);
FParams.Add(Param);
end;
else
girError(geError, Format(geUnexpectedNodeType,[ClassName, PNode.NodeName, GirTokenName[gtParameter]]));
end;
if FThrowsGError and (PNode.NextSibling = nil) then
CheckAddErrorParam(ANode); // may add a NextSibling
PNode := PNode.NextSibling;
end;
end;
begin
inherited Create(AOwner, ANode);
FParams := TgirParamList.Create;
FCIdentifier:=TDOMElement(ANode).GetAttribute('c:identifier');
ThrowsGError:=TDOMElement(ANode).GetAttribute('throws') = '1';
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,
gtDocDeprecated,
gtSourcePosition:;
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;
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;
Node: TDomElement);
var
Member: PgirEnumMember;
IntValue: LongInt;
FailPoint: Integer;
begin
if (ACIdentifier = '') and Assigned(Node) then
begin
// sometimes there is an attribute child node
Node := TDomElement(Node.FirstChild);
while Node <> nil do
begin
if Node.NodeName = 'attribute' then
begin
if Node.GetAttribute('name') = 'c:identifier' then
ACIdentifier:=Node.GetAttribute('value');
end;
Node := TDomElement(Node.NextSibling);
end;
end;
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_';
// See of the enum needs a signed type or not. Probably not.
if not FNotIntTypeEnum and not FNeedsSignedType then
begin
Val(AValue, IntValue, FailPoint);
if (FailPoint = 0) and (Length(AValue) > 0) and (AValue[1] = '-') then
FNeedsSignedType:=True;
if FailPoint <> 0 then
FNotIntTypeEnum:=True; // so we won't continue trying to convert invalid values to ints.
end;
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,
gtDocDeprecated,
gtSourcePosition:;
gtMember: AddMember(Node.GetAttribute('name'), Node.GetAttribute('value'),Node.GetAttribute('c:identifier'), Node);
// 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);
FCName:=TDomELement(ANode).GetAttribute('c:type');
if FCName = '' then
FCName := FName;
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*') or (Node.GetAttribute('name') = 'utf8');
//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;
if Assigned(FResolvedType) then
FResolvedType.ImpliedPointerLevel:=ImpliedPointerLevel;
//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;
FVersion := TgirNamespace(FOwner).Version.AsMajor;
FDeprecatedVersion := girVersion(MaxInt, MaxInt); // not deprecated
//girError(geFuzzy, 'Creating Fuzzy Type "'+AName+'/'+ACtype+'"');
end;
{ TgirAlias }
function TgirAlias.GetForType: TGirBaseType;
begin
if (FForType <> nil) and (FForType.ObjectType = otFuzzyType) and (TgirFuzzyType(FForType).ResolvedType <> nil) then
FForType := TgirFuzzyType(FForType).ResolvedType;
Result := FForType;
end;
constructor TgirAlias.Create(AOwner: TObject; ANode: TDomNode);
var
TmpNode, Node: TDOMElement;
NodePath, NodeName, NodeCType: String;
begin
inherited Create(AOwner, ANode);
NodePath := '';
Node := TDomELement(ANode.FindNode('type'));
TmpNode := Node;
while TmpNode <> nil do
begin
if TmpNode.InheritsFrom(TDOMElement) then
NodePath := TmpNode.NodeName + '('+TmpNode.GetAttribute('name')+')/'+ NodePath
else
NodePath := TmpNode.NodeName + '/'+ NodePath;
TmpNode := TDOMElement(TmpNode.ParentNode);
end;
NodeName := Node.GetAttribute('name');
NodeCType := Node.GetAttribute('c:type');
{ "alias" might implicitly declare an 'opaque' data type. In that case we want
to substitute the type (so that a suitable fuzzy type gets added), and tag
the current object; which allows TPascalUnit.HandleAlias() to take care of
correctly emitting the opaque type (= Pascal record) later. }
if (NodeName = 'none') and (NodeCType = 'void') then
begin
FIsOpaque := True;
Node := ANode as TDOMElement;
if Node.hasAttribute('name') then
NodeName := Node.GetAttribute('name'); // "name" attribute of ANode
if Node.hasAttribute('c:type') then
NodeCType := Node.GetAttribute('c:type'); // "c:type" attribute of ANode
end;
//WriteLn('ALIAS: ', NodeName, ' ', NodePath);
FForType := TgirNamespace(Owner).LookupTypeByName(NodeName, NodeCType);
if FIsOpaque then assert(FForType.ObjectType = otFuzzyType); // sanity check
FObjectType:=otAlias;
end;
constructor TgirAlias.Create(AOwner: TObject; AName, ACType,
ATranslatedName: String);
begin
FOwner := AOwner;
FName:=AName;
FCType:=ACType;
FTranslatedName:=ATranslatedName;
FObjectType:=otAlias;
FVersion := TgirNamespace(FOwner).Version.AsMajor;
FDeprecatedVersion := girVersion(MaxInt, MaxInt); // not deprecated
end;
{ TGirBaseType }
procedure TGirBaseType.SetImpliedPointerLevel(AValue: Integer);
begin
if FImpliedPointerLevel<AValue then
begin
FImpliedPointerLevel:=AValue;
end;
if FImpliedPointerLevel > 3 then
FImpliedPointerLevel:=3;
end;
function TGirBaseType.MaybeResolvedType: TGirBaseType;
begin
if Self.InheritsFrom(TgirFuzzyType) and (TgirFuzzyType(Self).ResolvedType <> nil) then
Result := TgirFuzzyType(Self).ResolvedType
else
Result := Self;
end;
function TGirBaseType.GetPointerLevelFromCType(ACType: String): Integer;
var
C: Char;
begin
if ACType = '' then
ACType:=FCType;
Result := 0;
for C in ACType do
if C = '*' then
Inc(Result);
end;
constructor TGirBaseType.Create(AOwner: TObject; ANode: TDomNode);
var
Element: TDOMElement absolute ANode;
Node: TDomNode;
AttrValue: String;
begin
if ANode = nil then
girError(geError, 'Creating '+ClassName+' with a nil node');
FOwner := AOwner;
FCType := Element.GetAttribute('c:type');
if FCType = '' then
FCType := Element.GetAttribute('glib:type-name');
FName := Element.GetAttribute('name');
try
FVersion:= girVersion(Element.GetAttribute('version'));
except
FVersion := TgirNamespace(FOwner).Version.AsMajor;
end;
FDisguised := Element.GetAttribute('disguised') = '1';
FGLibGetType:= Element.GetAttribute('glib:get-type');
AttrValue := Element.GetAttribute('bits');
if AttrValue <> '' then
FBits := StrToInt(AttrValue);
Node := ANode.FindNode('doc');
if Node <> nil then
FDoc := Node.FirstChild.TextContent;
ImpliedPointerLevel:=2;
FDeprecated:=TDOMElement(ANode).GetAttribute('deprecated') = '1';
if FDeprecated then
begin
Node := ANode.FindNode('doc-deprecated');
if Node <> nil then
begin
FDeprecatedMsg:=StringReplace(Node.TextContent, #10, ' ', [rfReplaceAll]);
FDeprecatedMsg := StringReplace(FDeprecatedMsg, '''', '''''', [rfReplaceAll]); // replace ' with ''
end;
try
FDeprecatedVersion:=girVersion(TDOMElement(ANode).GetAttribute('deprecated-version'));
except
FDeprecatedVersion:=TgirNamespace(FOwner).Version.AsMajor;
end;
end
else
FDeprecatedVersion := girVersion(MaxInt, MaxInt); // not deprecated
FObjectType:=otBaseType;
end;
end.
Reference in New Issue View Git Blame Copy Permalink