{ 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 FForType: TGirBaseType; function GetForType: TGirBaseType; public constructor Create(AOwner: TObject; ANode: TDomNode); override; constructor Create(AOwner: TObject; AName, ACType, ATranslatedName: String); 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:; 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; 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 = ' '; 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:; 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:; 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: String; begin inherited Create(AOwner, ANode); 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; //WriteLn('ALIAS: ', Node.GetAttribute('name')+' ', NodePath); FForType := TgirNamespace(Owner).LookupTypeByName(Node.GetAttribute('name'), Node.GetAttribute('c:type')); 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 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.